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

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