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

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