Télécharger la plaquette Cast3M


fr en

Télécharger graf1.eso

Retour à la liste

Numérotation des lignes : 

graf1

  1. C GRAF1     SOURCE    OF166741  25/02/21    21:17:19     12166          
  2.       SUBROUTINE GRAF1(IPMODL,IPCHE2,IPCHE1,IPCHL1,IRET)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. *____________________________________________________________________*
  6. *                                                                    *
  7. *     Sous-programme de l'op{rateur GRADIENT DE FLEXION              *
  8. *                                                                    *
  9. *     Entr{es:                                                       *
  10. *                                                                    *
  11. *        IPMODL    Pointeur sur un objet MMODEL                      *
  12. *        IPCHE2    Pointeur sur un MCHAML de DEPLACEMENT             *
  13. *        IPCHE1    Pointeur sur un MCHAML de CARACTERISTIQUES        *
  14. *                                                                    *
  15. *     Sortie:                                                        *
  16. *                                                                    *
  17. *        IPCHL1    Pointeur sur un MCHAML de gradients               *
  18. *        IRET       1 si succes , 0 sinon                            *
  19. *                                                                    *
  20. *     Auteurs, date de cr{ation:                                     *
  21. *                                                                    *
  22. *     SUO X.Z Le 19/21/1986                                          *
  23. *     Passage aux nouveux chamelems par P.DOWLATYARI  le 28/03/91    *
  24. *                                                                    *
  25. *____________________________________________________________________*
  26. *
  27.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC CCHAMP
  31.  
  32. -INC SMCHAML
  33. -INC SMMODEL
  34. -INC SMELEME
  35. -INC SMINTE
  36. -INC SMCOORD
  37.  
  38. -INC TMPTVAL
  39.  
  40.       SEGMENT,MWRK1
  41.          REAL*8 XDDL(LRE),XE(3,NBBB),GRADF(NGRAF)
  42.          REAL*8 DDHOOK(NSTRS,NSTRS),DDHOMU(NSTRS,NSTRS)
  43.       ENDSEGMENT
  44. *
  45.       SEGMENT,MWRK2
  46.          REAL*8 SHPWRK(6,NBNO),BGF(NGRAF,LRE)
  47.       ENDSEGMENT
  48. *
  49.       SEGMENT,MWRK3
  50.          REAL*8 WORK(LW)
  51.       ENDSEGMENT
  52. *
  53.       SEGMENT,MWRK4
  54.          REAL*8 BPSS(3,3),XEL(3,NBBB),XDDLOC(LRE)
  55.       ENDSEGMENT
  56. *
  57.       SEGMENT NOTYPE
  58.         CHARACTER*16 TYPE(NBTYPE)
  59.       ENDSEGMENT
  60. *
  61.       SEGMENT MVELCH
  62.          REAL*8 VALMAT(NV1)
  63.       ENDSEGMENT
  64. *
  65.       CHARACTER*8  CMATE
  66.       PARAMETER ( NINF=3 )
  67.       INTEGER INFOS(NINF)
  68.       CHARACTER*(NCONCH) CONM
  69.       LOGICAL lsupgf,lsupdp
  70.  
  71.       lsupgf=.false.
  72.       lsupdp=.false.
  73.       IRET=1
  74.       MWRK1=0
  75.       MWRK2=0
  76.       MWRK3=0
  77.       MWRK4=0
  78.       MVELCH=0
  79.       NMAT = 0
  80.       IMESS= 0
  81.       NHRM = NIFOUR
  82.       SEGACT,MCOORD*NOMOD
  83. *
  84. *     ACTIVATION DU CHAPEAU DE MODELE
  85. *
  86.       MMODEL = IPMODL
  87.       SEGACT MMODEL
  88.       NSOUS = KMODEL(/1)
  89. *
  90. *     Initialisation du CHAMELEM de GRADIENTS DE FLEXION
  91. *
  92.       L1 = 19
  93.       N1 = NSOUS
  94.       N3 = 6
  95.       SEGINI,MCHELM
  96.       IPCHL1=MCHELM
  97.       TITCHE = 'GRADIENT DE FLEXION'
  98.       IFOCHE=IFOUR
  99. *
  100. *     Boucle sur les zones {l{mentaires du MODELE
  101. *
  102.       DO 500 ISOUS=1,NSOUS
  103. *
  104. *    QUELQUES INITIALISATIONS
  105. *
  106.          NGRAF= 0
  107.          MOGRAF=0
  108.          MODEPL=0
  109.          MOMATR=0
  110.          MOCARA=0
  111.          NDEP=0
  112.          NCAR = 0
  113.          IPMINT=0
  114.          IRTD1=1
  115.          NSTRS=0
  116.          IVAGRF=0
  117.          IVADEP=0
  118.          IVAMAT=0
  119.          IVACAR=0
  120.          NMATR=0
  121.          NMATF=0
  122. *
  123.          IMODEL=KMODEL(ISOUS)
  124.          SEGACT IMODEL
  125.          MELE=NEFMOD
  126.          IPMAIL=IMAMOD
  127.          CONM=CONMOD
  128.          NFOR=FORMOD(/2)
  129.          NMAT=MATMOD(/2)
  130.          CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  131.          IF (CMATE.EQ.' ')THEN
  132.            CALL ERREUR(251)
  133.            SEGSUP MCHELM
  134.            IRET=0
  135.            RETURN
  136.          ENDIF
  137. *
  138. *        ACTIVATION DU MAILLAGE
  139. *
  140.          MELEME=IPMAIL
  141.          SEGACT,MELEME
  142.          NBNN  =NUM(/1)
  143.          NBELEM=NUM(/2)
  144.          NBNO=NBNN
  145. *
  146. *        INFORMATIONS SUR L'ELEMENT FINI
  147. *
  148. *         CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  149. *         IF (IERR.NE.0) THEN
  150. *           SEGSUP MCHELM
  151. *           IRET=0
  152. *           RETURN
  153. *         ENDIF
  154. *         INFO=IPINF
  155.          MFR=INFELE(13)
  156. *         MINTE=INFELE(11)
  157.          minte=infmod(7)
  158.          MINTE1= INFMOD(8)
  159.          NSTRS =INFELE(16)
  160.          LW    = INFELE( 7)
  161.          LRE   = INFELE( 9)
  162.          LHOOK =INFELE(10)
  163. *
  164. *        ACTIVATION DU SEGMENT D'INTEGRATION
  165. *
  166.          SEGACT,MINTE
  167.          NBPGAU=POIGAU(/1)
  168. C
  169. C        CREATION DU TABLEAU INFOS
  170. C
  171.          CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRTD)
  172.          IF (IRTD.EQ.0) GOTO 9990
  173. *
  174. *        NOMS DE COMPOSANTES OBLIGATOIRES A TROUVER DANS LES CHAMELEMS
  175. *
  176.          if(lnomid(11).ne.0) then
  177.           nomid=lnomid(11)
  178.           segact nomid
  179.           mograf=nomid
  180.           ngraf=lesobl(/2)
  181.           nfac=lesfac(/2)
  182.           lsupgf=.false.
  183.          else
  184.           lsupgf=.true.
  185.           CALL IDGRAF(MFR,IFOUR,MOGRAF,NGRAF,NFAC)
  186.          endif
  187. *
  188. *        NOMS DE COMPOSANTES DU DEPLACEMENT
  189. *
  190.       if(lnomid(1).ne.0) then
  191.          nomid=lnomid(1)
  192.          segact nomid
  193.          modepl=nomid
  194.          ndep=lesobl(/2)
  195.          nfac=lesfac(/2)
  196.          lsupdp=.false.
  197.       else
  198.          lsupdp=.true.
  199.          CALL IDPRIM(IMODEL,MFR,MODEPL,NDEP,NFAC)
  200.       endif
  201. *
  202. *        VERIFICATION DE PRESENCE DES COMPOSANTES
  203. *
  204.          NBTYPE=1
  205.          SEGINI NOTYPE
  206.          MOTYPE=NOTYPE
  207.          TYPE(1)='REAL*8'
  208.          CALL KOMCHA(IPCHE2,IPMAIL,CONM,MODEPL,
  209.      1               MOTYPE,1,INFOS,3,IVADEP)
  210.          SEGSUP NOTYPE
  211.          IF (IERR.NE.0) THEN
  212.             NGRAF=0
  213.             GO TO 9990
  214.          ENDIF
  215. *
  216. *  RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE
  217. *  TRAVAIL UNIQUEMENT DANS LE CAS DE L'ELEMENT COQUE DST (MELE=93)
  218. *
  219. *  CAS DES POUTRES ET TUYAUX : RECHERCHE DU VECTEUR LOCAL
  220. *
  221.          NBROBL=0
  222.          NBRFAC=0
  223.          MOMATR=0
  224.          MOCARA=0
  225.          NCAR=0
  226.          NMATR=0
  227.          NMATF=0
  228.          IVECT=0
  229. *
  230. *
  231.          IF(MELE.EQ.93.AND.FORMOD(1).EQ.'MECANIQUE'
  232.      1      .AND.CMATE.EQ.'ISOTROPE') THEN
  233.            NBROBL=2
  234.            NBRFAC=0
  235.            SEGINI NOMID
  236.            MOMATR=NOMID
  237.            LESOBL(1)='YOUN'
  238.            LESOBL(2)='NU  '
  239.            NMATR=NBROBL
  240.            NMATF=NBRFAC
  241. *
  242.            IF (IPCHE1.NE.0) THEN
  243.               NBTYPE=1
  244.               SEGINI NOTYPE
  245.               MOTYPE=NOTYPE
  246.               TYPE(1)='REAL*8'
  247.               CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,
  248.      1                    1,INFOS,3,IVAMAT)
  249.               SEGSUP NOTYPE
  250.            ELSE
  251.               MOTERR(1:8)='CARACTER'
  252.               MOTERR(9:12)=NOMTP(MELE)
  253.               MOTERR(13:20)='GRAF'
  254.               CALL ERREUR(145)
  255.               NMATR=0
  256.               NMATF=0
  257.               NGRAF=0
  258.               NOMID=MOMATR
  259.               SEGSUP NOMID
  260.               MOMATR=0
  261.               GOTO 9990
  262.            ENDIF
  263.            IF (IERR.NE.0) GOTO 9990
  264. *
  265.            NMATT=NMATR+NMATF
  266. *
  267.            MPTVAL=IVAMAT
  268.            NBGMAT = 0
  269.            NELMAT = 0
  270.            DO 1108 IM=1,NMATT
  271.              IF(IVAL(IM).NE.0)THEN
  272.                MELVAL=IVAL(IM)
  273.                NBGMAT=MAX(NBGMAT,VELCHE(/1))
  274.                NELMAT=MAX(NELMAT,VELCHE(/2))
  275.              ENDIF
  276.  1108      CONTINUE
  277. C
  278.            NBROBL=1
  279.            NBRFAC=1
  280.            SEGINI NOMID
  281.            MOCARA=NOMID
  282.            LESOBL(1)='EPAI'
  283.            LESFAC(1)='EXCE'
  284.            NCAR=1
  285.            NBTYPE=1
  286.            SEGINI NOTYPE
  287.            MOTYPE=NOTYPE
  288.            TYPE(1)='REAL*8'
  289.            CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,
  290.      1                 MOTYPE,1,INFOS,3,IVACAR)
  291.            SEGSUP NOTYPE
  292.            IF (IERR.NE.0) GOTO 9990
  293.          ENDIF
  294. C
  295.          IF(IVACAR.NE.0)THEN
  296.             MPTVAL=IVACAR
  297.             IPMELV=IVAL(1)
  298.             CALL QUELCH(IPMELV,ICONS)
  299.             IF(ICONS.NE.0)THEN
  300.                CALL ERREUR(566)
  301.                GOTO 9990
  302.             ENDIF
  303. *
  304. *  CAS DES POUTRES ET TUYAUX
  305. *
  306.          ELSE IF(MFR.EQ.7) THEN
  307.           IF (CMATE.EQ.'SECTION') THEN
  308.            NBROBL=0
  309.            NBRFAC=3
  310.            SEGINI NOMID
  311.            MOCARA=NOMID
  312.            LESFAC(1)='VX'
  313.            LESFAC(2)='VY'
  314.            LESFAC(3)='VZ'
  315.            IVECT=1
  316. *
  317.            NBTYPE=3
  318.            SEGINI NOTYPE
  319.            TYPE(1)='REAL*8'
  320.            TYPE(2)='REAL*8'
  321.            TYPE(3)='REAL*8'
  322.           ELSE
  323.            IF(IFOUR.EQ.2) THEN
  324.              NBROBL=4
  325.              NBRFAC=5
  326.              SEGINI NOMID
  327.              MOCARA=NOMID
  328.              LESOBL(1)='TORS'
  329.              LESOBL(2)='INRY'
  330.              LESOBL(3)='INRZ'
  331.              LESOBL(4)='SECT'
  332.              LESFAC(1)='SECY'
  333.              LESFAC(2)='SECZ'
  334.              LESFAC(3)='VX'
  335.              LESFAC(4)='VY'
  336.              LESFAC(5)='VZ'
  337.              IVECT=1
  338. *
  339.              NBTYPE=9
  340.              SEGINI NOTYPE
  341.              TYPE(1)='REAL*8'
  342.              TYPE(2)='REAL*8'
  343.              TYPE(3)='REAL*8'
  344.              TYPE(4)='REAL*8'
  345.              TYPE(5)='REAL*8'
  346.              TYPE(6)='REAL*8'
  347.              TYPE(7)='REAL*8'
  348.              TYPE(8)='REAL*8'
  349.              TYPE(9)='REAL*8'
  350.            ELSEIF(IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.63) THEN
  351.              NBRFAC=1
  352.              NBROBL=2
  353.              SEGINI NOMID
  354.              MOCARA=NOMID
  355.              LESOBL(1)= 'SECT'
  356.              LESOBL(2)= 'INRZ'
  357.              LESFAC(1)= 'SECY'
  358. *
  359.              NBTYPE=1
  360.              SEGINI NOTYPE
  361.              TYPE(1)='REAL*8'
  362.            ENDIF
  363.           ENDIF
  364. C
  365. C     CARACTERISTIQUE POUR LES TUYAUX
  366. C
  367.         ELSE IF (MFR.EQ.13) THEN
  368.            NBROBL=2
  369.            NBRFAC=5
  370.            SEGINI NOMID
  371.            MOCARA=NOMID
  372.            LESOBL(1)='EPAI'
  373.            LESOBL(2)='RAYO'
  374.            LESFAC(1)='RACO'
  375.            LESFAC(2)='CISA'
  376.            LESFAC(3)='VX'
  377.            LESFAC(4)='VY'
  378.            LESFAC(5)='VZ'
  379.            IVECT=1
  380. C
  381.            NBTYPE=7
  382.            SEGINI NOTYPE
  383.            TYPE(1)='REAL*8'
  384.            TYPE(2)='REAL*8'
  385.            TYPE(3)='REAL*8'
  386.            TYPE(4)='REAL*8'
  387.            TYPE(5)='REAL*8'
  388.            TYPE(6)='REAL*8'
  389.            TYPE(7)='REAL*8'
  390. C
  391.         ENDIF
  392.         NCARA=NBROBL
  393.         NCARF=NBRFAC
  394.         NCAR=NBROBL+NBRFAC
  395.  
  396. C  Verification de la presence des caracteristiques dans IPCHE1
  397.  
  398.         IF (NCAR.NE.0) THEN
  399.           IF (IPCHE1.NE.0) THEN
  400.             MOTYPE=NOTYPE
  401.             CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,
  402.      .                  INFOS,3,IVACAR)
  403.             SEGSUP,NOTYPE
  404.             IF(IERR.NE.0) GOTO 9990
  405.             IF (IVACAR.NE.0) THEN
  406.               MPTVAL=IVACAR
  407.               IPMELV=IVAL(1)
  408.               CALL QUELCH(IPMELV,ICONS)
  409.               IF (ICONS.NE.0) THEN
  410.                 CALL ERREUR(566)
  411.                 GOTO 9990
  412.               ENDIF
  413.             ENDIF
  414. *
  415. *  CAS DES POUTRES : TRAITEMENT DES VECTEURS
  416.  
  417.           ELSE
  418.             SEGSUP,NOTYPE
  419.             MOTERR(1:8)='CARACTER'
  420.             MOTERR(9:12)=NOMTP(MELE)
  421.             MOTERR(13:20)='GRAF'
  422.             CALL ERREUR(145)
  423.             GOTO 9990
  424.           ENDIF
  425.         ENDIF
  426. *
  427. C =====
  428. C Cas d'un joint unidimensionnel JOI1
  429. C   Chargement des vecteurs stitués dans les caractéristiques matériau
  430. C =====
  431.        IF(MFR.EQ.75) THEN
  432.              IF(IDIM.EQ.3) THEN
  433.              NBROBL=6
  434.              NBRFAC=0
  435.              SEGINI NOMID
  436.              MOMATR=NOMID
  437.              LESOBL(1)='V1X'
  438.              LESOBL(2)='V1Y'
  439.              LESOBL(3)='V1Z'
  440.              LESOBL(4)='V2X'
  441.              LESOBL(5)='V2Y'
  442.              LESOBL(6)='V2Z'
  443.              NMATR=NBROBL
  444.              NMATF=NBRFAC
  445.           ELSE IF(IDIM.EQ.2) THEN
  446.              NBROBL=2
  447.              NBRFAC=0
  448.              SEGINI NOMID
  449.              MOMATR=NOMID
  450.              LESOBL(1)='V1X'
  451.              LESOBL(2)='V1Y'
  452.              NMATR=NBROBL
  453.              NMATF=NBRFAC
  454.           ENDIF
  455.             NBTYPE=1
  456.             SEGINI NOTYPE
  457.             TYPE(1)='REAL*8'
  458.             MOTYPE=NOTYPE
  459. *
  460.          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  461.          SEGSUP NOTYPE
  462.          IF (IERR.NE.0) GOTO 9990
  463. *
  464.           NMATT=NMATR+NMATF
  465. *                                                                        C
  466.           IF(ISUP1.EQ.1)THEN
  467.             CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  468.             IF(IERR.NE.0)THEN
  469.                ISUP1=0
  470.                GOTO 9990
  471.             ENDIF
  472.           ENDIF
  473.           MPTVAL=IVAMAT
  474.           NBGMAT = 0
  475.           NELMAT = 0
  476.           DO 11265 IM=1,NMATT
  477.             IF(IVAL(IM).NE.0)THEN
  478.               MELVAL=IVAL(IM)
  479.               IF (CMATE.EQ.'SECTION') THEN
  480.                 NBGMAT=MAX(NBGMAT,IELCHE(/1))
  481.                 NELMAT=MAX(NELMAT,IELCHE(/2))
  482.               ELSE
  483.                 NBGMAT=MAX(NBGMAT,VELCHE(/1))
  484.                 NELMAT=MAX(NELMAT,VELCHE(/2))
  485.               ENDIF
  486.             ENDIF
  487. 11265    CONTINUE
  488.         nmattd=nmatt
  489.         ivamtd= ivamat
  490.        ENDIF
  491. *
  492. *        CREATION DU MCHAML DE GRADIENT DE FLEXION
  493. *
  494.          N2=NGRAF
  495.          SEGINI,MCHAML
  496.          ICHAML(ISOUS)=MCHAML
  497.          IMACHE(ISOUS)=MELEME
  498.          CONCHE(ISOUS)=CONMOD
  499. *
  500.          INFCHE(ISOUS,1)=0
  501.          INFCHE(ISOUS,2)=0
  502.          INFCHE(ISOUS,3)=NHRM
  503.          INFCHE(ISOUS,4)=MINTE
  504.          INFCHE(ISOUS,5)=0
  505.          INFCHE(ISOUS,6)=5
  506. *
  507. *        RECHERCHE DES DIMENSIONS LES PLUS GRANDES
  508. *
  509.          N1EL=0
  510.          N1PTEL=0
  511.          MPTVAL=IVADEP
  512.          DO 178 IO=1,NDEP
  513.            MELVAL=IVAL(IO)
  514.            N1PTEL=MAX(N1PTEL,VELCHE(/1))
  515.            N1EL  =MAX(N1EL  ,VELCHE(/2))
  516.  178     CONTINUE
  517. *
  518.          IF(IVACAR.NE.0)THEN
  519.            MPTVAL=IVACAR
  520.            DO 179 IO=1,NCAR
  521.              IF(IVAL(IO).NE.0) THEN
  522.                MELVAL=IVAL(IO)
  523.                N1PTEL=MAX(N1PTEL,VELCHE(/1))
  524.                N1EL  =MAX(N1EL  ,VELCHE(/2))
  525.              ENDIF
  526.  179       CONTINUE
  527.          ENDIF
  528. *
  529.          IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN
  530.            N1PTEL=1
  531.          ELSE
  532.            N1PTEL=NBPGAU
  533.          ENDIF
  534.          N1EL  =MIN(N1EL  ,NBELEM)
  535. *
  536. *        CREATION DES MELVAL DU GRADIENT DE FLEXION
  537. *
  538.          NSR=1
  539.          NCOSOR=NGRAF
  540.          SEGINI MPTVAL
  541.          IVAGRF=MPTVAL
  542.          NOMID=MOGRAF
  543.          SEGACT NOMID
  544.          DO 77 IGR=1,NGRAF
  545.            TYPCHE(IGR)='REAL*8'
  546.            NOMCHE(IGR)=LESOBL(IGR)
  547.            N2PTEL=0
  548.            N2EL=0
  549.            SEGINI MELVAL
  550.            IELVAL(IGR)=MELVAL
  551.            IVAL(IGR)=MELVAL
  552.  77      CONTINUE
  553. *
  554. C=======================================================================
  555. C     NUMERO DES ETIQUETTES      :
  556. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  557. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  558. C     5  CONTINUE
  559. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  560. C     44 CONTINUE
  561. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  562. C=======================================================================
  563.       GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  564.      1      99,99,99,99,99,99,27,28,29,99,99,99,99,99,99,99,99,99,99,99,
  565.      2      99,29,99,44,99,99,99,99,49,99,99,99,99,99,99,99,99,99,99,99,
  566.      3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  567.      4      99,99,99,29,99,99,99,99,99,99,99,99,93,99,99,99,99),MELE
  568. C
  569.           IF (MELE.EQ.265) GOTO 265
  570.  99   CONTINUE
  571.       MOTERR(1:4)=NOMTP(MELE)
  572.       MOTERR(9:12)='GRAF'
  573.       IMESS = 86
  574.       GOTO 9990
  575. *
  576. C    ______________________
  577. C   |    ELEMENTS  COQ3    |
  578. C   |______________________|
  579.   27  CONTINUE
  580.       NBBB=NBNN
  581.       SEGINI MWRK1,MWRK3
  582. C
  583. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  584. C
  585.       DO  3027 IB=1,NBELEM
  586. C
  587. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  588. C
  589.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  590. C
  591. C     ON CHERCHE LES DEPLACEMENTS
  592. C
  593.       IE=0
  594.       MPTVAL=IVADEP
  595.       DO 4027 IGAU=1,NBNN
  596.         DO ICOMP=1,NDEP
  597.            IE=IE+1
  598.            MELVAL=IVAL(ICOMP)
  599.            IF (MELVAL.NE.0) THEN
  600.              IGMN=MIN(IGAU,VELCHE(/1))
  601.              IBMN=MIN(IB  ,VELCHE(/2))
  602.              XDDL(IE)=VELCHE(IGMN,IBMN)
  603.            ELSE
  604.              XDDL(IE)=0.D0
  605.            ENDIF
  606.         ENDDO
  607.  4027 CONTINUE
  608.  
  609. C
  610.       CALL COQ3GF(XE,XDDL,GRADF,WORK)
  611. C
  612. C     REMPLISAGE DU SEGMENT CONTENANT LES GRADIENT EN FLEXION
  613. C
  614.         MPTVAL=IVAGRF
  615.         DO 6027 IC=1,NGRAF
  616.  
  617.           MELVAL=IVAL(IC)
  618.           IBMN=MIN(IB  ,VELCHE(/2))
  619.           IF (IC.EQ.3.OR.IC.GE.6) THEN
  620.             VELCHE(1,IBMN)=0.D0
  621.           ELSE
  622.             VELCHE(1,IBMN)=GRADF(IC)
  623.           ENDIF
  624.  6027   CONTINUE
  625. C
  626.  3027 CONTINUE
  627.       GOTO 510
  628. C      ______________________
  629. C      |     ELEMENT DKT     |
  630. C      |_____________________|
  631.   28  CONTINUE
  632.       NBNO=NBNN
  633.       NBBB=NBNN
  634.       SEGINI MWRK1,MWRK2,MWRK4
  635.       DO 3028  IB=1,NBELEM
  636. C
  637. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  638. C
  639.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  640. C
  641. C     ON CHERCHE LES DEPLACEMENTS
  642. C
  643.       IE=0
  644.       MPTVAL=IVADEP
  645.       DO 4028 IGAU=1,NBNN
  646.         DO ICOMP=1,NDEP
  647.            IE=IE+1
  648.            MELVAL=IVAL(ICOMP)
  649.            IF (MELVAL.NE.0) THEN
  650.              IGMN=MIN(IGAU,VELCHE(/1))
  651.              IBMN=MIN(IB  ,VELCHE(/2))
  652.              XDDL(IE)=VELCHE(IGMN,IBMN)
  653.            ELSE
  654.              XDDL(IE)=0.D0
  655.            ENDIF
  656.         ENDDO
  657.  4028 CONTINUE
  658.  
  659.       CALL VPAST(XE,BPSS)
  660. C     BPSS    STOCKE LA MATRICE DE PASSAGE
  661.       CALL VCORLC (XE,XEL,BPSS)
  662.       CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  663. C
  664. C     BOUCLE SUR LES POINTS DE GAUSS
  665. C
  666.       DO 5028  IGAU=1,NBPGAU
  667.       CALL BGFDKT(IGAU,MELE,LRE,IFOUR,XEL,BGF)
  668.       CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF)
  669. C
  670. C     REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI
  671. C
  672.         MPTVAL=IVAGRF
  673.         DO 9028 IC=1,NGRAF
  674.           MELVAL=IVAL(IC)
  675.           IGMN=MIN(IGAU,VELCHE(/1))
  676.           IBMN=MIN(IB  ,VELCHE(/2))
  677.           IF (IC.EQ.3.OR.IC.GE.6) THEN
  678.             VELCHE(IGMN,IBMN)=0.D0
  679.           ELSE
  680.             VELCHE(IGMN,IBMN)=GRADF(IC)
  681.           ENDIF
  682.  9028   CONTINUE
  683.  5028 CONTINUE
  684.  3028 CONTINUE
  685.       GOTO 510
  686. C      ______________________
  687. C      |     ELEMENT DST     |
  688. C      |_____________________|
  689.   93  CONTINUE
  690.       NBNO=NBNN
  691.       NBBB=NBNN
  692.       NV1=NMATT
  693.       SEGINI MWRK1,MWRK2,MWRK3,MWRK4,MVELCH
  694.       DO 3093  IB=1,NBELEM
  695. C
  696. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  697. C
  698.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  699. C
  700. C     ON CHERCHE LES DEPLACEMENTS
  701. C
  702.       IE=0
  703.       MPTVAL=IVADEP
  704.       DO 4093 IGAU=1,NBNN
  705.         DO ICOMP=1,NDEP
  706.          IE=IE+1
  707.          MELVAL=IVAL(ICOMP)
  708.          IF (MELVAL.NE.0) THEN
  709.            IGMN=MIN(IGAU,VELCHE(/1))
  710.            IBMN=MIN(IB  ,VELCHE(/2))
  711.            XDDL(IE)=VELCHE(IGMN,IBMN)
  712.          ELSE
  713.            XDDL(IE)=0.D0
  714.          ENDIF
  715.         ENDDO
  716.  4093 CONTINUE
  717. C
  718.       CALL VPAST(XE,BPSS)
  719. C     BPSS    STOCKE LA MATRICE DE PASSAGE
  720.       CALL VCORLC (XE,XEL,BPSS)
  721.       CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  722. C
  723. C     ON CHERCHE LES EPAISEURS ET ON LES MOYENNE,
  724. C                LES EXCENTREMENTS ET ON LES MOYENNE.
  725. C
  726.       EPAIST=0.D0
  727.       EXCEN=0.D0
  728.       MPTVAL=IVACAR
  729.       DO 8093 IGAU=1,NBPGAU
  730.         MELVAL=IVAL(1)
  731.         IF (MELVAL.NE.0) THEN
  732.           IGMN=MIN(IGAU,VELCHE(/1))
  733.           IBMN=MIN(IB,VELCHE(/2))
  734.           EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  735.         ELSE
  736.           EPAIST=0.D0
  737.         ENDIF
  738. *
  739.         MELVAL=IVAL(2)
  740.         IF (MELVAL.NE.0) THEN
  741.           IGMN=MIN(IGAU,VELCHE(/1))
  742.           IBMN=MIN(IB,VELCHE(/2))
  743.           EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  744.         ELSE
  745.           EXCEN=0.D0
  746.         ENDIF
  747.  8093 CONTINUE
  748.       EPAIST=EPAIST/NBPGAU
  749.       EXCEN=EXCEN/NBPGAU
  750. C
  751. C     BOUCLE SUR LES POINTS DE GAUSS
  752. C
  753.       DO 5093  IGAU=1,NBPGAU
  754.         MPTVAL=IVAMAT
  755.         DO 9193 IM=1,NMATT
  756.           IF (IVAL(IM).NE.0) THEN
  757.              MELVAL=IVAL(IM)
  758.              IBMN=MIN(IB  ,VELCHE(/2))
  759.              IGMN=MIN(IGAU,VELCHE(/1))
  760.              VALMAT(IM)=VELCHE(IGMN,IBMN)
  761.            ELSE
  762.              VALMAT(IM)=0.D0
  763.            ENDIF
  764.  9193   CONTINUE
  765.         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  766.      1     CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD1)
  767.         CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU)
  768.         CALL ZERO(BGF,NGRAF,LRE)
  769. C
  770. C     CALCUL DES FONCTIONS HS4,HS5 ET HS6
  771. C
  772.         CALL HS456(XEL,NSTRS,DDHOMU,WORK(1),WORK(10),WORK(19))
  773. C
  774. C     TERMES DE LA MATRICE DE BGF RELATIFS
  775. C     AUX DEFORMATONS DE FLEXION
  776. C
  777.         CALL BGFDST(IGAU,XEL,NGRAF,QSIGAU,ETAGAU,
  778.      1          WORK(1),WORK(10),WORK(19),BGF)
  779.         CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF)
  780. C
  781. C     REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI
  782. C
  783.         MPTVAL=IVAGRF
  784.         DO 9093 IC=1,NGRAF
  785.           MELVAL=IVAL(IC)
  786.           IGMN=MIN(IGAU,VELCHE(/1))
  787.           IBMN=MIN(IB  ,VELCHE(/2))
  788.           IF (IC.EQ.3.OR.IC.GE.6) THEN
  789.             VELCHE(IGMN,IBMN)=0.D0
  790.           ELSE
  791.             VELCHE(IGMN,IBMN)=GRADF(IC)
  792.           ENDIF
  793.  9093   CONTINUE
  794.  5093 CONTINUE
  795.  3093 CONTINUE
  796.       GOTO 510
  797. C  _____________________________________
  798. C  |      COQUES A 4 NOEUDS   COQ4     |
  799. C  |___________________________________|
  800.    49 CONTINUE
  801.       NBNO=NBNN
  802.       NBBB=NBNN
  803.       SEGINI MWRK1,MWRK2,MWRK4
  804.       DO 3049 IB=1,NBELEM
  805. C
  806. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  807. C
  808.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  809. C
  810.       CALL CQ4LOC(XE,XEL,BPSS,IERT,IUN)
  811. C     IERT=1 NODI  TROPPO VICINI
  812. C     IERT=2 NODI  ELEMENTO NON COMPLANARI
  813.       IF(IERT.NE.0)THEN
  814.        IF(IERT.EQ.1)IMESS=323
  815.        IF(IERT.EQ.2)IMESS=322
  816.        GO TO 9990
  817.       ENDIF
  818. C
  819. C     ON CHERCHE LES DEPLACEMENTS
  820. C
  821.       IE=0
  822.       MPTVAL=IVADEP
  823.       DO 2049 IGAU=1,NBNN
  824.         DO ICOMP=1,NDEP
  825.          IE=IE+1
  826.          MELVAL=IVAL(ICOMP)
  827.          IF (MELVAL.NE.0) THEN
  828.            IGMN=MIN(IGAU,VELCHE(/1))
  829.            IBMN=MIN(IB  ,VELCHE(/2))
  830.            XDDL(IE)=VELCHE(IGMN,IBMN)
  831.          ELSE
  832.            XDDL(IE)=0.D0
  833.          ENDIF
  834.         ENDDO
  835.  2049 CONTINUE
  836.  
  837. C
  838.       CALL MATVEC(XDDL,XDDLOC,BPSS,8)
  839. C
  840. C     BOUCLE SUR LES POINTS DE GAUSS
  841. C
  842.       DO 4049 IGAU=1,NBPGAU
  843. C
  844. C     APPEL A BGFCQ4
  845. C
  846.       CALL BGFCQ4(IGAU,XEL,SHPTOT,SHPWRK,BGF,DJAC,IERT)
  847. C     IERT=1 JACOBIANO <= 0
  848.       IF(IERT.EQ.1)THEN
  849.        IMESS=321
  850.        GO TO 9990
  851.       ENDIF
  852. C
  853.       CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF)
  854. C
  855. C     REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI
  856. C
  857.         MPTVAL=IVAGRF
  858.         DO 9049 IC=1,NGRAF
  859.           MELVAL=IVAL(IC)
  860.           IGMN=MIN(IGAU,VELCHE(/1))
  861.           IBMN=MIN(IB  ,VELCHE(/2))
  862.           IF (IC.EQ.3.OR.IC.GE.6) THEN
  863.             VELCHE(IGMN,IBMN)=0.D0
  864.           ELSE
  865.             VELCHE(IGMN,IBMN)=GRADF(IC)
  866.           ENDIF
  867.  9049   CONTINUE
  868. C
  869.  4049 CONTINUE
  870.  3049 CONTINUE
  871.       GO TO 510
  872.  
  873. C  __________
  874. C |          |
  875. C |   COQ2   |
  876. C |__________|
  877. C
  878.    44 CONTINUE
  879.       NBNO=NBNN
  880.       SEGINI MWRK1,MWRK2
  881. C
  882. C     Valeur de l'excentrement ne sert pas (pour l'instant ?)
  883.       EXCEN=0.D0
  884. C
  885.       NDDD=NDEP
  886.       IF (IFOUR.EQ.-3) NDDD=NDEP-3
  887.       DO 3044 IB=1,NBELEM
  888. C
  889. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  890. C
  891.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  892. C
  893. C     ON CHERCHE LES DEPLACEMENTS
  894. C
  895.          MPTVAL=IVADEP
  896.          IE=1
  897.          DO 2044 IGAU=1,NBNN
  898.             DO ICOMP=1,NDDD
  899.                MELVAL=IVAL(ICOMP)
  900.                IGMN=MIN(IGAU,VELCHE(/1))
  901.                IBMN=MIN(IB  ,VELCHE(/2))
  902.                XDDL(IE)=VELCHE(IGMN,IBMN)
  903.                IE=IE+1
  904.            ENDDO
  905.  2044    CONTINUE
  906.          IF (IFOUR.EQ.-3) THEN
  907.                XDDL(IE)=UZDPG
  908.                XDDL(IE+1)=RYDPG
  909.                XDDL(IE+2)=RXDPG
  910.          ENDIF
  911. C
  912. C     BOUCLE SUR LES POINTS DE GAUSS
  913. C
  914.             DO 4044 IGAU=1,NBPGAU
  915.                IF (IVACAR.NE.0) THEN
  916.                   MPTVAL=IVACAR
  917.                   IF (IVAL(/1).GT.1) THEN
  918.                      IF (IVAL(2).NE.0) THEN
  919.                      MELVAL=IVAL(2)
  920.                         IBMN=MIN(IB,VELCHE(/2))
  921.                         EXCEN=VELCHE(1,IBMN)
  922.                      ENDIF
  923.                   ENDIF
  924.                ENDIF
  925. C
  926. C     APPEL A BGFCQ2
  927. C
  928.       CALL BGFCQ2(BGF,NGRAF,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,
  929.      .           EXCEN,1.D0,IRR,XDPGE,YDPGE)
  930. C
  931. C     GESTION D'ERREUR
  932. C
  933.             IF (IRR.EQ.1) THEN
  934.               INTERR(1)=IB
  935.               CALL ERREUR(255)
  936.               GOTO 9990
  937.             ELSE IF(IRR.EQ.2) THEN
  938.               INTERR(1)=IB
  939.               CALL ERREUR(256)
  940.               GOTO 9990
  941.             ENDIF
  942. C
  943.             CALL BST(BGF,XDDL,LRE,NGRAF,GRADF)
  944. C
  945. C     REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS DE FLEXION
  946. C
  947.             MPTVAL=IVAGRF
  948.             DO 9044 ICOMP=1,NGRAF
  949.                MELVAL=IVAL(ICOMP)
  950.                IGMN=MIN(IGAU,VELCHE(/1))
  951.                IBMN=MIN(IB  ,VELCHE(/2))
  952.                VELCHE(IGMN,IBMN)=GRADF(ICOMP)
  953.  9044       CONTINUE
  954.  4044    CONTINUE
  955.  3044 CONTINUE
  956. C
  957.       GOTO 510
  958.  
  959.  
  960. C
  961. C       POUTRE, TUYA, TIMO
  962. C
  963.  
  964.  29   CONTINUE
  965.       NBNO=NBNN
  966.       NBBB=NBNN
  967.  
  968.       SEGINI MWRK1,MWRK3
  969.       DO 3029  IB=1,NBELEM
  970. C
  971. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  972. C
  973.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  974. C
  975. C     ON CHERCHE LES DEPLACEMENTS
  976. C
  977.       IE=0
  978.       MPTVAL=IVADEP
  979.       DO 4029 IGAU=1,NBNN
  980.        DO ICOMP=1,NDEP
  981.          IE=IE+1
  982.          MELVAL=IVAL(ICOMP)
  983.          IF (MELVAL.NE.0) THEN
  984.            IGMN=MIN(IGAU,VELCHE(/1))
  985.            IBMN=MIN(IB  ,VELCHE(/2))
  986.            XDDL(IE)=VELCHE(IGMN,IBMN)
  987.          ELSE
  988.            XDDL(IE)=0.D0
  989.          ENDIF
  990.        ENDDO
  991.  4029 CONTINUE
  992. C
  993. C  ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  994. C
  995.          CALL ZERO(WORK,NCAR,1)
  996.          DO 5029 IGAU=1,NBNN
  997.          MPTVAL=IVACAR
  998.          DO 6029 IC=1,NCAR
  999.             IF(IVAL(IC).NE.0) THEN
  1000.                MELVAL=IVAL(IC)
  1001.                IBMN=MIN(IB,VELCHE(/2))
  1002.                IGMN=MIN(IGAU,VELCHE(/1))
  1003.                IF(IGMN.GT.0.AND.IBMN.GT.0) THEN
  1004.                   WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  1005.                ELSE
  1006.                   WORK(IC)=0.
  1007.                ENDIF
  1008.             ELSE
  1009.                WORK(IC)=0.
  1010.             ENDIF
  1011.           IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  1012.  6029    CONTINUE
  1013.  5029    CONTINUE
  1014. C
  1015. C CAS OU ON A LU LE MOT VECTEUR
  1016. C
  1017.          IF (IFOUR.EQ.2) THEN
  1018. C
  1019. C
  1020.          ENDIF
  1021. C
  1022. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  1023. C                   EQUIVALENTE
  1024.          IF(MELE.EQ.42) THEN
  1025.            CISA=WORK(4)
  1026.            VX=WORK(5)
  1027.            VY=WORK(6)
  1028.            VZ=WORK(7)
  1029.            CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  1030.          ENDIF
  1031. C
  1032. C  ON CALCULE LES GRADIENTS
  1033. C
  1034.          IF(MELE.EQ.84) THEN
  1035. C
  1036.           IF(CMATE.EQ.'SECTION') THEN
  1037.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1038.               CALL TIMGF2(XE,XDDL,WORK(12),WORK(25))
  1039.             ELSE
  1040.               CALL TIMGF1(XE,XDDL,WORK(1),WORK(12),WORK(25))
  1041.             ENDIF
  1042.           ELSE
  1043. C
  1044.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1045.               CALL TIMGF2(XE,XDDL,WORK(12),WORK(25))
  1046. C
  1047.             ELSE
  1048.               CALL TIMGF1(XE,XDDL,WORK(7),WORK(12),WORK(25))
  1049.             ENDIF
  1050.           ENDIF
  1051.          ELSE
  1052. C
  1053.             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  1054.               CALL POUGF2(XE,XDDL,WORK,WORK(12),WORK(25))
  1055.             ELSE
  1056. C
  1057.               CALL POUGF1(XE,XDDL,WORK,WORK(12),WORK(25))
  1058.             ENDIF
  1059.          ENDIF
  1060.  
  1061. *  REMPLISSAGE
  1062.  
  1063.             DO iGau=1,NBPGAU
  1064.               MPTVAL=IVAGRF
  1065.               DO i=1,NGRAF
  1066.                 MELVAL=IVAL(i)
  1067.                 IGMN=MIN(iGau,VELCHE(/1))
  1068.                 IBMN=MIN(IB,VELCHE(/2))
  1069. *                IDECA=11+I+(IGAU-1)*NGRAF
  1070.                 VELCHE(IGMN,IBMN)=WORK(I)
  1071.               ENDDO
  1072.             ENDDO
  1073. 3029      CONTINUE
  1074.           GOTO 510
  1075. C
  1076. C       JOINT UNIDIMENSIONNELS JOI1
  1077. C
  1078.  265  CONTINUE
  1079.       NBNO=NBNN
  1080.       NBBB=NBNN
  1081.       SEGINI MWRK1,MWRK3,MWRK4
  1082.       DO 3265  IB=1,NBELEM
  1083. C
  1084. C     RANGEMENT DES CARACTERISTIQUES DANS WORK
  1085. C
  1086.       MPTVAL=IVAMAT
  1087.       DO IC=1,NMATT
  1088.         IF(IVAL(IC).NE.0) THEN
  1089.           MELVAL=IVAL(IC)
  1090.           IBMN=MIN(IB,VELCHE(/2))
  1091.           WORK(IC)=VELCHE(1,IBMN)
  1092.         ELSE
  1093.           WORK(IC)=0.D0
  1094.         ENDIF
  1095.       END DO
  1096. C
  1097.       CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  1098. C
  1099. C     ON CHERCHE LES DEPLACEMENTS
  1100. C
  1101.       IE=0
  1102.       MPTVAL=IVADEP
  1103.       DO 4265 IGAU=1,NBNN
  1104.         DO ICOMP=1,NDEP
  1105.          IE=IE+1
  1106.          MELVAL=IVAL(ICOMP)
  1107.          IF (MELVAL.NE.0) THEN
  1108.            IGMN=MIN(IGAU,VELCHE(/1))
  1109.            IBMN=MIN(IB  ,VELCHE(/2))
  1110.            XDDL(IE)=VELCHE(IGMN,IBMN)
  1111.          ELSE
  1112.            XDDL(IE)=0.D0
  1113.          ENDIF
  1114.         ENDDO
  1115.  4265 CONTINUE
  1116. C
  1117. C  CALCUL DES DEPLACEMENTS LOCAUX
  1118. C
  1119.       IAW1 = 101
  1120.       IAW2 = IAW1 + LRE
  1121.       CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
  1122. C
  1123. C  ON CALCULE LES GRADIENTS
  1124. C
  1125.       CALL JOIGF1(XDDL,WORK,LRE,NGRAF,IDIM)
  1126. *  REMPLISSAGE
  1127.             DO iGau=1,NBPGAU
  1128.               MPTVAL=IVAGRF
  1129.               DO i=1,NGRAF
  1130.                 MELVAL=IVAL(i)
  1131.                 IGMN=MIN(iGau,VELCHE(/1))
  1132.                 IBMN=MIN(IB,VELCHE(/2))
  1133.                 IDECA=11+I+(IGAU-1)*NGRAF
  1134.                 VELCHE(IGMN,IBMN)=WORK(IDECA)
  1135.               ENDDO
  1136.             ENDDO
  1137. 3265      CONTINUE
  1138.           GOTO 510
  1139.  
  1140. C
  1141. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  1142. C
  1143.   510 CONTINUE
  1144. *     Desactivation des segments
  1145. *
  1146.       IF (MWRK1.NE.0) SEGSUP,MWRK1
  1147.       IF (MWRK2.NE.0) SEGSUP,MWRK2
  1148.       IF (MWRK3.NE.0) SEGSUP,MWRK3
  1149.       IF (MWRK4.NE.0) SEGSUP,MWRK4
  1150.       IF (MVELCH.NE.0) SEGSUP,MVELCH
  1151. *
  1152.         CALL DTMVAL(IVADEP,1)
  1153. *
  1154.         CALL DTMVAL(IVAMAT,1)
  1155. *
  1156.         CALL DTMVAL(IVACAR,1)
  1157. *
  1158.         CALL DTMVAL(IVAGRF,1)
  1159. *
  1160.         NOMID=MODEPL
  1161.         if(lsupdp)SEGSUP NOMID
  1162.         NOMID=MOGRAF
  1163.         if(lsupgf)SEGSUP NOMID
  1164.         IF (MOMATR.NE.0) THEN
  1165.           NOMID=MOMATR
  1166.           SEGSUP NOMID
  1167.         ENDIF
  1168.         IF (MOCARA.NE.0) THEN
  1169.           NOMID=MOCARA
  1170.           SEGSUP NOMID
  1171.         ENDIF
  1172. *
  1173. *        SEGSUP INFO
  1174. *
  1175.  500  CONTINUE
  1176. *      CALL DTCHAM(IPCHE2)
  1177. *
  1178.       RETURN
  1179. *
  1180.  9990 CONTINUE
  1181. *
  1182. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  1183. *
  1184.       IRET=0
  1185. *
  1186. *     Gestion des messages d'erreur
  1187. *
  1188.       IF (IMESS.NE.0) THEN
  1189.          INTERR(1) = IB
  1190.          CALL ERREUR(IMESS)
  1191.       ENDIF
  1192. *
  1193.       IF (MWRK1.NE.0) SEGSUP,MWRK1
  1194.       IF (MWRK2.NE.0) SEGSUP,MWRK2
  1195.       IF (MWRK3.NE.0) SEGSUP,MWRK3
  1196.       IF (MWRK4.NE.0) SEGSUP,MWRK4
  1197.       IF (MVELCH.NE.0) SEGSUP,MVELCH
  1198. *
  1199.       CALL DTMVAL(IVADEP,1)
  1200. *
  1201.       CALL DTMVAL(IVAMAT,1)
  1202. *
  1203.       CALL DTMVAL(IVACAR,1)
  1204. *
  1205.       CALL DTMVAL(IVAGRF,3)
  1206. *
  1207.       IF(MODEPL.NE.0.and.lsupdp) THEN
  1208.         NOMID=MODEPL
  1209.         SEGSUP NOMID
  1210.       ENDIF
  1211. *
  1212.       IF(MOGRAF.NE.0)THEN
  1213.         NOMID=MOGRAF
  1214.         if(lsupgf)SEGSUP NOMID
  1215.       ENDIF
  1216. *
  1217.       IF (MOCARA.NE.0) THEN
  1218.         NOMID=MOCARA
  1219.         SEGSUP NOMID
  1220.       ENDIF
  1221. *
  1222.       IF (MOMATR.NE.0) THEN
  1223.         NOMID=MOMATR
  1224.         SEGSUP NOMID
  1225.       ENDIF
  1226.  
  1227.       RETURN
  1228.       END
  1229.  
  1230.  
  1231.  

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