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

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