Télécharger la plaquette Cast3M


fr en

Télécharger deco1.eso

Retour à la liste

Numérotation des lignes : 

deco1

  1. C DECO1     SOURCE    OF166741  25/02/21    21:15:46     12166          
  2.       SUBROUTINE DECO1(IPMODL,IPCHE2,IPCHE1,IPCHL1,IRET)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. *____________________________________________________________________*
  6. *                                                                    *
  7. *     Sous-programme de l'op{rateur DECO                             *
  8. *                                                                    *
  9. *     Entr{es:                                                       *
  10. *                                                                    *
  11. *        IPMODL    Pointeur sur un objet MMODEL                      *
  12. *        IPCHE2    Pointeur sur un MCHAML de FONCTION DE COURANT     *
  13. *        IPCHE1    Pointeur sur un MCHAML de CARACTERISTIQUES        *
  14. *                                                                    *
  15. *     Sortie:                                                        *
  16. *                                                                    *
  17. *        IPCHL1    Pointeur sur un MCHAML de courants                *
  18. *        IRET       1 si succes , 0 sinon                            *
  19. *                                                                    *
  20. *     Auteurs, date de cr{ation:                                     *
  21. *                                                                    *
  22. *        Yann Stephan, le 22/09/97                                   *
  23. *                                                                    *
  24. *____________________________________________________________________*
  25. *
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29. -INC CCHAMP
  30.  
  31. -INC SMCHAML
  32. -INC SMMODEL
  33. -INC SMELEME
  34. -INC SMINTE
  35. -INC SMCOORD
  36.  
  37. -INC TMPTVAL
  38.  
  39.       SEGMENT,MMAT1
  40.          REAL*8 VALMAT(NMATR)
  41.          REAL*8 XE(3,NBNN),XE1(3,NBNN)
  42.          REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN,NBPGAU)
  43.          REAL*8 COSD1(3),COSD2(3)
  44.       ENDSEGMENT
  45.       POINTEUR MMAT2.MMAT1,MMATX.MMAT1
  46. *
  47.       SEGMENT SGAUSS
  48.         REAL*8 XGAUSS(3,NBPGAU)
  49.         REAL*8 DX(NBPGAU)
  50.       ENDSEGMENT
  51.       POINTEUR SGX.SGAUSS,SGY.SGAUSS
  52. *
  53.       SEGMENT,MWRK1
  54.          REAL*8 XDDL(LRE)
  55.       ENDSEGMENT
  56. *
  57.       SEGMENT INFO
  58.         INTEGER INFELL(JG)
  59.       ENDSEGMENT
  60. *
  61.       SEGMENT NOTYPE
  62.         CHARACTER*16 TYPE(NBTYPE)
  63.       ENDSEGMENT
  64. *
  65.       CHARACTER*8  CMATE
  66.       CHARACTER*(NCONCH) CONM
  67.       PARAMETER ( NINF=3 )
  68.       INTEGER INFOS(NINF)
  69.       LOGICAL lsupgd
  70.  
  71.       lsupgd=.false.
  72.       IRET=1
  73.       MWRK1=0
  74.       NMAT = 0
  75.       ITHER= 0
  76.       IMAGN= 0
  77.       NHRM = NIFOUR
  78. *
  79. *     ACTIVATION DU CHAPEAU DE MODELE
  80. *
  81.       MMODEL = IPMODL
  82.       SEGACT MMODEL
  83.       NSOUS = KMODEL(/1)
  84. *
  85. *     Initialisation du CHAMELEM de COURANTS
  86. *
  87.       L1 = 8
  88.       N1 = NSOUS
  89.       N3 = 6
  90.       SEGINI,MCHELM
  91.       IPCHL1=MCHELM
  92.       TITCHE = 'COURANT'
  93.       IFOCHE=IFOUR
  94. *
  95. *     Boucle sur les zones {l{mentaires du MODELE
  96. *
  97.       DO 500 ISOUS=1,NSOUS
  98. *
  99. *    QUELQUES INITIALISATIONS
  100. *
  101.          NGRA=0
  102.          NDEP=0
  103.          NCAR = 0
  104.          IPMINT=0
  105.          IRTD1=1
  106.          NSTRS=0
  107.          MOGRAD=0
  108.          MODEPL=0
  109.          MOTEMP=0
  110.          MOCARA=0
  111.          MOMATR=0
  112.          IVAGRA=0
  113.          IVADEP=0
  114.          IVACAR=0
  115.          IVAMAT=0
  116.          NMATR=0
  117.          NMATF=0
  118. *
  119.          IMODEL=KMODEL(ISOUS)
  120.          SEGACT IMODEL
  121.          MELE=NEFMOD
  122.          IPMAIL=IMAMOD
  123.          CONM  =CONMOD
  124.          NFOR=FORMOD(/2)
  125.          NMAT=MATMOD(/2)
  126.          CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  127.          IF (CMATE.EQ.' ')THEN
  128.            CALL ERREUR(251)
  129.            SEGDES IMODEL,MMODEL
  130.            SEGSUP MCHELM
  131.            IRET=0
  132.            RETURN
  133.          ENDIF
  134.          CALL PLACE(FORMOD,FORMOD(/2),IMAGN,'MAGNETODYNAMIQUE')
  135. *
  136. *        ACTIVATION DU MAILLAGE
  137. *
  138.          MELEME=IPMAIL
  139.          SEGACT,MELEME
  140.          NBNN  =NUM(/1)
  141.          NBELEM=NUM(/2)
  142.          NBNO=NBNN
  143. *
  144. *        INFORMATIONS SUR L'ELEMENT FINI
  145. *
  146. *
  147.          IF(IMAGN.NE.0) THEN
  148. *
  149. *          CAS MAGNETODYNAMIQUE
  150. *
  151.            if(infmod(/1).lt.4) then
  152.            CALL ELQUOI(MELE,0,2,IPINF,IMODEL)
  153. *
  154.          IF (IERR.NE.0) THEN
  155.            SEGDES IMODEL,MMODEL
  156.            SEGSUP MCHELM
  157.            IRET=0
  158.            RETURN
  159.          ENDIF
  160.          INFO=IPINF
  161.          MFR=INFELL(13)
  162.          MINTE=INFELL(11)
  163.          MINTE1= INFELL(12)
  164.          NSTRS =INFELL(16)
  165.          LW    = INFELL( 7)
  166.          LRE   = INFELL( 9)
  167.          LHOOK =INFELL(10)
  168. *        SEGSUP INFO
  169.          ELSE
  170.          MFR=INFELE(13)
  171.          minte=infmod(4)
  172.          MINTE1= INFMOD(8)
  173.          NSTRS =INFELE(16)
  174.          LW    = INFELE( 7)
  175.          LRE   = INFELE( 9)
  176.          LHOOK =INFELE(10)
  177.          ENDIF
  178. *
  179.          ENDIF
  180. *
  181. *        ACTIVATION DU SEGMENT D'INTEGRATION
  182. *
  183.          SEGACT,MINTE
  184.          NBPGAU=POIGAU(/1)
  185.          SEGINI SGAUSS
  186.          NDIM=IDIM
  187.          SEGINI MMAT1
  188. C
  189. C        CREATION DU TABLEAU INFOS
  190. C
  191.          CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRTD)
  192.          IF (IRTD.EQ.0) GOTO 9990
  193. *
  194. *        NOMS DE COMPOSANTES OBLIGATOIRES A TROUVER DANS LES CHAMELEMS
  195. *
  196.          MDM=MFR
  197.          if(lnomid(3).ne.0) then
  198.           nomid=lnomid(3)
  199.           segact nomid
  200.           mograd=nomid
  201.           ngra=lesobl(/2)
  202.           nfac=lesfac(/2)
  203.           lsupgd=.false.
  204.         else
  205.           IF(IMAGN.NE.0) MDM=69
  206.          lsupgd=.true.
  207.          CALL IDGRAD(MDM,IFOUR,MOGRAD,NGRA,NFAC)
  208.         endif
  209. *
  210.          IF(IMAGN.NE.0) THEN
  211.            CALL IDFC(MFR,IFOUR,MOFC,NDEP,NFAC)
  212.          ENDIF
  213. *
  214. *        EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  215. *
  216.          NBROBL=0
  217.          NBRFAC=0
  218.          MOCARA=0
  219.          NCAR=0
  220. *
  221.          IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  222.            NBROBL=1
  223.            NBRFAC=1
  224.            SEGINI NOMID
  225.            MOCARA=NOMID
  226.            LESOBL(1)='EPAI'
  227.            LESFAC(1)='EXCE'
  228.            NCAR=1
  229.          ENDIF
  230. *
  231. *        VERIFICATION DE PRESENCE DES COMPOSANTES
  232. *
  233.          NBTYPE=1
  234.          SEGINI NOTYPE
  235.          MOTYPE=NOTYPE
  236.          TYPE(1)='REAL*8'
  237.          IF(IMAGN.NE.0) THEN
  238.            CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOFC,
  239.      1                   MOTYPE,1,INFOS,3,IVADEP)
  240.          ENDIF
  241.          SEGSUP NOTYPE
  242.          IF (IERR.NE.0) THEN
  243.            NGRA=0
  244.            IF (NCAR.NE.0) THEN
  245.               NOMID=MOCARA
  246.               SEGSUP NOMID
  247.            ENDIF
  248.            MOCARA=0
  249.            NCAR=0
  250.            GOTO 9990
  251.          ENDIF
  252. *
  253.          IF (NCAR.NE.0) THEN
  254.            IF (IPCHE1.NE.0) THEN
  255.              NBTYPE=1
  256.              SEGINI NOTYPE
  257.              MOTYPE=NOTYPE
  258.              TYPE(1)='REAL*8'
  259.              CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,
  260.      1                                   1,INFOS,3,IVACAR)
  261.              SEGSUP NOTYPE
  262.            ELSE
  263.              MOTERR(1:8)='CARACTER'
  264.              MOTERR(9:12)=NOMTP(MELE)
  265.              MOTERR(13:20)='COURANT'
  266.              CALL ERREUR(145)
  267.              NCAR=0
  268.              NGRA=0
  269.              NOMID=MOCARA
  270.              SEGSUP NOMID
  271.              MOCARA=0
  272.              GOTO 9990
  273.            ENDIF
  274.          ENDIF
  275.          IF (IERR.NE.0) GOTO 9990
  276. *
  277.          IF(IVACAR.NE.0)THEN
  278.             MPTVAL=IVACAR
  279.             IPMELV=IVAL(1)
  280.             CALL QUELCH(IPMELV,ICONS)
  281.             IF(ICONS.NE.0)THEN
  282.                CALL ERREUR(566)
  283.                GOTO 9990
  284.             ENDIF
  285.          ENDIF
  286. *
  287.          NBROBL=0
  288.          NBRFAC=0
  289.          MOMATR=0
  290.          NMATR=0
  291.          NMATF=0
  292. *
  293. *        CREATION DU MCHAML DE COURANT
  294. *
  295.          N2=NGRA
  296.          SEGINI,MCHAML
  297.          ICHAML(ISOUS)=MCHAML
  298.          IMACHE(ISOUS)=MELEME
  299.          CONCHE(ISOUS)=CONMOD
  300. C
  301.          INFCHE(ISOUS,1)=0
  302.          INFCHE(ISOUS,2)=0
  303.          INFCHE(ISOUS,3)=NHRM
  304.          INFCHE(ISOUS,4)=MINTE
  305.          INFCHE(ISOUS,5)=0
  306.          IF(IMAGN.NE.0) THEN
  307.            INFCHE(ISOUS,6)=2
  308.          ENDIF
  309. *
  310. *        RECHERCHE DES DIMENSIONS LES PLUS GRANDES
  311. *
  312.          N1EL=0
  313.          N1PTEL=0
  314.          MPTVAL=IVADEP
  315.          DO 178 IO=1,NDEP
  316.            MELVAL=IVAL(IO)
  317.            N1PTEL=MAX(N1PTEL,VELCHE(/1))
  318.            N1EL  =MAX(N1EL  ,VELCHE(/2))
  319.  178     CONTINUE
  320. *
  321.          IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN
  322.            N1PTEL=1
  323.          ELSE
  324.            N1PTEL=NBPGAU
  325.          ENDIF
  326.          N1EL  =MIN(N1EL  ,NBELEM)
  327. *
  328. *        CREATION DES MELVAL DU COURANT
  329. *
  330.           NSR=1
  331.           NCOSOR=NGRA
  332.           SEGINI MPTVAL
  333.           IVAGRA=MPTVAL
  334.           NOMID=MOGRAD
  335.           SEGACT NOMID
  336.           DO 77 IGR=1,NGRA
  337.             TYPCHE(IGR)='REAL*8'
  338.             NOMCHE(IGR)=LESOBL(IGR)
  339.             N2PTEL=0
  340.             N2EL=0
  341.             SEGINI MELVAL
  342.             IELVAL(IGR)=MELVAL
  343.             IVAL(IGR)=MELVAL
  344.  77       CONTINUE
  345.           SEGDES NOMID
  346. *
  347.       IMESS = 0
  348.       NBBB=NBNO
  349.       IF (MFR.EQ.29) THEN
  350.         NDUM=NGRA
  351.         NGRA=NDUM*NBBB
  352.         SEGINI MWRK1
  353.         NGRA=NDUM
  354.       ELSE
  355.         SEGINI MWRK1
  356.       ENDIF
  357. *
  358. *     Boucle sur les {l{ments
  359. *
  360.       DO 100 IB=1,NBELEM
  361. *
  362. *     On cherche les coordonn{es des noeuds de l'{l{ment IB
  363. *
  364.       CALL DOXE(XCOOR,IDIM,NBNO,NUM,IB,XE)
  365. *
  366. *     On cherche les d{placements ou les temp{ratures
  367. *
  368.       IE=1
  369.       MPTVAL=IVADEP
  370.       NDDD=NDEP
  371.       IF (IFOUR.EQ.-3.AND.ITHER.EQ.0) NDDD=NDEP-3
  372.       DO 200 IGAU=1,NBNN
  373.       DO 200 ICOMP=1,NDDD
  374.          MELVAL=IVAL(ICOMP)
  375.          IF (MELVAL.NE.0) THEN
  376.            IGMN=MIN(IGAU,VELCHE(/1))
  377.            IBMN=MIN(IB  ,VELCHE(/2))
  378.            XDDL(IE)=VELCHE(IGMN,IBMN)
  379.          ELSE
  380.            XDDL(IE)=0.
  381.          ENDIF
  382.          IE=IE+1
  383.  200  CONTINUE
  384. *
  385. *     On se dirige vers la zone sp{cifique selon l'{l{ment
  386. *
  387.       GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  388.      &      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  389.      &      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  390.      &      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  391.      &      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  392.      &      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  393.      &      99,99,99,99,99,99,99,27),MELE
  394. *
  395.  99   CONTINUE
  396.       MOTERR(1:4)=NOMTP(MELE)
  397.       MOTERR(9:12)='COURANT'
  398.       IMESS = 86
  399.       GOTO 9990
  400. *____________________________________________________________________*
  401. *     2/ COQ3                                                        *
  402. *____________________________________________________________________*
  403.   27  CONTINUE
  404.       IF(IMAGN.NE.0)THEN
  405. C      COQUE MAGNETODYNAMIQUE
  406.         CALL COQLOC(NBNN,XE,COSD1,COSD2,XE1)
  407.         CALL ELGAUS(MINTE,MMAT1,SGAUSS,IFOIS,IFOI2)
  408. C
  409. *          LE JACOBIEN EST NEGATIF : MAILLAGE INCORRECT
  410. *
  411.         IF(IFOIS.NE.0.AND.IFOIS.NE.NBPGAU)THEN
  412.             INTERR(1)=IB
  413.             CALL ERREUR(195)
  414.             GO TO 9990
  415. *
  416. *          CAS OU LE JACOBIEN EST TRES PETIT
  417. *
  418.         ELSEIF(IFOI2.EQ.NBPGAU)THEN
  419.             INTERR(1)=IB
  420.             CALL ERREUR (259)
  421.             GO TO 9990
  422.         ENDIF
  423. C
  424. C        REMPLISSAGE
  425. C
  426.          MPTVAL=IVAGRA
  427.         DO 5027  IGAU=1,NBPGAU
  428.           DO IC=1,NGRA
  429.             MELVAL=IVAL(IC)
  430.             IBMN=MIN(IB  ,VELCHE(/2))
  431.             IGMN=MIN(IGAU,VELCHE(/1))
  432.             r_z = 0.D0
  433.             DO IN=1,NBNN
  434.               r_z = r_z + GRAD(IC,IN,IGAU)*XDDL(IN)
  435.             ENDDO
  436.             VELCHE(IGMN,IBMN)=VELCHE(IGMN,IBMN) + r_z
  437.           ENDDO
  438.  5027   CONTINUE
  439. *
  440.       ENDIF
  441. *
  442.  100  CONTINUE
  443. *
  444. *     D{sactivation des segments
  445. *
  446.       IF (MWRK1.NE.0) SEGSUP,MWRK1
  447. *
  448.         CALL DTMVAL(IVADEP,1)
  449.         CALL DTMVAL(IVACAR,1)
  450.         CALL DTMVAL(IVAMAT,1)
  451.         CALL DTMVAL(IVAGRA,1)
  452. *
  453.         IF (ITHER.NE.0) THEN
  454.           NOMID=MOTEMP
  455.           SEGSUP NOMID
  456.         ELSE IF(IMAGN.NE.0) THEN
  457.           NOMID=MOFC
  458.           SEGSUP NOMID
  459.         ELSE
  460.           NOMID=MODEPL
  461.           SEGSUP NOMID
  462.         ENDIF
  463.         IF (MOCARA.NE.0) THEN
  464.           NOMID=MOCARA
  465.           SEGSUP NOMID
  466.         ENDIF
  467.         IF (MOMATR.NE.0) THEN
  468.           NOMID=MOMATR
  469.           SEGSUP NOMID
  470.         ENDIF
  471.         NOMID=MOGRAD
  472.         if(lsupgd)SEGSUP NOMID
  473.         SEGDES,IMODEL,MELEME
  474.         SEGDES,MCHAML,MINTE
  475. *
  476.  500  CONTINUE
  477.       SEGDES,MMODEL,MCHELM
  478.  
  479.       RETURN
  480. *
  481.  9990 CONTINUE
  482. *
  483. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  484. *
  485.       IRET=0
  486. *
  487. *     Gestion des messages d'erreur
  488. *
  489.       IF (IMESS.NE.0) THEN
  490.          INTERR(1) = IB
  491.          CALL ERREUR(IMESS)
  492.       ENDIF
  493. *
  494.       IF (MWRK1.NE.0) SEGSUP,MWRK1
  495.       SEGSUP MMAT1
  496.       SEGSUP SGAUSS
  497. *
  498.       CALL DTMVAL(IVADEP,1)
  499.       CALL DTMVAL(IVACAR,1)
  500.       CALL DTMVAL(IVAMAT,1)
  501.       CALL DTMVAL(IVAGRA,3)
  502. *
  503.       IF (MODEPL.NE.0) THEN
  504.         NOMID=MODEPL
  505.         SEGSUP NOMID
  506.       ENDIF
  507.       IF (MOTEMP.NE.0) THEN
  508.         NOMID=MOTEMP
  509.         SEGSUP NOMID
  510.       ENDIF
  511.       IF (MOCARA.NE.0)THEN
  512.          NOMID=MOCARA
  513.          SEGSUP NOMID
  514.       ENDIF
  515.       IF (lsupgd.and.MOGRAD.NE.0)THEN
  516.         NOMID=MOGRAD
  517.         SEGSUP NOMID
  518.       ENDIF
  519.       IF(MOMATR.NE.0)THEN
  520.          NOMID=MOMATR
  521.          SEGSUP NOMID
  522.       ENDIF
  523.  
  524.       SEGDES MELEME
  525.       SEGDES IMODEL
  526.  
  527.       SEGDES MMODEL
  528.       IF (IPCHE1.NE.0) THEN
  529.         MCHELM=IPCHE1
  530.         SEGDES MCHELM
  531.       ENDIF
  532.       SEGSUP,MCHAML
  533.       SEGSUP,MCHELM
  534.  
  535.       SEGDES MINTE
  536.  
  537.       RETURN
  538.       END
  539.  
  540.  
  541.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales