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

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