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

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