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

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