Télécharger la plaquette Cast3M


fr en

Télécharger workp.eso

Retour à la liste

Numérotation des lignes : 

workp

  1. C WORKP     SOURCE    CB215821  24/04/12    21:17:29     11897          
  2.        SUBROUTINE WORKP(IPMODL,IPCHE1,IPCHE2,IPCHE3,IPCHE4,IRET)
  3. ************************************************************************
  4. * ENTREES :
  5. * IPMODL = POINTEUR SUR UN OBJET MMODEL
  6. * IPCHE1 = POINTEUR SUR UN MCHAML DE CONTRAINTES
  7. * IPCHE2 = POINTEUR SUR UN MCHAML DE GRADIENTS
  8. * IPCHE3 = POINTEUR SUR UN MCHAML DE GRADIENT DE FLEXION (CAS DES COQUES
  9. *
  10. * SORTIE :
  11. * IPCHE4 = POINTEUR SUR UN MCHAML DE DENSITE D'ENERGIE
  12. * IRET   = CODE DE RETOUR  = 0 ECHEC , = 1 SUCCES
  13. *
  14. * CODE DE SUO X.Z
  15. * PASSAGE AUX NOUVEAUX CHAMELEMS PAR P. DOWLATYARI AVRIL 91
  16. ************************************************************************
  17.       IMPLICIT INTEGER(I-N)
  18.       IMPLICIT REAL*8(A-H,O-Z)
  19. *
  20.  
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. -INC CCHAMP
  24. -INC SMCHAML
  25. -INC SMCHPOI
  26. -INC SMELEME
  27. -INC SMCOORD
  28. -INC SMMODEL
  29. -INC SMINTE
  30. -INC SMLREEL
  31. C
  32.       DIMENSION STRESS(8),GRADI(9),GRADF(9)
  33. *
  34.       SEGMENT NOTYPE
  35.         CHARACTER*16 TYPE(NBTYPE)
  36.       ENDSEGMENT
  37. *
  38.       SEGMENT MPTVAL
  39.         INTEGER IPOS(NS)    ,NSOF(NS)
  40.         INTEGER      IVAL(NCOSOU)
  41.         CHARACTER*16 TYVAL(NCOSOU)
  42.       ENDSEGMENT
  43. *
  44.       PARAMETER ( NINF=3 )
  45.       INTEGER INFOS(NINF)
  46.       CHARACTER*(NCONCH) CONM
  47.       LOGICAL lsupgd,lsupgf,lsupco
  48. C
  49.       lsupgd=.false.
  50.       lsupgf=.false.
  51.       lsupco=.false.
  52.       IRET = 0
  53.       IPCHE4 = 0
  54. C
  55.       NHRM=NIFOUR
  56. C
  57.       MCHEL1=IPCHE1
  58.       SEGACT,MCHEL1
  59.       MCHEL2=IPCHE2
  60.       SEGACT,MCHEL2
  61. C
  62. C      TEST DE COMPATIBILITE DES CHAMPS
  63. C
  64.        IF((MCHEL1.TITCHE).EQ.'CONTRAINTES'.AND.(MCHEL2.TITCHE)
  65.      1    .EQ.'GRADIENT')THEN
  66.          IPCONT=IPCHE1
  67.          IPGRAD=IPCHE2
  68.          IPGRAF=IPCHE3
  69.        ELSEIF((MCHEL2.TITCHE).EQ.'CONTRAINTES'.AND.(MCHEL1.TITCHE)
  70.      1    .EQ.'GRADIENT')THEN
  71.          IPCONT=IPCHE2
  72.          IPGRAD=IPCHE1
  73.          IPGRAF=IPCHE3
  74.        ELSE
  75.          MOTERR(1:19)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8)
  76.          CALL  ERREUR(175)
  77.          RETURN
  78.        ENDIF
  79. *
  80. *     Verification du lieu support du MCHAML de CONTRAINTES
  81. *
  82.       CALL QUESUP(IPMODL,IPCONT,5,0,ISUP1,IRET1)
  83.       IF (ISUP1.GT.1) RETURN
  84. *
  85. *     Verification du lieu support du MCHAML de GRADIENT
  86. *
  87.       segact mchel1,mchel2
  88.       CALL QUESUP(IPMODL,IPGRAD,5,0,ISUP2,IRET2)
  89.       IF (ISUP2.GT.1) RETURN
  90. *
  91. *     Verification du lieu support du MCHAML de GRADIENT  DE FLEXION
  92. *
  93.       IF(IPGRAF.NE.0)THEN
  94.         CALL QUESUP(IPMODL,IPGRAF,5,0,ISUP3,IRET3)
  95.         IF (ISUP3.GT.1) RETURN
  96.        ENDIF
  97. C
  98. C      ACTIVATION DU MODEL
  99. C
  100.        MMODEL=IPMODL
  101.        SEGACT,MMODEL
  102.        NSOUS=KMODEL(/1)
  103. C
  104. C       CREATION DU MCHELM
  105. C
  106.        N1=NSOUS
  107.        L1=8
  108.        N3=6
  109.        SEGINI MCHELM
  110.        TITCHE='SCALAIRE'
  111.        IFOCHE=IFOUR
  112. C
  113. C       DEBUT DE LA BOUCLE SUR LES DIFFERENTS SOUS-ZONES
  114. C
  115.        isouss=0
  116.        DO 500 ISOUS=1,NSOUS
  117. *
  118. *   INITIALISATION
  119. *
  120.        IVASTR=0
  121.        NSTR=0
  122.        IVAGRA=0
  123.        NGRAD=0
  124.        IVAGRF=0
  125.        NGRAF=0
  126.        IPMINT=0
  127. C
  128. C       ON RECUPERE LES INFOS GENERALES
  129. C
  130.        IMODEL=KMODEL(ISOUS)
  131.        SEGACT,IMODEL
  132.        MELE=NEFMOD
  133.        if((mele.eq.22).OR.(mele.eq.259)) then
  134.           go to 500
  135.        endif
  136.        isouss=isouss+1
  137. C
  138. C     TRAITEMENT DU MODELE
  139. C
  140.        IPMAIL=IMAMOD
  141.        MELEME=IPMAIL
  142.        CONM = CONMOD
  143. C
  144.        IMACHE(ISOUSs)=IPMAIL
  145.        CONCHE(ISOUSs)=CONMOD
  146. C____________________________________________________________________
  147. C
  148. C     INFORMATION SUR L'ELEMENT FINI
  149. C____________________________________________________________________
  150. C
  151.       MFR  =INFELE(13)
  152.       NBGS =INFELE(4)
  153. *      MINTE=INFELE(11)
  154.       MINTE=INFMOD(7)
  155.       IPMINT=MINTE
  156.       IF (IPMINT.NE.0) SEGACT,MINTE
  157. C*      MINTE1=INFMOD(8)
  158. C
  159. C   COQUE INTEGREE OU PAS ?
  160. C
  161.          IF(INFMOD(/1).NE.0)THEN
  162.            NPINT=INFMOD(1)
  163. C        attention aux XFEM qui ne sont pas des coques!
  164.            IF(MFR.eq.63) NPINT=0
  165.          ELSE
  166.            NPINT=0
  167.          ENDIF
  168.          IF (NPINT.NE.0)THEN
  169.             CALL ERREUR(615)
  170.             GOTO 9991
  171.          ENDIF
  172. C
  173. C     CREATION DU TABLEAU INFOS
  174. C
  175.       CALL IDENT(IPMAIL,CONM,IPCONT,IPGRAD,INFOS,IRTD)
  176.       IF (IERR.NE.0) GOTO 9991
  177. C
  178.       INFCHE(ISOUSs,1)=0
  179.       INFCHE(ISOUSs,2)=0
  180.       INFCHE(ISOUSs,3)=NHRM
  181.       INFCHE(ISOUSs,4)=MINTE
  182.       INFCHE(ISOUSs,5)=0
  183.       INFCHE(ISOUSs,6)=5
  184. C
  185. C     ACTIVATION DU MELEME
  186. C
  187.       SEGACT MELEME
  188.       NBNN  =NUM(/1)
  189.       NBELEM=NUM(/2)
  190.       IPPORE=0
  191.       IF(MFR.EQ.33) IPPORE=NBNN
  192. C____________________________________________________________________
  193. C
  194. C     RECHERCHE DES NOMS DE COMPOSANTES
  195. C____________________________________________________________________
  196. C
  197.       if(lnomid(4).ne.0) then
  198.          nomid=lnomid(4)
  199.          segact nomid
  200.          mostrs=nomid
  201.          nstr=lesobl(/2)
  202.          nfac=lesfac(/2)
  203.          lsupco=.false.
  204.       else
  205.          lsupco=.true.
  206.          CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  207.       endif
  208. C
  209.       if(lnomid(3).ne.0) then
  210.          nomid=lnomid(3)
  211.          segact nomid
  212.          mograd=nomid
  213.          ngrad=lesobl(/2)
  214.          nfac=lesfac(/2)
  215.          lsupgd=.false.
  216.       else
  217.          lsupgd=.true.
  218.        CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRAD,NFAC)
  219.       endif
  220. C
  221.       IF(IPGRAF.NE.0) THEN
  222.         if(lnomid(11).ne.0) then
  223.          nomid=lnomid(11)
  224.          segact nomid
  225.          mograf=nomid
  226.          ngraf=lesobl(/2)
  227.          nfac=lesfac(/2)
  228.          lsupgf=.false.
  229.         else
  230.          lsupgf=.true.
  231.          CALL IDGRAF(MFR,IFOUR,MOGRAF,NGRAF,NFAC)
  232.         endif
  233.       ENDIF
  234. C____________________________________________________________________
  235. C
  236. C     VERIFICATION DE LEUR PRESENCE
  237. C____________________________________________________________________
  238. C
  239.       NBTYPE=1
  240.       SEGINI NOTYPE
  241.       MOTYPE=NOTYPE
  242.       TYPE(1)='REAL*8'
  243. C
  244.       CALL KOMCHA(IPCONT,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
  245.       IF (IERR.NE.0)THEN
  246.          SEGSUP NOTYPE
  247.          GOTO 9990
  248.       ENDIF
  249.       IF (ISUP1.EQ.1) CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE,
  250.      &                MOSTRS,MELE)
  251. C
  252.       CALL KOMCHA(IPGRAD,IPMAIL,CONM,MOGRAD,MOTYPE,1,INFOS,3,IVAGRA)
  253.       SEGSUP NOTYPE
  254.       IF (IERR.NE.0) GOTO 9990
  255.       IF (ISUP2.EQ.1) CALL VALCHE(IVAGRA,NGRAD,IPMINT,IPPORE,
  256.      &                MOGRAD,MELE)
  257. C
  258.       IF(MFR.EQ.3.OR.MFR.EQ.9)THEN
  259.         IF(IPGRAF.NE.0)THEN
  260.          NBTYPE=1
  261.          SEGINI NOTYPE
  262.          MOTYPE=NOTYPE
  263.          TYPE(1)='REAL*8'
  264.          CALL KOMCHA(IPGRAF,IPMAIL,CONM,MOGRAF,MOTYPE,1,INFOS,3,IVAGRF)
  265.          SEGSUP NOTYPE
  266.          IF (IERR.NE.0) GOTO 9990
  267.          IF (ISUP3.EQ.1) CALL VALCHE(IVAGRF,NGRAF,IPMINT,IPPORE,
  268.      &                MOGRAF,MELE)
  269. C
  270.        ELSE
  271.         MOTERR(1:8)='MCHAML  '
  272.         CALL ERREUR(37)
  273.         GO TO 9990
  274.        ENDIF
  275.       ENDIF
  276. C
  277. C     RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  278. C
  279.       N1PTEL=NBGS
  280.       N1EL=NBELEM
  281.       NBPTEL=N1PTEL
  282.       NEL=N1EL
  283. C
  284. C     CREATION DU MCHAML DE LA SOUS ZONE
  285. C
  286.       N2=1
  287.       SEGINI MCHAML
  288.       ICHAML(ISOUSs)=MCHAML
  289.       NOMCHE(1)='SCAL'
  290.       TYPCHE(1)='REAL*8'
  291.       N2PTEL=0
  292.       N2EL=0
  293.       SEGINI MELVAL
  294.       IELVAL(1)=MELVAL
  295. C
  296. C       ELEMENTS MASSIFS ET ELEMENTS COQUES EPAISSES
  297. C
  298.       IF(MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.5.OR.MFR.EQ.63)THEN
  299. C
  300. C       BOUCLE SUR  LES ELEMENTS
  301. C
  302.          DO 600 IB=1,NBELEM
  303. C
  304. C        BOUCLE SUR LES POINTS DE GAUSS
  305. C
  306.            DO 700 IGAU=1,NBPTEL
  307. C
  308. C        ON RECUPERE LES CONTRAINTES
  309. C
  310.           CALL ZERO(STRESS,8,1)
  311.           MPTVAL=IVASTR
  312.            DO 710 ICOMP=1,NSTR
  313.                MELVAL=IVAL(ICOMP)
  314.                IBMN=MIN(IB,VELCHE(/2))
  315.                IGMN=MIN(IGAU,VELCHE(/1))
  316.                STRESS(ICOMP)=VELCHE(IGMN,IBMN)
  317.   710      CONTINUE
  318. C
  319. C        ON RECUPERE LES GRADIENTS
  320. C
  321.           CALL ZERO(GRADI,9,1)
  322.           MPTVAL=IVAGRA
  323.            DO 720 ICOMP=1,NGRAD
  324.                MELVAL=IVAL(ICOMP)
  325.                IBMN=MIN(IB,VELCHE(/2))
  326.                IGMN=MIN(IGAU,VELCHE(/1))
  327.                GRADI(ICOMP)=VELCHE(IGMN,IBMN)
  328.   720      CONTINUE
  329. C
  330. C            CALCUL  DE LA  DENSITE DE TRAVAIL
  331. C
  332.             IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.63) THEN
  333. C* <=>      IF (MFR.NE.5) THEN
  334.             WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+
  335.      1   STRESS(3)*GRADI(9)+STRESS(4)*(GRADI(2)+GRADI(4))+
  336.      2                     STRESS(5)*(GRADI(3)+GRADI(7))+
  337.      3                     STRESS(6)*(GRADI(6)+GRADI(8))
  338.             ELSE
  339.             WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+
  340.      1         STRESS(3)*(GRADI(2)+GRADI(4))+
  341.      2         STRESS(4)*(GRADI(3)+GRADI(7))+
  342.      3         STRESS(5)*(GRADI(6)+GRADI(8))
  343.             ENDIF
  344. C
  345. C              STOCKAGE
  346. C
  347.               MELVAL=IELVAL(1)
  348.               IBMN=MIN(IB,VELCHE(/2))
  349.               VELCHE(IGAU,IBMN)=WO
  350. C
  351.   700    CONTINUE
  352. C
  353.  600    CONTINUE
  354. C
  355. C           ELEMENTS COQUES  MINCES
  356. C
  357.         ELSEIF(MFR.EQ.3.OR.MFR.EQ.9)THEN
  358.           IF(IFOUR.EQ.2)THEN
  359. C
  360. C         BOUCLE SUR  LES ELEMENTS
  361. C
  362.             DO 800 IB=1,NBELEM
  363. C
  364. C        BOUCLE SUR LES POINTS DE GAUSS
  365. C
  366.                DO 900 IGAU=1,NBPTEL
  367. C
  368. C        ON RECUPERE LES CONTRAINTES
  369. C
  370.               CALL ZERO(STRESS,8,1)
  371.               MPTVAL=IVASTR
  372.               DO 910 ICOMP=1,NSTR
  373.                 MELVAL=IVAL(ICOMP)
  374.                 IBMN=MIN(IB,VELCHE(/2))
  375.                 IGMN=MIN(IGAU,VELCHE(/1))
  376.                 STRESS(ICOMP)=VELCHE(IGMN,IBMN)
  377.   910         CONTINUE
  378. C
  379. C        ON RECUPERE LES GRADIENTS
  380. C
  381.              CALL ZERO(GRADI,9,1)
  382.              MPTVAL=IVAGRA
  383.              DO 920 ICOMP=1,NGRAD
  384.                MELVAL=IVAL(ICOMP)
  385.                IBMN=MIN(IB,VELCHE(/2))
  386.                IGMN=MIN(IGAU,VELCHE(/1))
  387.                GRADI(ICOMP)=VELCHE(IGMN,IBMN)
  388.   920        CONTINUE
  389. C
  390. C        ON RECUPERE LES GRADIENTS DE FLEXION
  391. C
  392.              CALL ZERO(GRADF,9,1)
  393.              MPTVAL=IVAGRF
  394.              DO 930 ICOMP=1,NGRAF
  395.                MELVAL=IVAL(ICOMP)
  396.                IBMN=MIN(IB,VELCHE(/2))
  397.                IGMN=MIN(IGAU,VELCHE(/1))
  398.                GRADF(ICOMP)=VELCHE(IGMN,IBMN)
  399.   930        CONTINUE
  400. C
  401. C            CALCUL  DE LA  DENSITE DE TRAVAIL
  402. C
  403.             IF(MFR.EQ.3)THEN
  404.             WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+
  405.      1    STRESS(3)*(GRADI(2)+GRADI(4))+STRESS(4)*GRADF(1)+
  406.      2    STRESS(5)*GRADF(5)+STRESS(6)*(GRADF(2)+GRADF(4))
  407.             ELSE
  408.             WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+
  409.      1    STRESS(3)*(GRADI(2)+GRADI(4))+STRESS(4)*GRADF(1)+
  410.      2    STRESS(5)*GRADF(5)+STRESS(6)*(GRADF(2)+GRADF(4))+
  411.      3    STRESS(7)*(GRADI(3)+GRADI(7))+
  412.      4    STRESS(8)*(GRADI(6)+GRADI(8))
  413.             ENDIF
  414. C
  415. C              STOCKAGE
  416. C
  417.                MELVAL=IELVAL(1)
  418.                IBMN=MIN(IB,VELCHE(/2))
  419.                VELCHE(IGAU,IBMN)=WO
  420. C
  421.   900      CONTINUE
  422. C
  423.  800      CONTINUE
  424. C
  425.          ELSE
  426. C
  427. C        OPTION NON DISPONIBLE
  428. C
  429.             CALL ERREUR(251)
  430.             GO TO 9990
  431.           ENDIF
  432. C
  433.        ELSE
  434. C
  435. C        OPTION NON DISPONIBLE
  436. C
  437.           CALL ERREUR(251)
  438.           GO TO 9990
  439.       ENDIF
  440. C
  441. C       DESACTIVATION DES SEGMENTS
  442. C
  443.         IF(ISUP1.EQ.1)THEN
  444.            CALL DTMVAL(IVASTR,3)
  445.         ELSE
  446.           CALL DTMVAL(IVASTR,1)
  447.         ENDIF
  448. *
  449.         IF(ISUP2.EQ.1)THEN
  450.            CALL DTMVAL(IVAGRA,3)
  451.         ELSE
  452.           CALL DTMVAL(IVAGRA,1)
  453.         ENDIF
  454. *
  455.         IF(IPGRAF.NE.0)THEN
  456.          IF(ISUP3.EQ.1)THEN
  457.            CALL DTMVAL(IVAGRF,3)
  458.          ELSE
  459.           CALL DTMVAL(IVAGRF,1)
  460.          ENDIF
  461.         ENDIF
  462. *
  463.         MELVAL=IELVAL(1)
  464. *
  465.         NOMID=MOSTRS
  466.         if(lsupco)SEGSUP NOMID
  467.         NOMID=MOGRAD
  468.         if(lsupgd)SEGSUP NOMID
  469.         IF(IPGRAF.NE.0)THEN
  470.          NOMID=MOGRAF
  471.          if(lsupgf)SEGSUP NOMID
  472.         ENDIF
  473. *
  474. *
  475.  500  CONTINUE
  476.       if( n1.ne.isouss) then
  477.           n1=isouss
  478.           segadj mchelm
  479.       endif
  480.       IRET = 1
  481.       IPCHE4 = MCHELM
  482. *
  483.       RETURN
  484. *
  485. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  486. *
  487.  9990 CONTINUE
  488. *
  489.       IF(ISUP1.EQ.1)THEN
  490.            CALL DTMVAL(IVASTR,3)
  491.       ELSE
  492.           CALL DTMVAL(IVASTR,1)
  493.       ENDIF
  494. *
  495.       IF(ISUP2.EQ.1)THEN
  496.            CALL DTMVAL(IVAGRA,3)
  497.       ELSE
  498.           CALL DTMVAL(IVAGRA,1)
  499.       ENDIF
  500. *
  501.       IF(IPGRAF.NE.0)THEN
  502.          IF(ISUP3.EQ.1)THEN
  503.            CALL DTMVAL(IVAGRF,3)
  504.          ELSE
  505.           CALL DTMVAL(IVAGRF,1)
  506.          ENDIF
  507.       ENDIF
  508.        IF(IELVAL(1).NE.0)THEN
  509.          MELVAL=IELVAL(1)
  510.          SEGSUP,MELVAL
  511.        ENDIF
  512. *
  513.       IF(NSTR.NE.0)THEN
  514.        NOMID=MOSTRS
  515.        if(lsupco)SEGSUP NOMID
  516.       ENDIF
  517. *
  518.       IF(NGRAD.NE.0)THEN
  519.        NOMID=MOGRAD
  520.        if(lsupgd)SEGSUP NOMID
  521.       ENDIF
  522. *
  523.       IF(NGRAF.NE.0)THEN
  524.        NOMID=MOGRAF
  525.        if(lsupgf)SEGSUP NOMID
  526.       ENDIF
  527. *
  528.       IF(ICHAML(ISOUSs).NE.0)SEGSUP,MCHAML
  529.       ISOU=ISOUS-1
  530.       IF(ISOU.GE.1)THEN
  531.        DO 9996 IO=1,ISOU
  532.         MCHAML=ICHAML(ISOU)
  533.         SEGACT,MCHAML
  534.         MELVAL=IELVAL(1)
  535.         SEGSUP,MELVAL
  536.         SEGSUP,MCHAML
  537.  9996  CONTINUE
  538.       ENDIF
  539. *
  540.  9991 CONTINUE
  541.       SEGSUP,MCHELM
  542. *
  543.       IRET = 0
  544.       IPCHE4 = 0
  545. *
  546.       END
  547.  
  548.  
  549.  
  550.  
  551.  
  552.  
  553.  

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