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    MB234859  25/08/04    21:15:03     12339          
  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.          if(lnomid(3).ne.0) then
  197.           nomid=lnomid(3)
  198.           segact nomid
  199.           mograd=nomid
  200.           ngra=lesobl(/2)
  201.           nfac=lesfac(/2)
  202.           lsupgd=.false.
  203.         else
  204.          lsupgd=.true.
  205.          CALL IDGRAD(IMODEL,IFOUR,MOGRAD,NGRA,NFAC)
  206.         endif
  207. *
  208.          IF(IMAGN.NE.0) THEN
  209.            CALL IDFC(MFR,IFOUR,MOFC,NDEP,NFAC)
  210.          ENDIF
  211. *
  212. *        EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  213. *
  214.          NBROBL=0
  215.          NBRFAC=0
  216.          MOCARA=0
  217.          NCAR=0
  218. *
  219.          IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  220.            NBROBL=1
  221.            NBRFAC=1
  222.            SEGINI NOMID
  223.            MOCARA=NOMID
  224.            LESOBL(1)='EPAI'
  225.            LESFAC(1)='EXCE'
  226.            NCAR=1
  227.          ENDIF
  228. *
  229. *        VERIFICATION DE PRESENCE DES COMPOSANTES
  230. *
  231.          NBTYPE=1
  232.          SEGINI NOTYPE
  233.          MOTYPE=NOTYPE
  234.          TYPE(1)='REAL*8'
  235.          IF(IMAGN.NE.0) THEN
  236.            CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOFC,
  237.      1                   MOTYPE,1,INFOS,3,IVADEP)
  238.          ENDIF
  239.          SEGSUP NOTYPE
  240.          IF (IERR.NE.0) THEN
  241.            NGRA=0
  242.            IF (NCAR.NE.0) THEN
  243.               NOMID=MOCARA
  244.               SEGSUP NOMID
  245.            ENDIF
  246.            MOCARA=0
  247.            NCAR=0
  248.            GOTO 9990
  249.          ENDIF
  250. *
  251.          IF (NCAR.NE.0) THEN
  252.            IF (IPCHE1.NE.0) THEN
  253.              NBTYPE=1
  254.              SEGINI NOTYPE
  255.              MOTYPE=NOTYPE
  256.              TYPE(1)='REAL*8'
  257.              CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,
  258.      1                                   1,INFOS,3,IVACAR)
  259.              SEGSUP NOTYPE
  260.            ELSE
  261.              MOTERR(1:8)='CARACTER'
  262.              MOTERR(9:12)=NOMTP(MELE)
  263.              MOTERR(13:20)='COURANT'
  264.              CALL ERREUR(145)
  265.              NCAR=0
  266.              NGRA=0
  267.              NOMID=MOCARA
  268.              SEGSUP NOMID
  269.              MOCARA=0
  270.              GOTO 9990
  271.            ENDIF
  272.          ENDIF
  273.          IF (IERR.NE.0) GOTO 9990
  274. *
  275.          IF(IVACAR.NE.0)THEN
  276.             MPTVAL=IVACAR
  277.             IPMELV=IVAL(1)
  278.             CALL QUELCH(IPMELV,ICONS)
  279.             IF(ICONS.NE.0)THEN
  280.                CALL ERREUR(566)
  281.                GOTO 9990
  282.             ENDIF
  283.          ENDIF
  284. *
  285.          NBROBL=0
  286.          NBRFAC=0
  287.          MOMATR=0
  288.          NMATR=0
  289.          NMATF=0
  290. *
  291. *        CREATION DU MCHAML DE COURANT
  292. *
  293.          N2=NGRA
  294.          SEGINI,MCHAML
  295.          ICHAML(ISOUS)=MCHAML
  296.          IMACHE(ISOUS)=MELEME
  297.          CONCHE(ISOUS)=CONMOD
  298. C
  299.          INFCHE(ISOUS,1)=0
  300.          INFCHE(ISOUS,2)=0
  301.          INFCHE(ISOUS,3)=NHRM
  302.          INFCHE(ISOUS,4)=MINTE
  303.          INFCHE(ISOUS,5)=0
  304.          IF(IMAGN.NE.0) THEN
  305.            INFCHE(ISOUS,6)=2
  306.          ENDIF
  307. *
  308. *        RECHERCHE DES DIMENSIONS LES PLUS GRANDES
  309. *
  310.          N1EL=0
  311.          N1PTEL=0
  312.          MPTVAL=IVADEP
  313.          DO 178 IO=1,NDEP
  314.            MELVAL=IVAL(IO)
  315.            N1PTEL=MAX(N1PTEL,VELCHE(/1))
  316.            N1EL  =MAX(N1EL  ,VELCHE(/2))
  317.  178     CONTINUE
  318. *
  319.          IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN
  320.            N1PTEL=1
  321.          ELSE
  322.            N1PTEL=NBPGAU
  323.          ENDIF
  324.          N1EL  =MIN(N1EL  ,NBELEM)
  325. *
  326. *        CREATION DES MELVAL DU COURANT
  327. *
  328.           NSR=1
  329.           NCOSOR=NGRA
  330.           SEGINI MPTVAL
  331.           IVAGRA=MPTVAL
  332.           NOMID=MOGRAD
  333.           SEGACT NOMID
  334.           DO 77 IGR=1,NGRA
  335.             TYPCHE(IGR)='REAL*8'
  336.             NOMCHE(IGR)=LESOBL(IGR)
  337.             N2PTEL=0
  338.             N2EL=0
  339.             SEGINI MELVAL
  340.             IELVAL(IGR)=MELVAL
  341.             IVAL(IGR)=MELVAL
  342.  77       CONTINUE
  343.           SEGDES NOMID
  344. *
  345.       IMESS = 0
  346.       NBBB=NBNO
  347.       IF (MFR.EQ.29) THEN
  348.         NDUM=NGRA
  349.         NGRA=NDUM*NBBB
  350.         SEGINI MWRK1
  351.         NGRA=NDUM
  352.       ELSE
  353.         SEGINI MWRK1
  354.       ENDIF
  355. *
  356. *     Boucle sur les {l{ments
  357. *
  358.       DO 100 IB=1,NBELEM
  359. *
  360. *     On cherche les coordonn{es des noeuds de l'{l{ment IB
  361. *
  362.       CALL DOXE(XCOOR,IDIM,NBNO,NUM,IB,XE)
  363. *
  364. *     On cherche les d{placements ou les temp{ratures
  365. *
  366.       IE=1
  367.       MPTVAL=IVADEP
  368.       NDDD=NDEP
  369.       IF (IFOUR.EQ.-3.AND.ITHER.EQ.0) NDDD=NDEP-3
  370.       DO 200 IGAU=1,NBNN
  371.       DO 201 ICOMP=1,NDDD
  372.          MELVAL=IVAL(ICOMP)
  373.          IF (MELVAL.NE.0) THEN
  374.            IGMN=MIN(IGAU,VELCHE(/1))
  375.            IBMN=MIN(IB  ,VELCHE(/2))
  376.            XDDL(IE)=VELCHE(IGMN,IBMN)
  377.          ELSE
  378.            XDDL(IE)=0.
  379.          ENDIF
  380.          IE=IE+1
  381.  201  CONTINUE
  382.  200  CONTINUE
  383. *
  384. *     On se dirige vers la zone sp{cifique selon l'{l{ment
  385. *
  386.       GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  387.      &      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,27),MELE
  393. *
  394.  99   CONTINUE
  395.       MOTERR(1:4)=NOMTP(MELE)
  396.       MOTERR(9:12)='COURANT'
  397.       IMESS = 86
  398.       GOTO 9990
  399. *____________________________________________________________________*
  400. *     2/ COQ3                                                        *
  401. *____________________________________________________________________*
  402.   27  CONTINUE
  403.       IF(IMAGN.NE.0)THEN
  404. C      COQUE MAGNETODYNAMIQUE
  405.         CALL COQLOC(NBNN,XE,COSD1,COSD2,XE1)
  406.         CALL ELGAUS(MINTE,MMAT1,SGAUSS,IFOIS,IFOI2)
  407. C
  408. *          LE JACOBIEN EST NEGATIF : MAILLAGE INCORRECT
  409. *
  410.         IF(IFOIS.NE.0.AND.IFOIS.NE.NBPGAU)THEN
  411.             INTERR(1)=IB
  412.             CALL ERREUR(195)
  413.             GO TO 9990
  414. *
  415. *          CAS OU LE JACOBIEN EST TRES PETIT
  416. *
  417.         ELSEIF(IFOI2.EQ.NBPGAU)THEN
  418.             INTERR(1)=IB
  419.             CALL ERREUR (259)
  420.             GO TO 9990
  421.         ENDIF
  422. C
  423. C        REMPLISSAGE
  424. C
  425.          MPTVAL=IVAGRA
  426.         DO 5027  IGAU=1,NBPGAU
  427.           DO IC=1,NGRA
  428.             MELVAL=IVAL(IC)
  429.             IBMN=MIN(IB  ,VELCHE(/2))
  430.             IGMN=MIN(IGAU,VELCHE(/1))
  431.             r_z = 0.D0
  432.             DO IN=1,NBNN
  433.               r_z = r_z + GRAD(IC,IN,IGAU)*XDDL(IN)
  434.             ENDDO
  435.             VELCHE(IGMN,IBMN)=VELCHE(IGMN,IBMN) + r_z
  436.           ENDDO
  437.  5027   CONTINUE
  438. *
  439.       ENDIF
  440. *
  441.  100  CONTINUE
  442. *
  443. *     D{sactivation des segments
  444. *
  445.       IF (MWRK1.NE.0) SEGSUP,MWRK1
  446. *
  447.         CALL DTMVAL(IVADEP,1)
  448.         CALL DTMVAL(IVACAR,1)
  449.         CALL DTMVAL(IVAMAT,1)
  450.         CALL DTMVAL(IVAGRA,1)
  451. *
  452.         IF (ITHER.NE.0) THEN
  453.           NOMID=MOTEMP
  454.           SEGSUP NOMID
  455.         ELSE IF(IMAGN.NE.0) THEN
  456.           NOMID=MOFC
  457.           SEGSUP NOMID
  458.         ELSE
  459.           NOMID=MODEPL
  460.           SEGSUP NOMID
  461.         ENDIF
  462.         IF (MOCARA.NE.0) THEN
  463.           NOMID=MOCARA
  464.           SEGSUP NOMID
  465.         ENDIF
  466.         IF (MOMATR.NE.0) THEN
  467.           NOMID=MOMATR
  468.           SEGSUP NOMID
  469.         ENDIF
  470.         NOMID=MOGRAD
  471.         if(lsupgd)SEGSUP NOMID
  472.         SEGDES,IMODEL,MELEME
  473.         SEGDES,MCHAML,MINTE
  474. *
  475.  500  CONTINUE
  476.       SEGDES,MMODEL,MCHELM
  477.  
  478.       RETURN
  479. *
  480.  9990 CONTINUE
  481. *
  482. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  483. *
  484.       IRET=0
  485. *
  486. *     Gestion des messages d'erreur
  487. *
  488.       IF (IMESS.NE.0) THEN
  489.          INTERR(1) = IB
  490.          CALL ERREUR(IMESS)
  491.       ENDIF
  492. *
  493.       IF (MWRK1.NE.0) SEGSUP,MWRK1
  494.       SEGSUP MMAT1
  495.       SEGSUP SGAUSS
  496. *
  497.       CALL DTMVAL(IVADEP,1)
  498.       CALL DTMVAL(IVACAR,1)
  499.       CALL DTMVAL(IVAMAT,1)
  500.       CALL DTMVAL(IVAGRA,3)
  501. *
  502.       IF (MODEPL.NE.0) THEN
  503.         NOMID=MODEPL
  504.         SEGSUP NOMID
  505.       ENDIF
  506.       IF (MOTEMP.NE.0) THEN
  507.         NOMID=MOTEMP
  508.         SEGSUP NOMID
  509.       ENDIF
  510.       IF (MOCARA.NE.0)THEN
  511.          NOMID=MOCARA
  512.          SEGSUP NOMID
  513.       ENDIF
  514.       IF (lsupgd.and.MOGRAD.NE.0)THEN
  515.         NOMID=MOGRAD
  516.         SEGSUP NOMID
  517.       ENDIF
  518.       IF(MOMATR.NE.0)THEN
  519.          NOMID=MOMATR
  520.          SEGSUP NOMID
  521.       ENDIF
  522.  
  523.       SEGDES MELEME
  524.       SEGDES IMODEL
  525.  
  526.       SEGDES MMODEL
  527.       IF (IPCHE1.NE.0) THEN
  528.         MCHELM=IPCHE1
  529.         SEGDES MCHELM
  530.       ENDIF
  531.       SEGSUP,MCHAML
  532.       SEGSUP,MCHELM
  533.  
  534.       SEGDES MINTE
  535.  
  536.       RETURN
  537.       END
  538.  
  539.  
  540.  
  541.  

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