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

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