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

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