Télécharger la plaquette Cast3M


fr en

Télécharger grad2.eso

Retour à la liste

Numérotation des lignes : 

grad2

  1. C GRAD2     SOURCE    MB234859  25/09/08    21:15:36     12358          
  2.  
  3. *____________________________________________________________________*
  4. *                                                                    *
  5. *     Sous-programme de l'operateur GRADIENT                         *
  6. *                                                                    *
  7. *     Entree:                                                        *
  8. *                                                                    *
  9. *        IPMODL    Pointeur sur un objet MMODEL                      *
  10. *        IPCHA1    Pointeur sur un MCHAML de DEPLACEMENT             *
  11. *        IPCHE1    Pointeur sur un MCHAML de CARACTERISTIQUES        *
  12. *                                                                    *
  13. *     Sortie:                                                        *
  14. *                                                                    *
  15. *        IPGRAD    Pointeur sur un MCHAML de gradients               *
  16. *        IRET       1 si succes , 0 sinon                            *
  17. *                                                                    *
  18. *____________________________________________________________________*
  19. *
  20.       SUBROUTINE GRAD2(IPMODL,IPCHA1,IPCHE1,IPGRAD,IRET)
  21.  
  22.       IMPLICIT INTEGER(I-N)
  23.       IMPLICIT REAL*8(A-H,O-Z)
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC CCHAMP
  28. -INC CCGEOME
  29.  
  30. -INC SMCHAML
  31. -INC SMMODEL
  32. -INC SMELEME
  33. -INC SMINTE
  34. -INC SMCOORD
  35.  
  36. -INC TMPTVAL
  37.  
  38.       SEGMENT NOTYPE
  39.         CHARACTER*16 TYPE(NBTYPE)
  40.       ENDSEGMENT
  41.  
  42.       SEGMENT WRK1
  43.          REAL*8 XDDL(LRN),GRAD(NSTB),AUX(NSTB),XE(3,NBBB)
  44.       ENDSEGMENT
  45. *
  46.       SEGMENT WRK2
  47.          REAL*8 SHPWRK(6,NBNO),BGENE(NSTB,LRE)
  48.       ENDSEGMENT
  49. *
  50.       SEGMENT WRK3
  51.          REAL*8 XGENE(NSTN,LRN)
  52.       ENDSEGMENT
  53. *
  54.       SEGMENT WRK4
  55.          REAL*8 XLOC(3,3),XGLOB(3,3),TXR(IDIM,IDIM)
  56.          REAL*8 VALMAT(NMATT)
  57.          REAL*8 PMAT(NSTB,NSTB),PMAT1(IDIM,IDIM),PMAT2(IDIM,IDIM)
  58.       ENDSEGMENT
  59. *
  60.       SEGMENT WRK5
  61.        REAL*8 BPSS(3,3),XEL(3,NBBB)
  62.        REAL*8 XNTH(LRN,LRN),XNTB(LRN,LRN),XNTT(LRN)
  63.       ENDSEGMENT
  64. *
  65.       SEGMENT WRK6
  66.        REAL*8 PKK(NSTB,NSTB)
  67.       ENDSEGMENT
  68. *
  69.       CHARACTER*8  CMATE
  70.       CHARACTER*(NCONCH) CONM
  71.       PARAMETER ( NINF=3 )
  72.       INTEGER INFOS(NINF)
  73. *
  74.       IRET = 0
  75.       IPGRAD = 0
  76.  
  77.       NHRM=NIFOUR
  78.       MCHAML=0
  79. C
  80. C     VERIFICATION DU LIEU SUPPORT DU MCHAML DE MATERIAU
  81. C
  82.       ISUP=0
  83.       CALL QUESUP(IPMODL,IPCHE1,3,0,ISUP,IRETMA)
  84.       IF (ISUP.GT.1) RETURN
  85. C
  86. C     ACTIVATION DU MODELE
  87. C
  88.       MMODEL=IPMODL
  89.       SEGACT MMODEL
  90.       NSOUS=KMODEL(/1)
  91. C
  92.       KEL22 = 0
  93.       DO ISOUS = 1,NSOUS
  94.         IMODEL=KMODEL(ISOUS)
  95.         SEGACT IMODEL
  96.         IF (FORMOD(1).NE.'POREUX') THEN
  97.           CALL ERREUR(19)
  98.           GOTO 888
  99.         ENDIF
  100.         IF ((NEFMOD.EQ.22).OR.(NEFMOD.EQ.259)) KEL22 = KEL22 + 1
  101.         IF (FORMOD(1).EQ.'CHARGEMENT') KEL22 = KEL22 + 1
  102.       ENDDO
  103. C
  104. C     INITIALISATION DU MCHAML RESULTAT
  105. C
  106.       N1=NSOUS-KEL22
  107.       N3=6
  108.       L1=11
  109.       SEGINI MCHELM
  110.       TITCHE='GRADIENT'
  111.       IFOCHE=IFOUR
  112.       IPGRAD=MCHELM
  113. C____________________________________________________________________
  114. C
  115. C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  116. C____________________________________________________________________
  117. C
  118.       isouss=0
  119.       DO 500 ISOUS=1,NSOUS
  120. *
  121. *   INITIALISATION
  122. *
  123.       IVAMAT=0
  124.       IVAGRA=0
  125.       IVADEP=0
  126.       IVACAR=0
  127.       NMATR=0
  128.       NMATF=0
  129.       NGRAD=0
  130.       NDEP=0
  131.       MOMATR=0
  132.       MOGRAD=0
  133.       MODEPL=0
  134. C
  135. C     ON RECUPERE L INFORMATION GENERALE
  136. C
  137.       IMODEL=KMODEL(ISOUS)
  138.       SEGACT IMODEL
  139. C
  140. C     TRAITEMENT DU MODELE
  141. C
  142.       MELE=NEFMOD
  143.       if ((MELE.EQ.22).OR.(MELE.EQ.259)) go to 500
  144.       IF (FORMOD(1).EQ.'CHARGEMENT') GO TO 500
  145. C
  146.       isouss=isouss+1
  147.       MELEME=IMAMOD
  148.       IPMAIL=IMAMOD
  149.       CONM  =CONMOD
  150.       IMACHE(ISOUSs)=IPMAIL
  151.       CONCHE(ISOUSs)=CONMOD
  152. C
  153. C     NATURE DU MATERIAU
  154. C
  155. *      NFOR=FORMOD(/2)
  156. *      NMAT=MATMOD(/2)
  157. *      CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  158.       CMATE = CMATEE
  159.       MATE  = IMATEE
  160.       MAPL  = INATUU
  161.       IF (CMATE.EQ.' ')THEN
  162.         CALL ERREUR(251)
  163.         SEGSUP MCHELM
  164.         GOTO 888
  165.       ENDIF
  166. C____________________________________________________________________
  167. C
  168. C     INFORMATION SUR L'ELEMENT FINI
  169. C____________________________________________________________________
  170. C
  171.       MFR  =INFELE(13)
  172.       IELE =INFELE(14)
  173.       IPORE=INFELE(8)
  174.       MINTE=INFMOD(5)
  175.       IPMINT=MINTE
  176. C
  177. C     CREATION DU TABLEAU INFOS
  178. C
  179.       CALL IDENT(IPMAIL,CONM,IPCHA1,IPCHE1,INFOS,IRTD)
  180.       IF (IRTD.EQ.0) GOTO 9990
  181. C
  182.       INFCHE(ISOUSs,1)=0
  183.       INFCHE(ISOUSs,2)=0
  184.       INFCHE(ISOUSs,3)=NHRM
  185.       INFCHE(ISOUSs,4)=MINTE
  186.       INFCHE(ISOUSs,5)=0
  187.       INFCHE(ISOUSs,6)=3
  188. C
  189. C     ACTIVATIONS
  190. C
  191.       SEGACT MINTE
  192.       NBPGAU=POIGAU(/1)
  193.  
  194.       SEGACT MELEME
  195.       NBNN  =NUM(/1)
  196.       NBELEM=NUM(/2)
  197.  
  198. C____________________________________________________________________
  199. C
  200. C     RECHERCHE DES COMPOSANTES DE DEPLACEMENTS
  201. C____________________________________________________________________
  202. C
  203.        NBROBL=0
  204.        NBRFAC=0
  205.        IPPORE=0
  206. *
  207.        IF(MFR.EQ.33) THEN
  208.            IPPORE=NBNN
  209.            NBROBL=1
  210.            SEGINI NOMID
  211.            LESOBL(1)='P   '
  212.        ELSE IF(MFR.EQ.57) THEN
  213.            IPPORE=NBNN
  214.            NBROBL=2
  215.            SEGINI NOMID
  216.            LESOBL(1)='P   '
  217.            LESOBL(2)='PQ  '
  218.        ELSE IF(MFR.EQ.59) THEN
  219.            IPPORE=NBNN
  220.            NBROBL=3
  221.            SEGINI NOMID
  222.            LESOBL(1)='P   '
  223.            LESOBL(2)='PQ  '
  224.            LESOBL(3)='TP  '
  225.        ENDIF
  226.        IDECAP=NBROBL
  227.  
  228.        NDEP=NBROBL
  229.        MODEPL = NOMID
  230. C
  231.        NBTYPE=1
  232.        SEGINI NOTYPE
  233.        MOTYPE=NOTYPE
  234.        TYPE(1)='REAL*8'
  235.        CALL KOMCHA(IPCHA1,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP)
  236.        SEGSUP NOTYPE
  237.        IF (IERR.NE.0) GOTO 9990
  238.  
  239. C____________________________________________________________________
  240. C
  241. C     RECHERCHE DES COMPOSANTES DE MATERIAU
  242. C____________________________________________________________________
  243. C
  244.          NBROBL=0
  245.          NBRFAC=0
  246. *                                         cas isotrope
  247.             IF (MATE.EQ.1) THEN
  248. *
  249.               IF (MELE.GE.79.AND.MELE.LE.83) THEN
  250.                 NBROBL=2
  251.                 SEGINI NOMID
  252.                 LESOBL(1)='PERM'
  253.                 LESOBL(2)='VISC'
  254.               ELSE IF (MELE.GE.108.AND.MELE.LE.110) THEN
  255.                 NBROBL=4
  256.                 SEGINI NOMID
  257.                 LESOBL(1)='PERH'
  258.                 LESOBL(2)='PERB'
  259.                 LESOBL(3)='PERT'
  260.                 LESOBL(4)='VISC'
  261.               ELSE IF (MELE.GE.173.AND.MELE.LE.177) THEN
  262.                 NBROBL=4
  263.                 SEGINI NOMID
  264.                 LESOBL(1)='PK11'
  265.                 LESOBL(2)='PK12'
  266.                 LESOBL(3)='PK21'
  267.                 LESOBL(4)='PK22'
  268.               ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  269.                 NBROBL=9
  270.                 SEGINI NOMID
  271.                 LESOBL(1)='PK11'
  272.                 LESOBL(2)='PK12'
  273.                 LESOBL(3)='PK13'
  274.                 LESOBL(4)='PK21'
  275.                 LESOBL(5)='PK22'
  276.                 LESOBL(6)='PK23'
  277.                 LESOBL(7)='PK31'
  278.                 LESOBL(8)='PK32'
  279.                 LESOBL(9)='PK33'
  280.               ELSE IF (MELE.GE.185.AND.MELE.LE.187) THEN
  281.                 NBROBL=12
  282.                 SEGINI NOMID
  283.                 LESOBL(1)='PH11'
  284.                 LESOBL(2)='PB11'
  285.                 LESOBL(3)='PT11'
  286.                 LESOBL(4)='PH12'
  287.                 LESOBL(5)='PB12'
  288.                 LESOBL(6)='PT12'
  289.                 LESOBL(7)='PH21'
  290.                 LESOBL(8)='PB21'
  291.                 LESOBL(9)='PT21'
  292.                 LESOBL(10)='PH22'
  293.                 LESOBL(11)='PB22'
  294.                 LESOBL(12)='PT22'
  295.               ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  296.                 NBROBL=27
  297.                 SEGINI NOMID
  298.                 LESOBL(1)='PH11'
  299.                 LESOBL(2)='PB11'
  300.                 LESOBL(3)='PT11'
  301.                 LESOBL(4)='PH12'
  302.                 LESOBL(5)='PB12'
  303.                 LESOBL(6)='PT12'
  304.                 LESOBL(7)='PH13'
  305.                 LESOBL(8)='PB13'
  306.                 LESOBL(9)='PT13'
  307.                 LESOBL(10)='PH21'
  308.                 LESOBL(11)='PB21'
  309.                 LESOBL(12)='PT21'
  310.                 LESOBL(13)='PH22'
  311.                 LESOBL(14)='PB22'
  312.                 LESOBL(15)='PT22'
  313.                 LESOBL(16)='PH23'
  314.                 LESOBL(17)='PB23'
  315.                 LESOBL(18)='PT23'
  316.                 LESOBL(19)='PH31'
  317.                 LESOBL(20)='PB31'
  318.                 LESOBL(21)='PT31'
  319.                 LESOBL(22)='PH32'
  320.                 LESOBL(23)='PB32'
  321.                 LESOBL(24)='PT32'
  322.                 LESOBL(25)='PH33'
  323.                 LESOBL(26)='PB33'
  324.                 LESOBL(27)='PT33'
  325.               ENDIF
  326. *                                          cas orthotrope
  327.             ELSE IF (MATE.EQ.2) THEN
  328.               IF (IDIM.EQ.3) THEN
  329.                 NBROBL=10
  330.                 SEGINI NOMID
  331.                 LESOBL(1)='PER1'
  332.                 LESOBL(2)='PER2'
  333.                 LESOBL(3)='PER3'
  334.                 LESOBL(4)='VISC'
  335.                 LESOBL(5)='V1X '
  336.                 LESOBL(6)='V1Y '
  337.                 LESOBL(7)='V1Z '
  338.                 LESOBL(8)='V2X '
  339.                 LESOBL(9)='V2Y '
  340.                 LESOBL(10)='V2Z '
  341.               ELSE IF(IDIM.EQ.2) THEN
  342.                 IF (IFOUR.LE.0) THEN
  343.                   NBROBL=5
  344.                   SEGINI NOMID
  345.                   LESOBL(1)='PER1'
  346.                   LESOBL(2)='PER2'
  347.                   LESOBL(3)='VISC'
  348.                   LESOBL(4)='V1X '
  349.                   LESOBL(5)='V1Y '
  350.                 ELSE IF (IFOUR.EQ.1) THEN
  351.                   NBROBL=6
  352.                   SEGINI NOMID
  353.                   LESOBL(1)='PER1'
  354.                   LESOBL(2)='PER2'
  355.                   LESOBL(3)='PER3'
  356.                   LESOBL(4)='VISC'
  357.                   LESOBL(5)='V1X '
  358.                   LESOBL(6)='V1Y '
  359.                 ENDIF
  360.               ENDIF
  361. *                                          cas anisotrope
  362.             ELSE IF (MATE.EQ.3)THEN
  363.               IF(IDIM.EQ.3)THEN
  364.                 NBROBL=13
  365.                 SEGINI NOMID
  366.                 LESOBL(1)='PER1'
  367.                 LESOBL(2)='PER2'
  368.                 LESOBL(3)='PER3'
  369.                 LESOBL(4)='PE12'
  370.                 LESOBL(5)='PE13'
  371.                 LESOBL(6)='PE23'
  372.                 LESOBL(7)='VISC'
  373.                 LESOBL(8)='V1X '
  374.                 LESOBL(9)='V1Y '
  375.                 LESOBL(10)='V1Z '
  376.                 LESOBL(11)='V2X '
  377.                 LESOBL(12)='V2Y '
  378.                 LESOBL(13)='V2Z '
  379.               ELSE IF (IDIM.EQ.2) THEN
  380.                 IF (IFOUR.LE.0) THEN
  381.                   NBROBL=6
  382.                   SEGINI NOMID
  383.                   LESOBL(1)='PER1'
  384.                   LESOBL(2)='PER2'
  385.                   LESOBL(3)='PE12'
  386.                   LESOBL(4)='VISC'
  387.                   LESOBL(5)='V1X '
  388.                   LESOBL(6)='V1Y '
  389.                 ELSE IF (IFOUR.EQ.1) THEN
  390.                   NBROBL=7
  391.                   SEGINI NOMID
  392.                   LESOBL(1)='PER1'
  393.                   LESOBL(2)='PER2'
  394.                   LESOBL(3)='PE12'
  395.                   LESOBL(4)='PER3'
  396.                   LESOBL(5)='VISC'
  397.                   LESOBL(6)='V1X '
  398.                   LESOBL(7)='V1Y '
  399.                 ENDIF
  400.               ENDIF
  401. *                                         cas unidirectionnel
  402.             ELSE IF (MATE.EQ.4) THEN
  403.              IF (IDIM.EQ.3) THEN
  404.               NBROBL=8
  405.               SEGINI NOMID
  406.               LESOBL(1)='PERM'
  407.               LESOBL(2)='VISC'
  408.               LESOBL(3)='V1X '
  409.               LESOBL(4)='V1Y '
  410.               LESOBL(5)='V1Z '
  411.               LESOBL(6)='V2X '
  412.               LESOBL(7)='V2Y '
  413.               LESOBL(8)='V2Z '
  414.              ELSE
  415.               NBROBL=4
  416.               SEGINI NOMID
  417.               LESOBL(1)='PERM'
  418.               LESOBL(2)='VISC'
  419.               LESOBL(3)='V1X '
  420.               LESOBL(4)='V1Y '
  421.              ENDIF
  422.             ENDIF
  423. *
  424.          NMATR=NBROBL
  425.          NMATF=NBRFAC
  426.          NMATT = NMATR+NMATF
  427.          MOMATR=NOMID
  428. *
  429.          NBTYPE=1
  430.          SEGINI NOTYPE
  431.          MOTYPE=NOTYPE
  432.          TYPE(1)='REAL*8'
  433.          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  434.          SEGSUP NOTYPE
  435.          IF (IERR.NE.0) GOTO 9990
  436.          IF (ISUP.EQ.1) THEN
  437.             CALL VALCHE(IVAMAT,NMATR,IPMINT,IPPORE,MOMATR,MELE)
  438.          ENDIF
  439. *
  440. *_______________________________________________________________________
  441. *
  442. *     COMPOSANTES EN SORTIE
  443. *_______________________________________________________________________
  444. *
  445. *     CAS JOINTS
  446. *
  447.        IF((MELE.GE.108.AND.MELE.LE.110).OR.
  448.      .    (MELE.GE.185.AND.MELE.LE.190)) THEN
  449.  
  450.          IF(IFOUR.LE.0) THEN
  451. *             CAS PLAN
  452.             NCOVEC=3
  453.          ELSE IF (IFOUR.EQ.2) THEN
  454. *              3D
  455.             NCOVEC=4
  456.          ENDIF
  457.       ELSE
  458.  
  459.         IF(IFOUR.LE.0) THEN
  460. *            CONTRAINTES PLANES - DEFORMATIONS PLANES
  461. *            DEFO PLAN GENE
  462. *            AXISYMETRIQUE
  463.            NCOVEC=2
  464.  
  465.         ELSE IF (IFOUR.GT.0) THEN
  466. *            FOURIER
  467. *             3D
  468.            NCOVEC=3
  469.         ENDIF
  470.  
  471.       ENDIF
  472. *
  473.       NBROBL=NCOVEC*IDECAP
  474.       NBRFAC=0
  475.       NGRAD=NBROBL
  476.       SEGINI NOMID
  477.       MOGRAD=NOMID
  478.  
  479.       IF((MELE.GE.108.AND.MELE.LE.110).OR.
  480.      .   (MELE.GE.185.AND.MELE.LE.190)) THEN
  481.  
  482.         DO 121 IPR=1,IDECAP
  483.         IPRDEC = (IPR-1)*NCOVEC
  484.         IF(IPR.EQ.1) THEN
  485.           LESOBL(IPRDEC+1)='VCPH'
  486.           LESOBL(IPRDEC+2)='VCPB'
  487.           LESOBL(IPRDEC+3)='VCP1'
  488.           IF(NCOVEC.EQ.4) LESOBL(IPRDEC+4)='VCP2'
  489.         ELSE IF(IPR.EQ.2) THEN
  490.           LESOBL(IPRDEC+1)='VCQH'
  491.           LESOBL(IPRDEC+2)='VCQB'
  492.           LESOBL(IPRDEC+3)='VCQ1'
  493.           IF(NCOVEC.EQ.4) LESOBL(IPRDEC+4)='VCQ2'
  494.         ELSE IF(IPR.EQ.3) THEN
  495.           LESOBL(IPRDEC+1)='VCTH'
  496.           LESOBL(IPRDEC+2)='VCTB'
  497.           LESOBL(IPRDEC+3)='VCT1'
  498.           IF(NCOVEC.EQ.4) LESOBL(IPRDEC+4)='VCT2'
  499.         ENDIF
  500.  121    CONTINUE
  501.  
  502.       ELSE
  503.         DO 120 IPR=1,IDECAP
  504.         IPRDEC = (IPR-1)*NCOVEC
  505.         IF(IPR.EQ.1) THEN
  506.           LESOBL(IPRDEC+1)='VCP1'
  507.           LESOBL(IPRDEC+2)='VCP2'
  508.           IF(NCOVEC.EQ.3) LESOBL(IPRDEC+3)='VCP3'
  509.         ELSE IF(IPR.EQ.2) THEN
  510.           LESOBL(IPRDEC+1)='VCQ1'
  511.           LESOBL(IPRDEC+2)='VCQ2'
  512.           IF(NCOVEC.EQ.3) LESOBL(IPRDEC+3)='VCQ3'
  513.         ELSE IF(IPR.EQ.3) THEN
  514.           LESOBL(IPRDEC+1)='VCT1'
  515.           LESOBL(IPRDEC+2)='VCT2'
  516.           IF(NCOVEC.EQ.3) LESOBL(IPRDEC+3)='VCT3'
  517.         ENDIF
  518.  120    CONTINUE
  519.  
  520.       ENDIF
  521. *
  522. *     SEGDES NOMID
  523. *_______________________________________________________________________
  524. *
  525. *      CREATION DU MCHAML DE LA SOUS ZONE
  526. *_______________________________________________________________________
  527. *
  528.       N1PTEL=NBPGAU
  529.       N1EL=NBELEM
  530.       NBPTEL=N1PTEL
  531.       NEL=N1EL
  532.       N2=NGRAD
  533. *
  534.       SEGINI MCHAML
  535.       ICHAML(ISOUSs)=MCHAML
  536.       NSR=1
  537.       NCOSOR=NGRAD
  538.       SEGINI MPTVAL
  539.       IVAGRA=MPTVAL
  540.       NOMID=MOGRAD
  541.       SEGACT NOMID
  542.       DO 100 ICOMP=1,NGRAD
  543.          NOMCHE(ICOMP)=LESOBL(ICOMP)
  544.          TYPCHE(ICOMP)='REAL*8'
  545.          N2PTEL=0
  546.          N2EL=0
  547.          SEGINI MELVAL
  548.          IELVAL(ICOMP)=MELVAL
  549.          IVAL(ICOMP)=MELVAL
  550.  100  CONTINUE
  551. *
  552.       IF(MELE.GE.79.AND.MELE.LE.83) GO TO 79
  553.       IF(MELE.GE.173.AND.MELE.LE.182) GO TO 79
  554.       IF(MELE.GE.108.AND.MELE.LE.110) GO TO 80
  555.       IF(MELE.GE.185.AND.MELE.LE.190) GO TO 80
  556. *
  557.       GOTO 99
  558. *
  559. C_______________________________________________________________________
  560. C
  561. C     MILIEUX POREUX
  562. C_______________________________________________________________________
  563. C
  564.   79  CONTINUE
  565. C
  566. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  567. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  568. C
  569.       DIM3=1.D0
  570.       NBNO=IPORE
  571.       NBBB=NBNN
  572.  
  573.       LPP=NBNO-NBBB
  574.       LRN =IDECAP*LPP
  575.       LRE=NBNN*IDECAP
  576.       NSTBE=2
  577.       IF(IFOUR.GT.0) NSTBE=3
  578.       NSTB=NSTBE*IDECAP
  579.       NSTN=1
  580.  
  581. *     CAS NON ISOTROPES
  582. *     RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES
  583. *     AU CENTRE DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
  584. *
  585.       IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  586.         CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1)
  587.         MINTE2=IPMIN2
  588.         SEGACT MINTE2
  589.         SEGINI WRK4
  590.       ENDIF
  591. *
  592.       SEGINI WRK1,WRK2,WRK3,WRK6
  593.       I195=0
  594.       I259=0
  595.       I367=0
  596. C
  597.       DO 3079  IB=1,NBELEM
  598. C
  599. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  600. C
  601.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  602. C
  603. C     ON RECUPERE LES DEPLACEMENTS
  604. C
  605.       MPTVAL=IVADEP
  606.       NCOSOU=IVAL(/1)
  607.       IE=1
  608.       DO 8078 I=1,NCOSOU
  609.          MELVAL=IVAL(I)
  610.          DO 8079 IGAU=1,LPP
  611.             IGAUSO=IBSOM(NSPOS(IELE)+IGAU-1)
  612.             IGMN=MIN(IGAUSO,VELCHE(/1))
  613.             IBMN=MIN(IB    ,VELCHE(/2))
  614.             XDDL(IE)=VELCHE(IGMN,IBMN)
  615.             IE=IE+1
  616.  8079  CONTINUE
  617.  8078  CONTINUE
  618.  
  619. *       WRITE(6,44551) (XDDL(I),I=1,LRN)
  620. *44551  FORMAT(2X,'XDDL'/(4(1X,1PE12.5)/))
  621. *
  622. *     CALCUL DES AXES LOCAUX DANS LES CAS NON ISOTROPES
  623. *
  624.       IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  625.         NBSH=MINTE2.SHPTOT(/2)
  626.         CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  627.         IF (NBSH.EQ.-1) THEN
  628.            CALL ERREUR(525)
  629.            RETURN
  630.         ENDIF
  631.       ENDIF
  632.  
  633. C
  634. C     BOUCLE SUR LES POINTS DE GAUSS
  635. C
  636.       ISDJC=0
  637.  
  638.       DO 5079  IGAU=1,NBPGAU
  639. C
  640. C   RECUPERATION DE L'EPAISSEUR
  641. C
  642.       IF (IFOUR.EQ.-2)THEN
  643.         MPTVAL=IVACAR
  644.         IF (IVACAR.NE.0) THEN
  645.          MELVAL=IVAL(1)
  646.          IF (MELVAL.NE.0) THEN
  647.           IGMN=MIN(IGAU,VELCHE(/1))
  648.           IBMN=MIN(IB,VELCHE(/2))
  649.           DIM3=VELCHE(IGMN,IBMN)
  650.          ELSE
  651.           DIM3=1.D0
  652.          ENDIF
  653.         ENDIF
  654.       ENDIF
  655. C
  656.       LHOO=NSTB
  657.       CALL BNQORE(IGAU,NBNO,NBNN,LRE,IFOUR,NSTB,NSTN,NHRM,DIM3,
  658.      .       XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOO,2)
  659.  
  660. *     IF(IGAU.EQ.1) THEN
  661. *     PRINT *,' MATRICE B LIGNE PAR LIGNE '
  662. *     DO 3367 IPZ = 1,NSTB
  663. *       PRINT *,' LIGNE ',IPZ
  664. *       WRITE(6,3368) (BGENE(IPZ,JPZ), JPZ=1,LRE)
  665. *3368        FORMAT(8(1X,1PE10.3)/)
  666. *3367        CONTINUE
  667. *      ENDIF
  668.  
  669.       IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  670.       IF(DJAC.EQ.0.D0) I259=IB
  671. C
  672. C     ON RECUPERE LE MATERIAU
  673. C
  674.          EREF=1.D0
  675.          MPTVAL=IVAMAT
  676.          CALL ZERO (PKK,NSTB,NSTB)
  677. *
  678. *           le cas isotrope
  679. *
  680.          IF (MATE.EQ.1) THEN
  681.  
  682.            IF(MFR.EQ.33) THEN
  683.  
  684.               MELVAL=IVAL(1)
  685.               IGMN=MIN(IGAU,VELCHE(/1))
  686.               IBMN=MIN(IB  ,VELCHE(/2))
  687.               XK  =VELCHE(IGMN,IBMN)
  688. *
  689.               MELVAL=IVAL(2)
  690.               IGMN=MIN(IGAU,VELCHE(/1))
  691.               IBMN=MIN(IB  ,VELCHE(/2))
  692.               XMU =VELCHE(IGMN,IBMN)
  693.               IF(XMU.EQ.0.D0) THEN
  694.                 I367=IB
  695.                 GO TO 5079
  696.               ENDIF
  697.               COMJAC=EREF*EREF*XK/XMU
  698.               DO 1729 I=1,NSTB
  699.                 PKK(I,I)=COMJAC
  700. 1729          CONTINUE
  701.  
  702.            ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN
  703.  
  704.               ICO=1
  705.               IDECA2=IDECAP*IDECAP
  706.               DO 1731 ICD = 1,IDECAP
  707.                 ICDA =(ICD -1) * NSTBE
  708.                 DO 1732 JCD = 1,IDECAP
  709.                   JCDA =(JCD -1) * NSTBE
  710.                   MELVAL=IVAL(ICO)
  711.                   IGMN=MIN(IGAU,VELCHE(/1))
  712.                   IBMN=MIN(IB  ,VELCHE(/2))
  713.                   DO 1733 KCD = 1,NSTBE
  714.                     PKK(ICDA+KCD,JCDA+KCD) =VELCHE(IGMN,IBMN)
  715. 1733              CONTINUE
  716.                  ICO=ICO+1
  717. 1732            CONTINUE
  718. 1731          CONTINUE
  719.            ENDIF
  720. *
  721. *         IF(IGAU . EQ . 1 ) THEN
  722. *             PRINT *,' MATRICE PKK'
  723. *
  724. *              IF (IDECAP.EQ.1) THEN
  725. *              WRITE (6,1341) ((PKK(I,J),J=1,NSTB),I=1,NSTB)
  726. *1341          FORMAT(2(1X,1PE12.5)/)
  727. *
  728. *              ELSE IF (IDECAP.EQ.2) THEN
  729. *              WRITE (6,1342) ((PKK(I,J),J=1,NSTB),I=1,NSTB)
  730. *1342          FORMAT(4(1X,1PE12.5)/)
  731. *
  732. *              ELSE IF (IDECAP.EQ.3) THEN
  733. *              WRITE (6,1343) ((PKK(I,J),J=1,NSTB),I=1,NSTB)
  734. *1343          FORMAT(6(1X,1PE12.5)/)
  735. *              ENDIF
  736. *          ENDIF
  737. *
  738. *           les cas non isotropes
  739. *
  740.          ELSE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  741. *
  742.            IF(MFR.EQ.33) THEN
  743.  
  744.               DO 4379 IM=1,NMATT
  745.                 IF (IVAL(IM).NE.0) THEN
  746.                   MELVAL=IVAL(IM)
  747.                   IBMN=MIN(IB  ,VELCHE(/2))
  748.                   IGMN=MIN(IGAU,VELCHE(/1))
  749.                   VALMAT(IM)=VELCHE(IGMN,IBMN)
  750.                 ELSE
  751.                   VALMAT(IM)=0.D0
  752.                 ENDIF
  753.  4379         CONTINUE
  754. *
  755.               CALL PERMAO(WRK4,IFOUR,MATE,EREF,KERRE)
  756.               IF(KERRE.EQ.1) GO TO 99
  757.               IF(KERRE.EQ.2) THEN
  758.                 I367=IB
  759.                 GO TO 5079
  760.               ENDIF
  761. *
  762. *             REMPLISSAGE POUR CAS MFR=33 UNIQUEMENT
  763. *
  764.               DO 4478 I=1,NSTBE
  765.                 DO 4479 J=1,NSTBE
  766.                    PKK(I,J)=PMAT(I,J)
  767.  4479         CONTINUE
  768.  4478         CONTINUE
  769.  
  770. *         IF(IGAU . EQ . 1 ) THEN
  771. *
  772. *             PRINT *,' MATRICE PKK'
  773. *              IF(NSTBE.EQ.3) THEN
  774. *              WRITE (6,1441) ((PKK(I,J),J=1,NSTB),I=1,NSTB)
  775. *1441          FORMAT(3(1X,1PE12.5)/)
  776. *              ELSE
  777. *              WRITE (6,1341) ((PKK(I,J),J=1,NSTB),I=1,NSTB)
  778. *              ENDIF
  779. *         ENDIF
  780. *
  781.            ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN
  782. *
  783. *              CAS NON PREVU
  784.                GO TO 99
  785.            ENDIF
  786. *
  787. *           les cas non pr\E9vus
  788. *
  789.          ELSE
  790.               GO TO 99
  791.          ENDIF
  792. *
  793. *     CALCUL DES GRADIENTS
  794. *
  795.       DO 9179 IPR=1,IDECAP
  796.          LPPDEC=(IPR-1)*LPP
  797.          NSTDEC=(IPR-1)*NSTBE
  798.          NBBDEC=(IPR-1)*NBBB
  799.          DO 9078 I=1,NSTBE
  800.            AUX(I+NSTDEC)=0.D0
  801.            DO 9079 J=1,LPP
  802.              AUX(I+NSTDEC)= AUX(I+NSTDEC) +
  803.      .          BGENE(I+NSTDEC,J+NBBDEC)*XDDL(J+LPPDEC)
  804.  9079    CONTINUE
  805.  9078    CONTINUE
  806.  9179 CONTINUE
  807.  
  808. *      IF(IGAU.EQ.1) THEN
  809. *      WRITE(6,44552) (AUX (I),I=1,NSTB)
  810. *44552  FORMAT(2X,'AUX '/(4(1X,1PE12.5)/))
  811. *       ENDIF
  812. *
  813.       DO 9278 I=1,NSTB
  814.          GRAD(I)=0.D0
  815.          DO 9279 J=1,NSTB
  816.          GRAD(I)=GRAD(I)+PKK(I,J)*AUX(J)
  817.  9279 CONTINUE
  818.  9278 CONTINUE
  819.  
  820. *       IF(IGAU.EQ.1) THEN
  821. *       WRITE(6,44553) (GRAD (I),I=1,NSTB)
  822. *44553  FORMAT(2X,'GRAD '/(4(1X,1PE12.5)/))
  823. *       ENDIF
  824. C
  825. C  REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS
  826. C
  827.       MPTVAL=IVAGRA
  828.       DO 4179 I=1,NSTB
  829.          MELVAL=IVAL(I)
  830.          VELCHE(IGAU,IB)=GRAD(I)
  831.  4179 CONTINUE
  832.  
  833.  5079 CONTINUE
  834. *
  835.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  836. C
  837.  3079 CONTINUE
  838.  
  839.       SEGSUP WRK1,WRK2,WRK3
  840.       IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  841.         SEGDES MINTE2
  842.         SEGSUP WRK4
  843.       ENDIF
  844. *
  845.       IF(I195.NE.0) THEN
  846.          INTERR(1)=I195
  847.          CALL ERREUR(195)
  848.          GOTO 9990
  849.       ELSE IF(I259.NE.0) THEN
  850.          INTERR(1)=I259
  851.          CALL ERREUR(259)
  852.          GOTO 9990
  853.       ELSE IF(I367.NE.0) THEN
  854.          INTERR(1)=I367
  855.          CALL ERREUR(367)
  856.          GOTO 9990
  857.       ENDIF
  858. *
  859.       GOTO 9990
  860. C
  861. C_______________________________________________________________________
  862. C
  863. C     JOINTS POREUX
  864. C_______________________________________________________________________
  865. C
  866.   80  CONTINUE
  867. C
  868. C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
  869. C                       NBNO = NOMBRE DE FONCTIONS DE FORME
  870. C
  871.       DIM3=1.D0
  872.       NBNO=IPORE
  873.       NBBB=NBNN
  874.       LPP=(NBNO-NBBB)*3/2
  875.       LRN =LPP*IDECAP
  876.       LRE=LRN
  877.       NSTBE=3
  878.       IF(IFOUR.EQ.2) NSTBE=4
  879.       NSTB=NSTBE*IDECAP
  880.       NSTN=1
  881.       NMIL=LPP-NBSOM(IELE)
  882.  
  883. *      PRINT *,'NSTBE=',NSTBE
  884. *      PRINT *,'NSTB=',NSTB
  885. *      PRINT *,'IDECAP=',IDECAP
  886. *      PRINT *,'LPP   =',LPP
  887. *      PRINT *,'LRN   =',LRN
  888. *      PRINT *,'LRE   =',LRE
  889. *      PRINT *,'NBNO  =',NBNO
  890. *      PRINT *,'NBBB  =',NBBB
  891. *      PRINT *,'NSTN  =',NSTN
  892. *      PRINT *,'IFOUR =',IFOUR
  893. *      PRINT *,'NMIL  =',NMIL
  894.  
  895.       SEGINI WRK1,WRK2,WRK3,WRK5,WRK6
  896.       I195=0
  897.       I259=0
  898.       I367=0
  899. C
  900.       DO 3080  IB=1,NBELEM
  901. C
  902. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  903. C
  904.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  905. C
  906. C     ON RECUPERE LES DEPLACEMENTS
  907. C
  908.       MPTVAL=IVADEP
  909.       NCOSOU=IVAL(/1)
  910.  
  911. *      PRINT *,' NBSOM(IELE) =', NBSOM(IELE)
  912. *      PRINT *,' LPP = ', LPP
  913. *      PRINT *,' NCOSOU  = ', NCOSOU
  914.  
  915.         IE=0
  916.         DO 8080 I=1,NCOSOU
  917.            MELVAL=IVAL(I)
  918.            DO 8180 IGAU=1,NBSOM(IELE)
  919.               IGAUSO=IBSOM(NSPOS(IELE)+IGAU-1)
  920.               IGMN=MIN(IGAUSO,VELCHE(/1))
  921.               IBMN=MIN(IB    ,VELCHE(/2))
  922.               IE=IE+1
  923.               XDDL(IE)=VELCHE(IGMN,IBMN)
  924.  8180      CONTINUE
  925. *
  926.            DO 8280 IGAU=1,NMIL
  927.               IE=IE+1
  928.               IGAUSO=NBBB - NMIL + IGAU
  929.               IGMN=MIN(IGAUSO,VELCHE(/1))
  930.               IBMN=MIN(IB    ,VELCHE(/2))
  931.               XDDL(IE)=VELCHE(IGMN,IBMN)
  932.  8280      CONTINUE
  933.  8080    CONTINUE
  934.  
  935. *       WRITE(6,48551) (XDDL(I),I=1,LRN)
  936. *48551  FORMAT(2X,'XDDL'/(4(1X,1PE12.5)/))
  937.  
  938. C
  939. C     CALCUL DES AXES LOCAUX ET DES COORDONNEES LOCALES
  940. C
  941.       CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  942.  
  943. *     PRINT *, 'MATRICE BPSS '
  944. *         WRITE(6,67564) ((BPSS(I,J),J=1,3),I=1,3)
  945. *67564    FORMAT(2X,3(1X,1PE12.5)/)
  946.  
  947. C
  948. C     BOUCLE SUR LES POINTS DE GAUSS
  949. C
  950.       ISDJC=0
  951.       DO 5080  IGAU=1,NBPGAU
  952. C
  953. C   RECUPERATION DE L'EPAISSEUR
  954. C
  955. *     IF (IFOUR.EQ.-2)THEN
  956. *       MPTVAL=IVACAR
  957. *       IF (IVACAR.NE.0) THEN
  958. *        MELVAL=IVAL(1)
  959. *        IF (MELVAL.NE.0) THEN
  960. *         IGMN=MIN(IGAU,VELCHE(/1))
  961. *         IBMN=MIN(IB,VELCHE(/2))
  962. *         DIM3=VELCHE(IGMN,IBMN)
  963. *        ELSE
  964. *         DIM3=1.D0
  965. *        ENDIF
  966. *       ENDIF
  967. *     ENDIF
  968. C
  969.       CALL BNQORJ(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,XE,XEL,
  970.      .    SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,1)
  971.  
  972. *     IF(IGAU.EQ.1) THEN
  973. *     PRINT *,' MATRICE B LIGNE PAR LIGNE '
  974. *     DO 3867 IPZ = 1,NSTB
  975. *       PRINT *,' LIGNE ',IPZ
  976. *       WRITE(6,3868) (BGENE(IPZ,JPZ), JPZ=1,LRE)
  977. *3868        FORMAT(8(1X,1PE10.3)/)
  978. *3867 CONTINUE
  979. *        WRITE(6,77442) ((BGENE(I,J),J=1,LRE),I=1,NSTB)
  980. *77442   FORMAT(//6(1X,1PE12.5))
  981. *        WRITE(6,77443) (XDDL(I),I=1,LRN)
  982. *77443   FORMAT(//6(1X,1PE12.5))
  983. *      ENDIF
  984.  
  985.       IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  986.       IF(DJAC.EQ.0.D0) I259=IB
  987.  
  988. *
  989. *    CALCUL DES GRADIENTS
  990. *
  991.         DO 9180 IPR=1,IDECAP
  992.            LPPDEC=(IPR-1)*LPP
  993.            NSTDEC=(IPR-1)*NSTBE
  994.            DO 9080 I=1,NSTBE
  995.              II=I+NSTDEC
  996.              r_z = 0.D0
  997.              DO 9081 J=1,LPP
  998.                JJ=J+LPPDEC
  999.                r_z = r_z + BGENE(II,JJ)*XDDL(JJ)
  1000.  9081        CONTINUE
  1001.              AUX(II)=r_z
  1002.  9080        CONTINUE
  1003.  9180   CONTINUE
  1004.  
  1005. C
  1006. C     ON RECUPERE LE MATERIAU
  1007. C
  1008.       EREF=1.D0
  1009.       MPTVAL=IVAMAT
  1010. *
  1011. *     le cas isotrope (le seul)
  1012. *
  1013.  
  1014.       IF(MELE.GE.108.AND.MELE.LE.110) THEN
  1015.  
  1016.         MELVAL=IVAL(4)
  1017.         IGMN=MIN(IGAU,VELCHE(/1))
  1018.         IBMN=MIN(IB  ,VELCHE(/2))
  1019.         XMU =VELCHE(IGMN,IBMN)
  1020.         IF(XMU.EQ.0.D0) THEN
  1021.            I367=IB
  1022.            GO TO 5080
  1023.         ENDIF
  1024. *
  1025.         FAC = EREF*EREF/XMU
  1026. *  H
  1027.         MELVAL=IVAL(1)
  1028.         IGMN=MIN(IGAU,VELCHE(/1))
  1029.         IBMN=MIN(IB  ,VELCHE(/2))
  1030.         PKK(1,1)=VELCHE(IGMN,IBMN)*FAC
  1031. *  B
  1032.         MELVAL=IVAL(2)
  1033.         IGMN=MIN(IGAU,VELCHE(/1))
  1034.         IBMN=MIN(IB  ,VELCHE(/2))
  1035.         PKK(2,2)=VELCHE(IGMN,IBMN)*FAC
  1036. *  T
  1037.         MELVAL=IVAL(3)
  1038.         IGMN=MIN(IGAU,VELCHE(/1))
  1039.         IBMN=MIN(IB  ,VELCHE(/2))
  1040.         PKK(3,3)=VELCHE(IGMN,IBMN)*FAC
  1041.         IF(NSTBE.EQ.4) THEN
  1042.            PKK(4,4) = PKK(3,3)
  1043.         ENDIF
  1044.  
  1045.         DO 9280 I=1,NSTB
  1046.            GRAD(I)=PKK(I,I)*AUX(I)
  1047.  9280   CONTINUE
  1048.  
  1049. *
  1050.       ELSE IF(MELE.GE.185.AND.MELE.LE.190) THEN
  1051.  
  1052.         FAC = EREF*EREF
  1053.         IE=0
  1054.         DO 2184 IPR=1,IDECAP
  1055.           IPR1 = (IPR-1) * NSTBE
  1056.           DO 2185 JPR=1,IDECAP
  1057.             JPR1 = (JPR-1) * NSTBE
  1058.             DO 2186 I=1,NSTBE
  1059.               II = I + IPR1
  1060.               JJ = I + JPR1
  1061.               IF(I.NE.4) THEN
  1062.                 IE=IE+1
  1063.                 MELVAL=IVAL(IE)
  1064.                 IGMN=MIN(IGAU,VELCHE(/1))
  1065.                 IBMN=MIN(IB  ,VELCHE(/2))
  1066.                 PKK(II,JJ)=VELCHE(IGMN,IBMN)*FAC
  1067.               ELSE
  1068.                 PKK(II,JJ)=PKK(II-1,JJ-1)
  1069.               ENDIF
  1070. 2186        CONTINUE
  1071. 2185    CONTINUE
  1072. 2184    CONTINUE
  1073.  
  1074.         CALL ZERO(GRAD,NSTB,1)
  1075.         DO 2479 IPR=1,IDECAP
  1076.           IPR1 = (IPR-1) * NSTBE
  1077.           DO 2480 JPR=1,IDECAP
  1078.             JPR1 = (JPR-1) * NSTBE
  1079.             DO 2485 I=1,NSTBE
  1080.               II = I + IPR1
  1081.               JJ = I + JPR1
  1082.               GRAD(II)=GRAD(II)+PKK(II,JJ)*AUX(JJ)
  1083.  2485       CONTINUE
  1084.  2480   CONTINUE
  1085.  2479   CONTINUE
  1086.  
  1087.       ENDIF
  1088.  
  1089. *        IF(IGAU.EQ.1) THEN
  1090. *        PRINT *, '  MATRICE PKK '
  1091. *        WRITE(6,77444) ((PKK(I,J),J=1,NSTB),I=1,NSTB)
  1092. *77444   FORMAT(//6(1X,1PE12.5))
  1093. *       WRITE(6,48553) (GRAD (I),I=1,NSTB)
  1094. *48553  FORMAT(2X,'GRAD '/(4(1X,1PE12.5)/))
  1095. *       ENDIF
  1096. C
  1097. C  REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS
  1098. C
  1099.         MPTVAL=IVAGRA
  1100.         DO 4180 I=1,NSTB
  1101.            MELVAL=IVAL(I)
  1102.            VELCHE(IGAU,IB)=GRAD(I)
  1103.  4180   CONTINUE
  1104. *
  1105.  5080  CONTINUE
  1106. *
  1107.       IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1108. *
  1109.  3080 CONTINUE
  1110.  
  1111.       SEGSUP WRK1,WRK2,WRK3,WRK5,WRK6
  1112. *
  1113.       IF(I195.NE.0) THEN
  1114.          INTERR(1)=I195
  1115.          CALL ERREUR(195)
  1116.          GOTO 9990
  1117.       ELSE IF(I259.NE.0) THEN
  1118.          INTERR(1)=I259
  1119.          CALL ERREUR(259)
  1120.          GOTO 9990
  1121.       ELSE IF(I367.NE.0) THEN
  1122.          INTERR(1)=I367
  1123.          CALL ERREUR(367)
  1124.          GOTO 9990
  1125.       ENDIF
  1126. *
  1127.       GOTO 9990
  1128. *
  1129.  99   CONTINUE
  1130.       MOTERR(1:4)=NOMTP(MELE)
  1131.       MOTERR(9:12)='GRAD'
  1132.       CALL ERREUR(86)
  1133. C
  1134. C____________________________________________________________________
  1135. C
  1136. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  1137. C____________________________________________________________________
  1138. C
  1139.  9990 CONTINUE
  1140.       SEGDES MELEME
  1141. *
  1142.       CALL DTMVAL(IVADEP,1)
  1143.       CALL DTMVAL(IVAMAT,1)
  1144.       CALL DTMVAL(IVAGRA,1)
  1145. *
  1146.       IF(IERR.NE.0)THEN
  1147.         IF (MCHAML.NE.0) SEGSUP MCHAML
  1148.       ELSE
  1149.         SEGDES MCHAML
  1150.       ENDIF
  1151. *
  1152.       IF(MOMATR.NE.0)THEN
  1153.          NOMID=MOMATR
  1154.          SEGSUP NOMID
  1155.       ENDIF
  1156. *
  1157.       IF(MOGRAD.NE.0)THEN
  1158.          NOMID=MOGRAD
  1159.          SEGSUP NOMID
  1160.       ENDIF
  1161. *
  1162.       IF(MODEPL.NE.0)THEN
  1163.          NOMID=MODEPL
  1164.          SEGSUP NOMID
  1165.       ENDIF
  1166. *
  1167.       SEGDES MINTE
  1168. C
  1169. C     DANS LE CAS D'ERREUR
  1170. C
  1171.       IF(IERR.NE.0) GOTO 888
  1172. *
  1173.  500  CONTINUE
  1174. * Fin normale
  1175.       IRET = 1
  1176. *
  1177.       if(n1.ne.isouss) then
  1178.        n1=isouss
  1179.        segadj mchelm
  1180.       endif
  1181.       SEGDES,MCHELM
  1182.  
  1183.  888  CONTINUE
  1184.       DO ISOUS = 1,NSOUS
  1185.         IMODEL=KMODEL(ISOUS)
  1186.         SEGDES,IMODEL
  1187.       ENDDO
  1188.       SEGDES,MMODEL
  1189. *
  1190.       RETURN
  1191.       END
  1192.  
  1193.  
  1194.  
  1195.  

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