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

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