Télécharger la plaquette Cast3M


fr en

Télécharger fofis1.eso

Retour à la liste

Numérotation des lignes : 

fofis1

  1. C FOFIS1    SOURCE    OF166741  25/02/21    21:16:29     12166          
  2.       SUBROUTINE FOFIS1(IPMODL,IPCHE1,IPCHE2,IPCHE3,
  3.      1                            IPCHE4,IPCHP1,IRET)
  4.  
  5. ************************************************************************
  6. *
  7. *  ENTREES :
  8. *  _________
  9. *
  10. *        IPMODL = POINTEUR SUR UN MMODEL
  11. *        IPCHE1 = POINTEUR SUR UN MCHAML DE CONTRAINTES
  12. *        IPCHE2 = POINTEUR SUR UN MCHAML DE GRADIENT
  13. *        IPCHE3 = POINTEUR SUR UN MCHAML DE GRADIENT DE FLEXION
  14. *        IPCHE4 = POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
  15. *
  16. *  SORTIES :
  17. * __________
  18. *
  19. *        IPCHP1 = POINTEUER SUR UN CHPOINT DE FORCES NODALES
  20. *         IRET  = 1 OU 0 SUIVANT SUCCES OU PAS
  21. *
  22. ************************************************************************
  23.       IMPLICIT INTEGER(I-N)
  24.       IMPLICIT REAL*8(A-H,O-Z)
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC CCHAMP
  29.  
  30. -INC SMCHAML
  31. -INC SMCHPOI
  32. -INC SMELEME
  33. -INC SMCOORD
  34. -INC SMMODEL
  35. -INC SMINTE
  36.  
  37. -INC TMPTVAL
  38.  
  39.       SEGMENT NOTYPE
  40.         CHARACTER*16 TYPE(NBTYPE)
  41.       ENDSEGMENT
  42. *
  43.       SEGMENT WRK1
  44.        REAL*8 XFORC(LRE), XSTRS(NSTRS), XE(3,NBBB)
  45.       ENDSEGMENT
  46. *
  47.       SEGMENT WRK2
  48.        REAL*8 SHPWRK(6,NBNO), GRAD(9)
  49.        REAL*8 GRAF(9),BPRIM(NSTRS,LRE)
  50.       ENDSEGMENT
  51. *
  52.       SEGMENT WRK3
  53.        REAL*8 WORK(LW)
  54.       ENDSEGMENT
  55. *
  56.       SEGMENT WRK4
  57.        REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE)
  58.       ENDSEGMENT
  59. *
  60.       PARAMETER ( NINF=3 )
  61.       INTEGER INFOS(NINF)
  62.       CHARACTER*(NCONCH) CONM
  63.       LOGICAL lsupfo,lsupgd,lsupgf,lsupco
  64.       INTEGER ISUP1,ISUP2,ISUP3,ISUP4
  65. *
  66.       ISUP1=0
  67.       ISUP2=0
  68.       ISUP3=0
  69.       ISUP4=0
  70.       IRET = 0
  71.       IPCHP1 = 0
  72. *
  73. *     Verification du sous-type et du lieu support du MCHAML de contrain
  74. *
  75.       MCHELM=IPCHE1
  76.       SEGACT,MCHELM
  77.       IF(TITCHE.NE.'CONTRAINTES')THEN
  78.         MOTERR(1:32)='CONTRAINTES'
  79.         CALL ERREUR(565)
  80.         RETURN
  81.       ENDIF
  82.       CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP1,IRET1)
  83.       IF (ISUP1.GT.1) RETURN
  84. *
  85. *     Verification du sous-type et du lieu support du MCHAML de gradient
  86. *
  87.       MCHELM=IPCHE2
  88.       SEGACT,MCHELM
  89.       IF(TITCHE.NE.'GRADIENT')THEN
  90.         MOTERR(1:32)='GRADIENT'
  91.         CALL ERREUR(565)
  92.         RETURN
  93.       ENDIF
  94.       CALL QUESUP (IPMODL,IPCHE2,5,0,ISUP2,IRET2)
  95.       IF (ISUP2.GT.1) RETURN
  96. *
  97. *     Verification du sous-tyoe et du lieu support du MCHAML
  98. *     de gradient de flexion
  99. *
  100.       IF (IPCHE3.NE.0) THEN
  101.        MCHELM=IPCHE3
  102.        SEGACT,MCHELM
  103.        IF(TITCHE.NE.'GRADIENT DE FLEXION')THEN
  104.          MOTERR(1:32)='GRADIENT DE FLEXION'
  105.          CALL ERREUR(565)
  106.          RETURN
  107.        ENDIF
  108.        CALL QUESUP (IPMODL,IPCHE3,5,0,ISUP3,IRET3)
  109.        IF (ISUP3.GT.1) RETURN
  110.       ENDIF
  111. *
  112. *     Verification du sous-type et du lieu support du MCHAML
  113. *      de caracteristiques
  114. *
  115.       IF (IPCHE4.NE.0) THEN
  116.          MCHELM=IPCHE4
  117.          SEGACT,MCHELM
  118.          IF(TITCHE.NE.'CARACTERISTIQUES')THEN
  119.            MOTERR(1:32)='CARACTERISTIQUES'
  120.            CALL ERREUR(565)
  121.            RETURN
  122.          ENDIF
  123.          CALL QUESUP (IPMODL,IPCHE4,5,0,ISUP4,IRET4)
  124.          IF (ISUP4.GT.1) RETURN
  125.       ENDIF
  126. C_______________________________________________________________________
  127. C
  128. C     ACTIVATION DU MODELE
  129. C_______________________________________________________________________
  130. C
  131.       MMODEL=IPMODL
  132.       SEGACT MMODEL
  133.       NSOUS=KMODEL(/1)
  134. C
  135. C     INITIALISATION DU MCHELM DE FORCES
  136. C
  137.       L1=6
  138.       N1=NSOUS
  139.       N3=6
  140.       SEGINI MCHELM
  141.       IPCHE5=MCHELM
  142.       IFOCHE=IFOUR
  143.       TITCHE='FORCES'
  144. C_______________________________________________________________________
  145. C
  146. C     BOUCLE SUR LES SOUS ZONES
  147. C_______________________________________________________________________
  148. C
  149.       DO 500 ISOUS=1,NSOUS
  150. C
  151.       IVASTR=0
  152.       NSTR=0
  153.       IVAGRA=0
  154.       NGRAD=0
  155.       IVAGRF=0
  156.       NGRAF=0
  157.       IVACAR=0
  158.       NCARR=0
  159.       IVAFOR=0
  160. C
  161. C     TRAITEMENT DU MODELE
  162. C
  163.       IMODEL=KMODEL(ISOUS)
  164.       SEGACT IMODEL
  165.       CONM=CONMOD
  166.       MELE=NEFMOD
  167.       IPMAIL=IMAMOD
  168. C
  169. C     ACTIVATION DU MELEME
  170. C
  171.       MELEME=IPMAIL
  172.       SEGACT MELEME
  173.       NBNN=NUM(/1)
  174.       NBELEM=NUM(/2)
  175. C
  176. C     RECOPIE DU MCHELM
  177. C
  178.       IMACHE(ISOUS)=IPMAIL
  179. C
  180. C     CREATION DU TABLEAU INFOS
  181. C
  182.       CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  183.       IF (IRTD.EQ.0) GOTO 991
  184. C_______________________________________________________________________
  185. C
  186. C     INFORMATIONS SUR L'{L{MENT FINI
  187. C_______________________________________________________________________
  188. C
  189. *      CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  190. *      IF (IERR.NE.0) GOTO 991
  191. *      INFO=IPINF
  192.       NBPGS= INFELE(4)
  193.       NBPGAU  = INFELE(6)
  194.  
  195. *      MINTE = INFELE(11)
  196.       MINTE=infmod(5)
  197.       IPMINT= MINTE
  198.       MINTE1= INFMOD(8)
  199.       NSTRS = INFELE(16)
  200.       MFR   = INFELE(13)
  201.       LW    = INFELE(7)
  202.       NDDL  = INFELE(15)
  203.       LRE   = INFELE(9)
  204.       IPPORE=0
  205.       IF(MFR.EQ.33) IPPORE=NBNN
  206.       LVAL  = (LRE*(LRE+1))/2
  207.       NHRM   = NIFOUR
  208. C
  209.       SEGACT MINTE
  210.       NBNO=SHPTOT(/2)
  211. C
  212. C     REMPLIR LE TABLEAU DE L'INFORMATION DE MCHAML
  213. C
  214.       INFCHE(ISOUS,1)=0
  215.       INFCHE(ISOUS,2)=0
  216.       INFCHE(ISOUS,3)=NIFOUR
  217.       INFCHE(ISOUS,4)=0
  218.       INFCHE(ISOUS,5)=0
  219.       INFCHE(ISOUS,6)=1
  220. C_______________________________________________________________________
  221. C
  222. C     NOMS DE COMPOSANTES NECESSAIRES ( FORCES )
  223. C_______________________________________________________________________
  224. C
  225.       if(lnomid(2).ne.0) then
  226.         nomid = lnomid(2)
  227.         segact nomid
  228.         moforc=nomid
  229.         nfor=lesobl(/2)
  230.         nfac=0
  231.         lsupfo=.false.
  232.       else
  233.         CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC)
  234.         lsupfo=.true.
  235.       endif
  236. C
  237. C     CREATION DU MCHAML
  238. C
  239.       N2=NFOR
  240.       SEGINI MCHAML
  241.       ICHAML(ISOUS)=MCHAML
  242.       NOMID=MOFORC
  243.       SEGACT NOMID
  244.       DO 110 ICOMP=1,NFOR
  245.         NOMCHE(ICOMP)=LESOBL(ICOMP)
  246.         TYPCHE(ICOMP)='REAL*8'
  247.  110  CONTINUE
  248.       if(lsupfo)SEGSUP NOMID
  249. C_______________________________________________________________________
  250. C
  251. C     NOMS DE COMPOSANTES NECESSAIRES(CONTRAINTES,GRADIENT,
  252. C      GRADIENT DE FLEXION )
  253. C_______________________________________________________________________
  254. C
  255.       if(lnomid(4).ne.0) then
  256.          nomid=lnomid(4)
  257.          segact nomid
  258.          mostrs=nomid
  259.          nstr=lesobl(/2)
  260.          nfac=lesfac(/2)
  261.          lsupco=.false.
  262.       else
  263.          lsupco=.true.
  264.          CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  265.       endif
  266. C
  267.       if(lnomid(3).ne.0) then
  268.          nomid=lnomid(3)
  269.          segact nomid
  270.          mograd=nomid
  271.          ngrad=lesobl(/2)
  272.          nfac=lesfac(/2)
  273.          lsupgd=.false.
  274.       else
  275.          lsupgd=.true.
  276.         CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRAD,NFAC)
  277.       endif
  278. C
  279. *      write(6,*) ' lnomid() ' ,(lnomid(iou),iou=1,12)
  280.       if(lnomid(11).ne.0) then
  281.          nomid=lnomid(11)
  282.          segact nomid
  283.          mograf=nomid
  284.          ngraf=lesobl(/2)
  285.          nfac=lesfac(/2)
  286.          lsupgf=.false.
  287.       else
  288.          lsupgf=.true.
  289.          CALL IDGRAF(MFR,IFOUR,MOGRAF,NGRAF,NFAC)
  290.       endif
  291. C
  292. C     VERIFICATION DE LEUR PRESENCE
  293. C
  294.       NBTYPE=1
  295.       SEGINI NOTYPE
  296.       MOTYPE=NOTYPE
  297.       TYPE(1)='REAL*8'
  298.       CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
  299.       NOMID=MOSTRS
  300.       if(lsupco)SEGSUP NOMID
  301.       IF (IERR.NE.0)THEN
  302.        SEGSUP NOTYPE
  303.        GOTO 510
  304.       ENDIF
  305. *
  306.       IF (ISUP1.EQ.1) THEN
  307.         CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE,MOSTRS,MELE)
  308.       ENDIF
  309. *
  310.       CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOGRAD,MOTYPE,1,INFOS,3,IVAGRA)
  311.       NOMID=MOGRAD
  312. *      write(6,*) ' lsupgd 1',lsupgd
  313.       if(lsupgd)SEGSUP NOMID
  314.       IF (IERR.NE.0)THEN
  315.        SEGSUP NOTYPE
  316.        GOTO 510
  317.       ENDIF
  318. *
  319.       IF (ISUP2.EQ.1) THEN
  320.         CALL VALCHE(IVAGRA,NGRAD,IPMINT,IPPORE,MOGRAD,MELE)
  321.       ENDIF
  322. *
  323.       IF(NGRAF.NE.0)THEN
  324.        IF(IPCHE3.NE.0)THEN
  325.         CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOGRAF,MOTYPE,1,INFOS,3,IVAGRF)
  326.         NOMID=MOGRAF
  327.         if(lsupgf)SEGSUP NOMID
  328.         IF (IERR.NE.0)THEN
  329.          SEGSUP NOTYPE
  330.          GOTO 510
  331.         ENDIF
  332. *
  333.         IF (ISUP3.EQ.1) THEN
  334.          CALL VALCHE(IVAGRF,NGRAF,IPMINT,IPPORE,MOGRAF,MELE)
  335.         ENDIF
  336.        ELSE
  337.         MOTERR(1:8)='GRAFLEXI'
  338.         MOTERR(9:12)=NOMTP(MELE)
  339.         MOTERR(13:20)='FOFISS'
  340.         CALL ERREUR(145)
  341.         GO TO 510
  342.        ENDIF
  343.       ENDIF
  344.       SEGSUP NOTYPE
  345. C_____________________________________________________________________
  346.  
  347. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES                   *
  348. C____________________________________________________________________
  349. C
  350.            NBROBL=0
  351.            NBRFAC=0
  352.            MOCARA=0
  353.            IVECT=0
  354.            NOMID=0
  355. **           write(6,*) ' mfr ifour ipche4 ngraf ipche3 '
  356. *     $  ,mfr,ifour,ipche4, ngraf, ipche3
  357. *          write(6,*) ' lsupgd 2',lsupgd
  358. *
  359. * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES
  360. *
  361.          IF((MFR.EQ.1.OR.MFR.EQ.33).AND.IFOUR.EQ.-2.
  362.      +                       AND.IPCHE4.NE.0)THEN
  363.            NBROBL=0
  364.            NBRFAC=1
  365.            SEGINI NOMID
  366.            MOCARA=NOMID
  367.            LESFAC(1)='DIM3'
  368. *
  369.            NBTYPE=1
  370.            SEGINI NOTYPE
  371.            MOTYPE=NOTYPE
  372.            TYPE(1)='REAL*8'
  373. *
  374. * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  375. *
  376.          ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  377.            NBROBL=1
  378.            IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  379.              NBRFAC=2
  380.            ELSE
  381.              NBRFAC=1
  382.            ENDIF
  383.            SEGINI NOMID
  384.            MOCARA=NOMID
  385.            LESOBL(1)='EPAI'
  386.            LESFAC(1)='EXCE'
  387.            IF(MFR.EQ.3.AND.IFOUR.EQ.-2)  LESFAC(2)='DIM3'
  388. *
  389.            NBTYPE=1
  390.            SEGINI NOTYPE
  391.            MOTYPE=NOTYPE
  392.            TYPE(1)='REAL*8'
  393. *
  394. * SECTION POUR LES BARRES
  395. *
  396.          ELSE IF (MFR.EQ.27) THEN
  397.            NBROBL=1
  398.            SEGINI NOMID
  399.            MOCARA=NOMID
  400.            LESOBL(1)='SECT'
  401. *
  402.            NBTYPE=1
  403.            SEGINI NOTYPE
  404.            MOTYPE=NOTYPE
  405.            TYPE(1)='REAL*8'
  406. *
  407. * CARACTERISTIQUES POUR LES POUTRES
  408. *
  409.          ELSE IF (MFR.EQ.7 ) THEN
  410.            NBROBL=4
  411.            NBRFAC=5
  412.            SEGINI NOMID
  413.            MOCARA=NOMID
  414.            LESOBL(1)='TORS'
  415.            LESOBL(2)='INRY'
  416.            LESOBL(3)='INRZ'
  417.            LESOBL(4)='SECT'
  418.            LESFAC(1)='SECY'
  419.            LESFAC(2)='SECZ'
  420.            LESFAC(3)='VX'
  421.            LESFAC(4)='VY'
  422.            LESFAC(5)='VZ'
  423.            IVECT=1
  424. *
  425.            NBTYPE=9
  426.            SEGINI NOTYPE
  427.            MOTYPE=NOTYPE
  428.            TYPE(1)='REAL*8'
  429.            TYPE(2)='REAL*8'
  430.            TYPE(3)='REAL*8'
  431.            TYPE(4)='REAL*8'
  432.            TYPE(5)='REAL*8'
  433.            TYPE(6)='REAL*8'
  434.            TYPE(7)='REAL*8'
  435.            TYPE(8)='REAL*8'
  436.            TYPE(9)='REAL*8'
  437. *
  438. * CARACTERISTIQUES POUR LES TUYAUX
  439. *
  440.          ELSE IF (MFR.EQ.13) THEN
  441.            NBROBL=2
  442.            NBRFAC=4
  443.            SEGINI NOMID
  444.            MOCARA=NOMID
  445.            LESOBL(1)='EPAI'
  446.            LESOBL(2)='RAYO'
  447.            LESFAC(1)='RACO'
  448.            LESFAC(2)='VX'
  449.            LESFAC(3)='VY'
  450.            LESFAC(4)='VZ'
  451.            IVECT=1
  452. *
  453.            NBTYPE=4
  454.            SEGINI NOTYPE
  455.            MOTYPE=NOTYPE
  456.            TYPE(1)='REAL*8'
  457.            TYPE(2)='REAL*8'
  458.            TYPE(3)='REAL*8'
  459.            TYPE(4)='REAL*8'
  460.            TYPE(5)='REAL*8'
  461.            TYPE(6)='REAL*8'
  462. *
  463. * CARACTERISTIQUES POUR LES LINESPRING
  464. *
  465.          ELSE IF (MFR.EQ.15) THEN
  466.            NBROBL=5
  467.            SEGINI NOMID
  468.            MOCARA=NOMID
  469.            LESOBL(1)='EPAI'
  470.            LESOBL(2)='FISS'
  471.            LESOBL(3)='VX  '
  472.            LESOBL(4)='VY  '
  473.            LESOBL(5)='VZ  '
  474. *
  475.            NBTYPE=1
  476.            SEGINI NOTYPE
  477.            MOTYPE=NOTYPE
  478.            TYPE(1)='REAL*8'
  479. *
  480. * CARACTERISTIQUES POUR LES TUYAUX FISSURES
  481. *
  482.          ELSE IF (MFR.EQ.17) THEN
  483.            NBROBL=9
  484.            SEGINI NOMID
  485.            MOCARA=NOMID
  486.            LESOBL(1)='RAYO'
  487.            LESOBL(2)='EPAI'
  488.            LESOBL(3)='VX  '
  489.            LESOBL(4)='VY  '
  490.            LESOBL(5)='VZ  '
  491.            LESOBL(6)='VXF '
  492.            LESOBL(7)='VYF '
  493.            LESOBL(8)='VZF '
  494.            LESOBL(9)='ANGL'
  495. *
  496.            NBTYPE=1
  497.            SEGINI NOTYPE
  498.            MOTYPE=NOTYPE
  499.            TYPE(1)='REAL*8'
  500. *
  501. * CARACTERISTIQUES DES ELEMENTS HOMOGENEISES
  502. *
  503.          ELSE IF (MFR.EQ.37) THEN
  504.            IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  505.              NBROBL=4
  506.              SEGINI NOMID
  507.              MOCARA=NOMID
  508.              LESOBL(1)='SCEL'
  509.              LESOBL(2)='SFLU'
  510.              LESOBL(3)='EPS '
  511.              LESOBL(4)='XINE'
  512.            ELSE
  513.              NBROBL=3
  514.              SEGINI NOMID
  515.              MOCARA=NOMID
  516.              LESOBL(1)='SCEL'
  517.              LESOBL(2)='SFLU'
  518.              LESOBL(3)='EPS '
  519.            ENDIF
  520. *
  521.            NBTYPE=1
  522.            SEGINI NOTYPE
  523.            MOTYPE=NOTYPE
  524.            TYPE(1)='REAL*8'
  525.          ENDIF
  526.  
  527. *
  528.          IF (MOCARA.NE.0)  THEN
  529.             IF (IPCHE4.NE.0)  THEN
  530. *
  531.                CALL KOMCHA(IPCHE4,IPMAIL,CONM,MOCARA,MOTYPE,1,
  532.      1                       INFOS,3,IVACAR)
  533.                SEGSUP NOTYPE
  534.                IF (IERR.NE.0) GOTO 9990
  535.             ELSE
  536.                MOTERR(1:8)='CARACTER'
  537.                MOTERR(9:12)=NOMTP(MELE)
  538.                MOTERR(13:20)='FOFISS  '
  539.                CALL ERREUR(145)
  540.                SEGSUP NOMID
  541.                NCARA=0
  542.                NCARF=0
  543.                MOCARA=0
  544.                GOTO 510
  545.             ENDIF
  546.             NCARA=NBROBL
  547.             NCARF=NBRFAC
  548.             NCARR=NCARA+NCARF
  549. *
  550.             IF (ISUP4.EQ.1) THEN
  551.                CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  552.                IF(IERR.NE.0)THEN
  553.                  SEGSUP NOMID
  554.                  ISUP4=0
  555.                  GOTO 510
  556.                ENDIF
  557.             ENDIF
  558. *                 write(6,*) ' lsupgd 3 ' , lsupgd
  559.             SEGSUP NOMID
  560. *                  write(6,*) ' lsupgd 4 ' , lsupgd , nomid
  561.          ENDIF
  562.  
  563.          NCARA=NBROBL
  564.          NCARF=NBRFAC
  565.          NCARR=NCARA+NCARF
  566. C
  567. C     RECHERCHE DES TAILLES DE MELVAL
  568. C
  569.       N1EL=NBELEM
  570.       N1PTEL=NBNN
  571.       NBPTEL=N1PTEL
  572.       NEL   =N1EL
  573. C
  574. C     CREATION DU MELVAL DE FORCES
  575. C
  576.       NSR=1
  577.       NCOSOR=NFOR
  578.       SEGINI MPTVAL
  579.       IVAFOR=MPTVAL
  580.       DO 100 ICOMP=1,NFOR
  581.         N2PTEL=0
  582.         N2EL=0
  583.         SEGINI MELVAL
  584.         IELVAL(ICOMP)=MELVAL
  585.         IVAL(ICOMP)=MELVAL
  586.  100  CONTINUE
  587. C
  588. C=======================================================================
  589. C     NUMERO DES ETIQUETTES      :
  590. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  591. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  592. C     5  CONTINUE
  593. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  594. C     44 CONTINUE
  595. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  596. C=======================================================================
  597.       GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  598.      1      99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  599.      2      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  600.      3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  601.      4      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99),MELE
  602. C
  603. C     GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  604. C    1      99,99, 4, 4, 4, 4,27,28,29,30,99,99,99,99,99,99,99,99,99,99,
  605. C    2      41,29,99,44,99,99,99,99,49,30,51,99,99,99,99,41,99,99,99,99,
  606. C    3      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  607. C    4      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99),MELE
  608. C
  609.    99 CONTINUE
  610.       MOTERR(1:4)=NOMTP(MELE)
  611.       MOTERR(5:12)='FOFISS'
  612.       CALL ERREUR(86)
  613.       GOTO 510
  614. C
  615. C     SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS
  616. C
  617.    4  CONTINUE
  618.       DIM3=1.D0
  619.       NBNO=NBNN
  620.       NBBB=NBNN
  621.       SEGINI WRK1,WRK2
  622.       I195=0
  623.       I259=0
  624.       DO 3004  IB=1,NBELEM
  625. C
  626. C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  627. C
  628.       CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  629. C
  630. C     MISE A 0 DES FORCES
  631. C
  632.       CALL ZERO(XFORC,1,LRE)
  633. C
  634. C     BOUCLE SUR LES POINTS DE GAUSS
  635. C
  636.       ISDJC=0
  637.       DO 5004  IGAU=1,NBPGAU
  638. C
  639. C   RECUPERATION DE L'EPAISSEUR
  640. C
  641.       IF (IFOUR.EQ.-2)THEN
  642.         MPTVAL=IVACAR
  643.         IF (IVACAR.NE.0) THEN
  644.          MELVAL=IVAL(1)
  645.          IF (MELVAL.NE.0) THEN
  646.           IGMN=MIN(IGAU,VELCHE(/1))
  647.           IBMN=MIN(IB,VELCHE(/2))
  648.           DIM3=VELCHE(IGMN,IBMN)
  649.          ELSE
  650.           DIM3=1.D0
  651.          ENDIF
  652.         ENDIF
  653.       ENDIF
  654. C
  655. C *****************
  656. C     ON CHERCHE LES GRADIENTS
  657.  
  658.       MPTVAL=IVAGRA
  659.        DO 1104 ICOMP=1,9
  660.  
  661.                MELVAL=IVAL(ICOMP)
  662.                IBMN=MIN(IB,VELCHE(/2))
  663.                IGMN=MIN(IGAU,VELCHE(/1))
  664.                GRAD(ICOMP)=VELCHE(IGMN,IBMN)
  665.  1104 CONTINUE
  666. C *****************
  667.       CALL BPRIMA(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,
  668.      1                       DIM3,XE,SHPTOT,SHPWRK,GRAD,BPRIM,DJAC)
  669.       IF(DJAC.LT.0.) ISDJC=ISDJC+1
  670.       IF(DJAC.EQ.0.) THEN
  671.         INTERR(1) = IB
  672.         CALL ERREUR(259)
  673.         GOTO 9904
  674.       ENDIF
  675.       DJAC=ABS(DJAC)*POIGAU(IGAU)
  676. C
  677. C     ON CHERCHE LES CONTRAINTES
  678. C
  679.         MPTVAL=IVASTR
  680.         DO 6004 ICOMP=1,NSTR
  681.                MELVAL=IVAL(ICOMP)
  682.                IBMN=MIN(IB,VELCHE(/2))
  683.                IGMN=MIN(IGAU,VELCHE(/1))
  684.                XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  685.  6004 CONTINUE
  686. C
  687. C     CALCUL DE  BPRIM*SIGMA
  688. C
  689.       CALL BSIG(BPRIM,XSTRS,NSTRS,LRE,DJAC,XFORC)
  690.  5004 CONTINUE
  691.       IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  692.         INTERR(1) = IB
  693.         CALL ERREUR(195)
  694.         GOTO 9904
  695.       ENDIF
  696. C
  697. C     ON RANGE XFORC DANS MELVAL
  698. C
  699.       IE=0
  700.       MPTVAL=IVAFOR
  701.       DO      IGAU=1,NBNN
  702.       DO      ICOMP=1,NFOR
  703.         IE=IE+1
  704.         MELVAL=IVAL(ICOMP)
  705.         IBMN=MIN(IB  ,VELCHE(/2))
  706.         VELCHE(IGAU,IBMN)=XFORC(IE)
  707.       enddo    
  708.       enddo    
  709.  3004 CONTINUE
  710.  
  711.  9904 CONTINUE
  712.       SEGSUP WRK1,WRK2
  713.       GOTO 510
  714. C ------------------------------------------------------------------
  715. C     ELEMENT COQ3 (NON)        | | | | | | | | | | | | | | | | | | |
  716. C
  717. *********************************************************************
  718. *     ATTENTION  LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  719. *      CHAMELEMS COMME POUR LES ELEMENTS  MASSIF
  720. *********************************************************************
  721. *  27  CONTINUE
  722. *      NBBB=NBNN
  723. *      LW=151
  724. *      SEGINI WRK1,WRK3
  725. *      DO 3027  IB=1,NBELEM
  726. *      IBMN1=MIN(IB,NEL1)
  727. *      IBMN4=MIN(IB,NEL4)
  728. *C
  729. *C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  730. *C
  731. *      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  732. *C
  733. *C     ON REACTUALISE LA GEOMETRIE
  734. *C
  735. *      IF(IRT4.EQ.0) GOTO 8027
  736. *      DO 4027 IC=1,3
  737. *      DO 4027 ID=1,3
  738. *      XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  739. * 4027 CONTINUE
  740. * 8027 CONTINUE
  741. *C
  742. *C     MISE A ZERO DES FORCES INTERNES
  743. *C
  744. *      CALL ZERO(XFORC,1,LRE)
  745. *C
  746. *C     ON CHERCHE LES EPAISSEURS ET ON MOYENNE
  747. *
  748. *     EPAIST=XZER
  749. *     DO 5027 IC=1,NBPTE4
  750. *     EPAIST=EPAIST+MELVA4.VELCHA(IC,1,IBMN4)
  751. *5027 CONTINUE
  752. *     EPAIST=EPAIST/NBPTE4
  753. * ****************
  754. *     ON CHERCHE LES GRADIENTS ET GRAFLEXIS
  755. *
  756. *     DO 1127 IC=1,9
  757. *     GRAD(IC)=MELVA2.VELCHA(1,IC,IBMN1)
  758. *1127 CONTINUE
  759. *     IF (IRT5.EQ.0) GO TO  1327
  760. *     DO 1227 IC=1,9
  761. *     GRAF(IC)=MELVA5.VELCHA(1,IC,IBMN1)
  762. *1227 CONTINUE
  763. *1327 CONTINUE
  764. * ****************
  765. *     ON CHERCHE LES CONTRAINTES
  766. *
  767. *     DO 7027 IC=1,NCOEL1
  768. *      XSTRS(IC)=MELVA1.VELCHA(1,IC,IBMN1)
  769. * 7027 CONTINUE
  770. *C
  771. *C     ON CALCULE B*SIGMA
  772. *C
  773. *      CALL BSIGCO(EPAIST,XE,XSTRS,XFORC,WORK,WORK,WORK(82),WORK(88),
  774. *     * WORK(92),WORK(119),WORK(128),WORK(134),WORK(143),WORK(143),
  775. *     * WORK(146),WORK(149))
  776. *C
  777. *C    RANGEMENT DANS MELVAL
  778. *C
  779. *      IE=0
  780. *      DO 9027 IC=1,NBNN
  781. *      DO 9027 ID=1,6
  782. *      IE=IE+1
  783. *      VELCHA(IC,ID,IB)=XFORC(IE)
  784. * 9027 CONTINUE
  785. * 3027 CONTINUE
  786. *      SEGSUP WRK1,WRK3
  787. *      GOTO 510
  788. *C
  789. *C     ELEMENT DKT (NON)
  790. *C
  791. *********************************************************************
  792. *     ATTENTION  LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  793. *      CHAMELEMS COMME POUR LES ELEMENTS  MASSIF
  794. *********************************************************************
  795. *  28  CONTINUE
  796. *      NBNO=NBNN
  797. *      NBBB=NBNN
  798. *      SEGINI WRK1,WRK2,WRK3,WRK4
  799. *      DO 3028  IB=1,NBELEM
  800. *      IBMN1=MIN(IB,NEL1)
  801. *      IBMN4=MIN(IB,NEL4)
  802. *C
  803. *C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  804. *C
  805. *      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  806. *C
  807. *C     ON REACTUALISE LA GEOMETRIE
  808. *C
  809. *      IF(IRT4.EQ.0) GOTO 8028
  810. *      DO 4028 IC=1,NBPTE3
  811. *      DO 4028 ID=1,3
  812. *      XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  813. * 4028 CONTINUE
  814. * 8028 CONTINUE
  815. *C
  816. *C     MISE A ZERO DES FORCES INTERNES
  817. *C
  818. *      CALL ZERO(XFORC,1,LRE)
  819. *C
  820. *      CALL VPAST(XE,BPSS)
  821. *C     BPSS    STOCKE LA MATRICE DE PASSAGE
  822. *      CALL VCORLC (XE,XEL,BPSS)
  823. *      CALL TRPOSE(BPSS)
  824. *C
  825. *C     ON CHERCHE LES EPAISSEURS ET ON MOYENNE
  826. *C
  827. *      EPAIST=XZER
  828. *      DO 5028 IC=1,NBPTE4
  829. *      EPAIST=EPAIST+MELVA4.VELCHA(IC,1,IBMN4)
  830. * 5028 CONTINUE
  831. *      EPAIST=EPAIST/NBPTE4
  832. *C
  833. *C     BOUCLE SUR LES POINTS DE GAUSS
  834. *C
  835. *      DO 6028  IGAU=1,NBPGAU
  836.  
  837. *      IGMN1=MIN(IGAU,NBPTE1)
  838. *C *******************
  839. *C     ON CHERCHE LES GRADIENTS ET GRAFLEXIS
  840. *C
  841. *      DO 1028 IC=1,9
  842. *      GRAD(IC)=MELVA2.VELCHA(IGMN1,IC,IBMN1)
  843. * 1028 CONTINUE
  844. *      IF (IRT5.EQ.0) GO TO  1328
  845. *      DO 1228 IC=1,9
  846. *      GRAF(IC)=MELVA5.VELCHA(IGMN1,IC,IBMN1)
  847. * 1228 CONTINUE
  848. * 1328 CONTINUE
  849. *C *******************
  850. *      CALL BPRIMA(IGAU,MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0,
  851. *     1                      XEL,SHPTOT,SHPWRK,GRAD,BPRIM,DJAC)
  852. *      DJAC=DJAC*POIGAU(IGAU)
  853. *C
  854. *C     ON CHERCHE LES CONTRAINTES
  855. *C
  856. *      DO 7028 IC=1,NCOEL1
  857. *      XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1)
  858. * 7028 CONTINUE
  859. *C
  860. *C     ON CALCULE  BPRIM*SIGMA
  861. *C
  862. *      CALL BSIG(BPRIM,XSTRS,NSTRS,LRE,DJAC,XFORC)
  863. * 6028 CONTINUE
  864. *C
  865. *C     TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  866. *C
  867. *      EPA=EPAIST*EPAIST/6.
  868. *      DO 1128 IC=1,3
  869. *      IE=(IC-1)*6
  870. *      XFORC(IE+1)=EPAIST*XFORC(IE+1)
  871. *      XFORC(IE+2)=EPAIST*XFORC(IE+2)
  872. *      XFORC(IE+3)=   EPA*XFORC(IE+3)
  873. *      XFORC(IE+4)=   EPA*XFORC(IE+4)
  874. *      XFORC(IE+5)=   EPA*XFORC(IE+5)
  875. * 1128 CONTINUE
  876. *      CALL MATVEC(XFORC,XFOLO,BPSS,6)
  877. *      IE=0
  878. *      DO 9028 IC=1,NBNN
  879. *      DO 9028 ID=1,6
  880. *      IE=IE+1
  881. *      VELCHA(IC,ID,IB)=XFOLO(IE)
  882. * 9028 CONTINUE
  883. * 3028 CONTINUE
  884. *      SEGSUP WRK1,WRK2,WRK3,WRK4
  885. *      GOTO 510
  886. *C
  887. *C  ELEMENT POUTRE  (NON)
  888. *C
  889. *********************************************************************
  890. *     ATTENTION  LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  891. *      CHAMELEMS COMME POUR LES ELEMENTS  MASSIF
  892. *********************************************************************
  893. * 29   CONTINUE
  894. *      NBBB=NBNN
  895. *      SEGINI WRK1,WRK3
  896. *      DO 3029 IB=1,NBELEM
  897. *      IBMN1=MIN(IB,NEL1)
  898. *      IBMN4=MIN(IB,NEL4)
  899. *C
  900. *C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
  901. *C
  902. *      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  903. *C
  904. *C  ON REACTUALISE LA GEOMETRIE
  905. *C
  906. *      IF(IRT4.EQ.0) GO TO 8029
  907. *      DO 4029 IC=1,NBPTE3
  908. *      DO 4029 ID=1,IDIM
  909. *      XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  910. *4029  CONTINUE
  911. *C
  912. *C  IL FAUDRAIT AUSSI MODIFIER LE VECTEUR LOCAL DE LA POUTRE
  913. *C
  914. *8029  CONTINUE
  915. *C
  916. *C  MISE A ZERO DES FORCES INTERNES
  917. *C
  918. *      CALL ZERO(XFORC,1,LRE)
  919. *C
  920. *C  ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  921. *C
  922. *      DO 6029 IC=1,ICARA
  923. *      WORK(IC)=MELVA4.VELCHA(1,IC,IBMN4)
  924. *6029  CONTINUE
  925. *C
  926. *C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  927. *C                   EQUIVALENTE (NON)
  928. *C
  929. *      IF(MELE.EQ.42) CALL TUYCAR(WORK,KERRE,0)
  930. *C
  931. *C  ON CHERCHE LES CONTRAINTES - ON LES MET DANS WORK
  932. *C
  933. *      IE=9
  934. *      DO 7029 ID=1,NBPTE1
  935. *      DO 7029 IC=1,NCOEL1
  936. *      IE=IE+1
  937. *      WORK(IE)=MELVA1.VELCHA(ID,IC,IBMN1)
  938. *7029  CONTINUE
  939. *C
  940. *C  ON CALCULE LES FORCES INTERNES
  941. *C
  942. *      CALL POUBSG(XFORC,WORK,XE,WORK(10),WORK(22),KERRE)
  943. *      IF(KERRE.EQ.0) GO TO 5029
  944. *      INTERR(1)=IA
  945. *      INTERR(2)=IB
  946. *      SEGSUP WRK1,WRK3
  947. *      CALL ERREUR(128)
  948. *      GO TO 9990
  949.  
  950. *5029  CONTINUE
  951. *C
  952. *C  RANGEMENT DANS MELVAL
  953. *C
  954. *      IE=0
  955. *      DO 9029 ID=1,NBPTEL
  956. *      DO 9029 IC=1,NCOELE
  957. *      IE=IE+1
  958. *      VELCHA(ID,IC,IB)=XFORC(IE)
  959. *9029  CONTINUE
  960. *029  CONTINUE
  961. *     SEGSUP WRK1,WRK3
  962. *     GO TO 510
  963. *
  964. *     ELEMENTS LISP ET LISM (NON)
  965. *********************************************************************
  966. *     ATTENTION  LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  967. *      CHAMELEMS COMME POUR LES ELEMENTS  MASSIF
  968. *********************************************************************
  969. *
  970. *  30  CONTINUE
  971. *      NBBB=NBNN
  972. *      SEGINI WRK1,WRK3,WRK4
  973. *      DO 3030  IB=1,NBELEM
  974. *      IBMN1=MIN(IB,NEL1)
  975. *      IBMN4=MIN(IB,NEL4)
  976. *C
  977. *C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  978. *C
  979. *      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  980. *C
  981. *C     ON REACTUALISE LA GEOMETRIE
  982. *C
  983. *      IF(IRT4.EQ.1) THEN
  984. *      DO 4030 IC=1,3
  985. *      DO 4030 ID=1,3
  986. *      XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  987. * 4030 CONTINUE
  988. *      ENDIF
  989. *C
  990. *C     MISE A ZERO DES FORCES INTERNES
  991. *C
  992. *      CALL ZERO(XFORC,1,LRE)
  993. *C
  994. *C     ON CHERCHE LES CONTRAINTES
  995. *C
  996. *      IE=0
  997. *      DO 7030 IC=1,NBPGAU
  998. *      ICMN1=MIN(IC,NBPTE1)
  999. *      DO 7030 ID=1,NCOEL1
  1000. *      IE=IE+1
  1001. *      WORK(IE)=MELVA1.VELCHA(ICMN1,ID,IBMN1)
  1002. * 7030 CONTINUE
  1003. *C
  1004. *C     ON CHERCHE LES CARACTERISTIQUES
  1005. *C
  1006. *      DO 6030 IC=1,NBPGAU
  1007. *      ICMN4=MIN(IC,NBPTE4)
  1008. *      DO 6030 ID=1,NCOEL4
  1009. *      IE=IE+1
  1010. *      WORK(IE)=MELVA4.VELCHA(ICMN4,ID,IBMN4)
  1011. * 6030 CONTINUE
  1012. *C
  1013. *C     ON CALCULE B*SIGMA
  1014. *C
  1015. *      ICNT=NBPGAU*NSTRS+1
  1016. *      CALL LISPBS(WORK(1),WORK(ICNT),POIGAU,SHPTOT,
  1017. *     1    NBPGAU,NBNO,XE,XFOLO,BPSS,XFORC)
  1018. *C
  1019. *C    RANGEMENT DANS MELVAL
  1020. *C
  1021. *      IE=0
  1022. *      DO 9030 IC=1,NBNN
  1023. *      DO 9030 ID=1,6
  1024. *      IE=IE+1
  1025. *      VELCHA(IC,ID,IB)=XFORC(IE)
  1026. * 9030 CONTINUE
  1027. * 3030 CONTINUE
  1028. *      SEGSUP WRK1,WRK3,WRK4
  1029. *      GOTO 510
  1030. *C
  1031. *C     ELEMENT COQ8  COQ6 (NON)
  1032. *C
  1033. *********************************************************************
  1034. *     ATTENTION  LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  1035. *      CHAMELEMS COMME POUR LES ELEMENTS  MASSIF
  1036. *********************************************************************
  1037. *  41  CONTINUE
  1038. *      NBBB=NBNN
  1039. *      SEGINI WRK1,WRK3
  1040. *      SEGACT MINTE1
  1041. *      NBPGA1=MINTE1.SHPTOT(/3)
  1042. *      NBN1  =MINTE1.SHPTOT(/2)
  1043. *C
  1044. *C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1045. *C
  1046. *      I240=0
  1047. *      I241=0
  1048. *      DO 3041  IB=1,NBELEM
  1049. *      IBMN1=MIN(IB,NEL1)
  1050. *      IBMN4=MIN(IB,NEL4)
  1051. *C
  1052. *C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1053. *C
  1054. *      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1055. *C
  1056. *C     ON REACTUALISE LA GEOMETRIE
  1057. *C
  1058. *      IF(IRT4.EQ.1) THEN
  1059. *      DO 4041 IC=1,3
  1060. *      DO 4041 ID=1,3
  1061. *      XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  1062. * 4041 CONTINUE
  1063. *      ENDIF
  1064. *C
  1065. *C     MISE A ZERO DES FORCES INTERNES
  1066. *C
  1067. *      CALL ZERO(XFORC,1,LRE)
  1068. *C
  1069. *C     ON CHERCHE LES EPAISSEURS ET ON MOYENNE
  1070. *C
  1071. *      EPAIST=XZER
  1072. *      DO 5041 IC=1,NBPTE4
  1073. *      EPAIST=EPAIST+MELVA4.VELCHA(IC,1,IBMN4)
  1074. * 5041 CONTINUE
  1075. *      EPAIST=EPAIST/DBLE(NBPTE4)
  1076. *      CALL ZERO(XFORC,1,LRE)
  1077. *C
  1078. *C     ON CHERCHE LES CONTRAINTES
  1079. *C
  1080. *      IE=1
  1081. *      DO 7041 IC=1,NBPGAU
  1082. *      DO 7041 ID=1,NSTRS
  1083. *      WORK(IE)=MELVA1.VELCHA(IC,ID,IBMN1)
  1084. *      IE=IE+1
  1085. * 7041 CONTINUE
  1086. *C
  1087. *C     ON CALCULE B*SIGMA
  1088. *C
  1089. *      CALL COQ8BS(XE,NBNN,NBPGAU,LRE,NSTRS,EPAIST,DZEGAU,POIGAU,
  1090. *     * SHPTOT,MINTE1.SHPTOT,WORK(1),XFORC,IRRT)
  1091. *      IF(IRRT.EQ.0)  I241=IB
  1092. *      IF(IRRT.EQ.-1) I240=IB
  1093. *C
  1094. *C    RANGEMENT DANS MELVAL
  1095. *C
  1096. *      IE=0
  1097. *      DO 9041 IC=1,NBNN
  1098. *      DO 9041 ID=1,6
  1099. *      IE=IE+1
  1100. *      VELCHA(IC,ID,IB)=XFORC(IE)
  1101. * 9041 CONTINUE
  1102. * 3041 CONTINUE
  1103. *      SEGSUP WRK1,WRK3
  1104. *      IF(I241.NE.0) INTERR(1)=I241
  1105. *      IF(I241.NE.0) CALL ERREUR(241)
  1106. *      IF(I240.NE.0) INTERR(1)=I240
  1107. *      IF(I240.NE.0) CALL ERREUR(240)
  1108. *      IF(I241.NE.0.OR.I240.NE.0)GO TO 9990
  1109. *      GOTO 510
  1110. *C
  1111. *C  ELEMENT COQ2 (NON)
  1112. *C
  1113. *********************************************************************
  1114. *     ATTENTION  LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  1115. *      CHAMELEMS COMME POUR LES ELEMENTS  MASSIF
  1116. *********************************************************************
  1117. *   44 CONTINUE
  1118. *      DIM3=1.D0
  1119. *      NBNO=NBNN
  1120. *      NBBB=NBNN
  1121. *      SEGINI WRK1,WRK2
  1122. *      I255=0
  1123. *      I256=0
  1124. *      DO 3044 IB=1,NBELEM
  1125. *      IBMN1=MIN(IB,NEL1)
  1126. *      IBMN4=MIN(IB,NEL4)
  1127. *C
  1128. *C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1129. *C
  1130. *      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1131. *C
  1132. *C  ON REACTUALISE LA GEOMETRIE
  1133. *C
  1134. *      IF(IRT4.EQ.1) THEN
  1135. *      DO 4044 IC=1,NBPTE3
  1136. *      DO 4044 ID=1,IDIM
  1137. *      XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  1138. * 4044 CONTINUE
  1139. *      ENDIF
  1140. *C
  1141. *C  MISE A ZERO DES FORCES INTERNES
  1142. *C
  1143. *      CALL ZERO(XFORC,1,LRE)
  1144. *C
  1145. *C  ON CHERCHE L EPAISSEUR DE L ELEMENT IB
  1146. *C
  1147. *      EPAIST=MELVA4.VELCHA(1,1,IBMN4)
  1148. *      EPA=EPAIST*EPAIST/6.D0
  1149. *
  1150. *C
  1151. *C  BOUCLE SUR LES POINTS DE GAUSS
  1152. *C
  1153. *      DO 6044 IGAU=1,NBPGAU
  1154. *      IGMN1=MIN(IGAU,NBPTE1)
  1155. *      MPTVAL=IVACAR
  1156. *      MELVAL=IVAL(2)
  1157. *      IF (MELVAL.NE.0) THEN
  1158. *         IGMN=MIN(IGAU  ,VELCHE(/1))
  1159. *         IBMN=MIN(IB  ,VELCHE(/2))
  1160. *         EXCEN =VELCHE(IGMN,IBMN)
  1161. *      ELSE
  1162. *         EXCEN=0.D0
  1163. *      ENDIF
  1164. *      IF(IFOUR.EQ.-2) THEN
  1165. *         MELVAL=IVAL(3)
  1166. *         IF (MELVAL.NE.0) THEN
  1167. *          IGMN=MIN(IGAU  ,VELCHE(/1))
  1168. *          IBMN=MIN(IB  ,VELCHE(/2))
  1169. *          DIM3=VELCHE(IGMN,IBMN)
  1170. *         ELSE
  1171. *          DIM3=1.D0
  1172. *         ENDIF
  1173. *      ENDIF
  1174. *      CALL BCOQ2(BGENE,NSTRS,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,
  1175. *    .             EXCEN,DIM3,IRRT,XDPGE,YDPGE)
  1176. *      IF(IRRT.EQ.1)  I255=IB
  1177. *      IF(IRRT.EQ.2)  I256=IB
  1178. *C
  1179. *C  ON CHERCHE LES CONTRAINTES - ON LES MET DANS XSTRS
  1180. *C
  1181. *      DO 7044 IC=1,NCOEL1
  1182. *      XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1)
  1183. * 7044 CONTINUE
  1184. *      NCO1 = NCOEL1/2
  1185. *      DO 8044 IC=1,NCO1
  1186. *      XSTRS(IC     )=XSTRS(IC     )*EPAIST
  1187. *      XSTRS(IC+NCO1)=XSTRS(IC+NCO1)*EPA
  1188. * 8044 CONTINUE
  1189. *C
  1190. *C  ON CALCULE B*SIGMA
  1191. *C
  1192. *      CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1193. * 6044 CONTINUE
  1194. *C
  1195. *C  TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1196. *C
  1197. *      IF(IFOUR.GT.0) THEN
  1198. *      DO 9044 IC=1,2
  1199. *      IE=(IC-1)*4
  1200. *      VELCHA(IC,1,IB)=  XFORC(IE+1)
  1201. *      VELCHA(IC,2,IB)=  XFORC(IE+2)
  1202. *      VELCHA(IC,3,IB)=  XFORC(IE+3)
  1203. *      VELCHA(IC,4,IB)=  XFORC(IE+4)
  1204. * 9044 CONTINUE
  1205. *      ELSE IF(IFOUR.LE.0) THEN
  1206. *      DO 9944 IC=1,2
  1207. *      IE=(IC-1)*3
  1208. *      VELCHA(IC,1,IB)=  XFORC(IE+1)
  1209. *      VELCHA(IC,2,IB)=  XFORC(IE+2)
  1210. *      VELCHA(IC,3,IB)=  XFORC(IE+3)
  1211. * 9944 CONTINUE
  1212. *      ENDIF
  1213. * 3044 CONTINUE
  1214. *      SEGSUP WRK1,WRK2
  1215. *      IF(I255.NE.0) THEN
  1216. *         INTERR(1)=I255
  1217. *         CALL ERREUR(255)
  1218. *      ENDIF
  1219. *      IF(I256.NE.0) THEN
  1220. *         INTERR(1)=I256
  1221. *         CALL ERREUR(256)
  1222. *      ENDIF
  1223. *     IF(I255.NE.0.OR.I256.NE.0)GO TO 9990
  1224. *     GOTO 510
  1225. *C
  1226. *C  ELEMENT COQ4 (NON)
  1227. *C
  1228. *********************************************************************
  1229. *     ATTENTION  LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  1230. *      CHAMELEMS COMME POUR LES ELEMENTS  MASSIF
  1231. *********************************************************************
  1232. *   49 CONTINUE
  1233. *      IG1=0
  1234. *      NBNO=NBNN
  1235. *      NBBB=NBNN
  1236. *      SEGINI WRK1,WRK2,WRK4
  1237. *      DO 3049 IB=1,NBELEM
  1238. *      IBMN1=MIN(IB,NEL1)
  1239. *      IBMN4=MIN(IB,NEL4)
  1240. *C
  1241. *C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1242. *C
  1243. *      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1244. *C
  1245. *C  ON REACTUALISE LA GEOMETRIE
  1246. *C
  1247. *      IF(IRT4.EQ.1) THEN
  1248. *      DO 4049 IC=1,NBPTE3
  1249. *      DO 4049 ID=1,IDIM
  1250. *      XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  1251. * 4049 CONTINUE
  1252. *      ENDIF
  1253. *C
  1254. *C  MISE A ZERO DES FORCES INTERNES
  1255. *C
  1256. *      CALL ZERO(XFORC,1,LRE)
  1257. *C
  1258. *C     RIFERIMENTO LOCALE
  1259. *C
  1260. *      CALL CQ4LOC(XE,XEL,BPSS,IERT,0)
  1261. *      CALL TRPOSE(BPSS)
  1262. *C
  1263. *C  ON CHERCHE L EPAISSEUR DE L ELEMENT IB
  1264. *C
  1265. *      EPAIST=MELVA4.VELCHA(1,1,IBMN4)
  1266. *C
  1267. *C  BOUCLE SUR LES POINTS DE GAUSS
  1268. *C
  1269. *      DO 6049 IGAU=1,NBPGAU
  1270. *      IGMN1=MIN(IGAU,NBPTE1)
  1271. *      CALL BCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT,0)
  1272. *      IF (IERT.NE.0) IG1=IB
  1273. *C
  1274. *C  ON CHERCHE LES CONTRAINTES - ON LES MET DANS WORK
  1275. *C
  1276. *      DO 7049 IC=1,NCOEL1
  1277. *      XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1)
  1278. * 7049 CONTINUE
  1279. *C
  1280. *C  ON CALCULE B*SIGMA
  1281. *C
  1282. *      DJAC=DJAC*POIGAU(IGAU)
  1283. *      CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1284. * 6049 CONTINUE
  1285. *C
  1286. *C  TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1287. *C
  1288. *      EPA=EPAIST*EPAIST/6.D0
  1289. *      DO 8049 IC=1,4
  1290. *      IE=(IC-1)*6
  1291. *      XFORC(IE+1)=EPAIST*XFORC(IE+1)
  1292. *      XFORC(IE+2)=EPAIST*XFORC(IE+2)
  1293. *      XFORC(IE+3)=EPAIST*XFORC(IE+3)
  1294. *      XFORC(IE+4)=   EPA*XFORC(IE+4)
  1295. *      XFORC(IE+5)=   EPA*XFORC(IE+5)
  1296. *      XFORC(IE+6)=   EPA*XFORC(IE+6)
  1297. * 8049 CONTINUE
  1298. *      CALL MATVEC(XFORC,XFOLO,BPSS,8)
  1299. *      IE=0
  1300. *      DO 9049 IC=1,4
  1301. *      DO 9049 ID=1,6
  1302. *      IE=IE+1
  1303. *      VELCHA(IC,ID,IB)=XFOLO(IE)
  1304. * 9049 CONTINUE
  1305. * 3049 CONTINUE
  1306. *      SEGSUP WRK1,WRK2,WRK4
  1307. *      IF(IG1.NE.0) THEN
  1308. *      INTERR(1)=IG1
  1309. *      CALL ERREUR (321)
  1310. *      GO TO 9990
  1311. *      ENDIF
  1312. *      GOTO 510
  1313. *C
  1314. *C  ELEMENT COF3 (NON)
  1315. *C
  1316. *********************************************************************
  1317. *     ATTENTION  LORS DU BRANCHEMENT IL FAUT PASSER AUX NOUVEAUX
  1318. *      CHAMELEMS COMME POUR LES ELEMENTS  MASSIF
  1319. *********************************************************************
  1320. *   51 CONTINUE
  1321. *      NBNO=NBNN
  1322. *      NBBB=NBNN
  1323. *      SEGINI WRK1,WRK2
  1324. *      DO 3051 IB=1,NBELEM
  1325. *      IBMN1=MIN(IB,NEL1)
  1326. *      IBMN4=MIN(IB,NEL4)
  1327. *C
  1328. *C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1329. *C
  1330. *      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1331. *C
  1332. *C  ON REACTUALISE LA GEOMETRIE
  1333. *C
  1334. *      IF(IRT4.EQ.1) THEN
  1335. *      DO 4051 IC=1,NBPTE3
  1336. *      DO 4051 ID=1,IDIM
  1337. *      XE(ID,IC)=XE(ID,IC)+MELVA3.VELCHA(IC,ID,IB)
  1338. * 4051 CONTINUE
  1339. *      ENDIF
  1340. *C
  1341. *C  MISE A ZERO DES FORCES INTERNES
  1342. *C
  1343. *      CALL ZERO(XFORC,1,LRE)
  1344. *C
  1345. *C  ON CHERCHE L EPAISSEUR DE L ELEMENT IB
  1346. *C
  1347. *      EPAIST=MELVA4.VELCHA(1,1,IBMN4)
  1348. *C
  1349. *C  BOUCLE SUR LES POINTS DE GAUSS
  1350. *C
  1351. *      DO 6051 IGAU=1,NBPGAU
  1352. *      IGMN1=MIN(IGAU,NBPTE1)
  1353. *      CALL BCOF3(BGENE,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,IRRT)
  1354. *C
  1355. *C  ON CHERCHE LES CONTRAINTES - ON LES MET DANS WORK
  1356. *C
  1357. *      DO 7051 IC=1,NCOEL1
  1358. *      XSTRS(IC)=MELVA1.VELCHA(IGMN1,IC,IBMN1)
  1359. * 7051 CONTINUE
  1360. *C
  1361. *C  ON CALCULE B*SIGMA
  1362. *C
  1363. *      CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1364. * 6051 CONTINUE
  1365. *C
  1366. *C  TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1367. *C
  1368. *      EPA=EPAIST*EPAIST/6.D0
  1369. *      DO 9051 IC=1,2
  1370. *      IE=(IC-1)*4
  1371. *      VELCHA(IC,1,IB)=EPAIST*XFORC(IE+1)
  1372. *      VELCHA(IC,2,IB)=EPAIST*XFORC(IE+2)
  1373. *      VELCHA(IC,3,IB)=EPAIST*XFORC(IE+3)
  1374. *      VELCHA(IC,4,IB)=   EPA*XFORC(IE+4)
  1375. * 9051 CONTINUE
  1376. * 3051 CONTINUE
  1377. *      SEGSUP WRK1,WRK2
  1378. *      GOTO 510
  1379. C                                    | | | | | | | | | | | | | |
  1380. C ---------------------------------------------------------------
  1381. C_______________________________________________________________________
  1382. C
  1383. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  1384. C_______________________________________________________________________
  1385. C
  1386.   510 CONTINUE
  1387. C
  1388.       IF (ISUP1.EQ.1) THEN
  1389.         CALL DTMVAL(IVASTR,3)
  1390.       ELSE
  1391.         CALL DTMVAL(IVASTR,1)
  1392.       ENDIF
  1393. *
  1394.       IF (ISUP2.EQ.1) THEN
  1395.         CALL DTMVAL(IVAGRA,3)
  1396.       ELSE
  1397.         CALL DTMVAL(IVAGRA,1)
  1398.       ENDIF
  1399. *
  1400.       IF (ISUP3.EQ.1) THEN
  1401.         CALL DTMVAL(IVAGRF,3)
  1402.       ELSE
  1403.         CALL DTMVAL(IVAGRF,1)
  1404.       ENDIF
  1405. *
  1406.       IF (ISUP4.EQ.1) THEN
  1407.         CALL DTMVAL(IVACAR,3)
  1408.       ELSE
  1409.         CALL DTMVAL(IVACAR,1)
  1410.       ENDIF
  1411. *
  1412.       IF (IERR.NE.0) THEN
  1413.         CALL DTMVAL(IVAFOR,3)
  1414.         SEGSUP MCHAML
  1415.       ELSE
  1416.         CALL DTMVAL(IVAFOR,1)
  1417.       ENDIF
  1418.  
  1419.  991  CONTINUE
  1420. *
  1421.       IF (IERR.NE.0) GOTO 9990
  1422. *
  1423.   500 CONTINUE
  1424. C_______________________________________________________________________
  1425. C
  1426. C     TRANSFORMATION DU CHAMELEM EN CHPOINT
  1427. C_______________________________________________________________________
  1428. C
  1429.       IRET = 1
  1430.       CALL CHAMPO(IPCHE5,0,IPCHP1,IRET)
  1431. C      ATTRIBUTION D'UNE NATURE DISCRETE
  1432.       CALL DTCHAM(IPCHE5)
  1433.       IF (IRET.EQ.1) THEN
  1434.         MCHPOI = IPCHP1
  1435.         SEGACT MCHPOI
  1436.         NAT = MAX ( JATTRI(/1) , 1 )
  1437.         NSOUPO = IPCHP(/1)
  1438.         SEGADJ MCHPOI
  1439.         JATTRI(1) = 2
  1440.       ENDIF
  1441. C
  1442.       RETURN
  1443. *
  1444. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  1445. *
  1446.  9990 CONTINUE
  1447.       IRET=0
  1448.       SEGSUP MCHELM
  1449.  
  1450. c      RETURN
  1451.       END
  1452.  
  1453.  
  1454.  

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