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  24/10/07    21:15:52     12016          
  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.          NPINT=INFMOD(1)
  161. C        attention aux XFEM qui ne sont pas des coques!
  162.          IF (MFR.eq.63) NPINT=0
  163.          IF (NPINT.NE.0)THEN
  164.             CALL ERREUR(615)
  165.             GOTO 9991
  166.          ENDIF
  167. C
  168. C     CREATION DU TABLEAU INFOS
  169. C
  170.       CALL IDENT(IPMAIL,CONM,IPCONT,IPGRAD,INFOS,IRTD)
  171.       IF (IERR.NE.0) GOTO 9991
  172. C
  173.       INFCHE(ISOUSs,1)=0
  174.       INFCHE(ISOUSs,2)=0
  175.       INFCHE(ISOUSs,3)=NHRM
  176.       INFCHE(ISOUSs,4)=MINTE
  177.       INFCHE(ISOUSs,5)=0
  178.       INFCHE(ISOUSs,6)=5
  179. C
  180. C     ACTIVATION DU MELEME
  181. C
  182.       SEGACT MELEME
  183.       NBNN  =NUM(/1)
  184.       NBELEM=NUM(/2)
  185.       IPPORE=0
  186.       IF(MFR.EQ.33) IPPORE=NBNN
  187. C____________________________________________________________________
  188. C
  189. C     RECHERCHE DES NOMS DE COMPOSANTES
  190. C____________________________________________________________________
  191. C
  192.       if(lnomid(4).ne.0) then
  193.          nomid=lnomid(4)
  194.          segact nomid
  195.          mostrs=nomid
  196.          nstr=lesobl(/2)
  197.          nfac=lesfac(/2)
  198.          lsupco=.false.
  199.       else
  200.          lsupco=.true.
  201.          CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  202.       endif
  203. C
  204.       if(lnomid(3).ne.0) then
  205.          nomid=lnomid(3)
  206.          segact nomid
  207.          mograd=nomid
  208.          ngrad=lesobl(/2)
  209.          nfac=lesfac(/2)
  210.          lsupgd=.false.
  211.       else
  212.          lsupgd=.true.
  213.        CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRAD,NFAC)
  214.       endif
  215. C
  216.       IF(IPGRAF.NE.0) THEN
  217.         if(lnomid(11).ne.0) then
  218.          nomid=lnomid(11)
  219.          segact nomid
  220.          mograf=nomid
  221.          ngraf=lesobl(/2)
  222.          nfac=lesfac(/2)
  223.          lsupgf=.false.
  224.         else
  225.          lsupgf=.true.
  226.          CALL IDGRAF(MFR,IFOUR,MOGRAF,NGRAF,NFAC)
  227.         endif
  228.       ENDIF
  229. C____________________________________________________________________
  230. C
  231. C     VERIFICATION DE LEUR PRESENCE
  232. C____________________________________________________________________
  233. C
  234.       NBTYPE=1
  235.       SEGINI NOTYPE
  236.       MOTYPE=NOTYPE
  237.       TYPE(1)='REAL*8'
  238. C
  239.       CALL KOMCHA(IPCONT,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
  240.       IF (IERR.NE.0)THEN
  241.          SEGSUP NOTYPE
  242.          GOTO 9990
  243.       ENDIF
  244.       IF (ISUP1.EQ.1) CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE,
  245.      &                MOSTRS,MELE)
  246. C
  247.       CALL KOMCHA(IPGRAD,IPMAIL,CONM,MOGRAD,MOTYPE,1,INFOS,3,IVAGRA)
  248.       SEGSUP NOTYPE
  249.       IF (IERR.NE.0) GOTO 9990
  250.       IF (ISUP2.EQ.1) CALL VALCHE(IVAGRA,NGRAD,IPMINT,IPPORE,
  251.      &                MOGRAD,MELE)
  252. C
  253.       IF(MFR.EQ.3.OR.MFR.EQ.9)THEN
  254.         IF(IPGRAF.NE.0)THEN
  255.          NBTYPE=1
  256.          SEGINI NOTYPE
  257.          MOTYPE=NOTYPE
  258.          TYPE(1)='REAL*8'
  259.          CALL KOMCHA(IPGRAF,IPMAIL,CONM,MOGRAF,MOTYPE,1,INFOS,3,IVAGRF)
  260.          SEGSUP NOTYPE
  261.          IF (IERR.NE.0) GOTO 9990
  262.          IF (ISUP3.EQ.1) CALL VALCHE(IVAGRF,NGRAF,IPMINT,IPPORE,
  263.      &                MOGRAF,MELE)
  264. C
  265.        ELSE
  266.         MOTERR(1:8)='MCHAML  '
  267.         CALL ERREUR(37)
  268.         GO TO 9990
  269.        ENDIF
  270.       ENDIF
  271. C
  272. C     RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  273. C
  274.       N1PTEL=NBGS
  275.       N1EL=NBELEM
  276.       NBPTEL=N1PTEL
  277.       NEL=N1EL
  278. C
  279. C     CREATION DU MCHAML DE LA SOUS ZONE
  280. C
  281.       N2=1
  282.       SEGINI MCHAML
  283.       ICHAML(ISOUSs)=MCHAML
  284.       NOMCHE(1)='SCAL'
  285.       TYPCHE(1)='REAL*8'
  286.       N2PTEL=0
  287.       N2EL=0
  288.       SEGINI MELVAL
  289.       IELVAL(1)=MELVAL
  290. C
  291. C       ELEMENTS MASSIFS ET ELEMENTS COQUES EPAISSES
  292. C
  293.       IF(MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.5.OR.MFR.EQ.63)THEN
  294. C
  295. C       BOUCLE SUR  LES ELEMENTS
  296. C
  297.          DO 600 IB=1,NBELEM
  298. C
  299. C        BOUCLE SUR LES POINTS DE GAUSS
  300. C
  301.            DO 700 IGAU=1,NBPTEL
  302. C
  303. C        ON RECUPERE LES CONTRAINTES
  304. C
  305.           CALL ZERO(STRESS,8,1)
  306.           MPTVAL=IVASTR
  307.            DO 710 ICOMP=1,NSTR
  308.                MELVAL=IVAL(ICOMP)
  309.                IBMN=MIN(IB,VELCHE(/2))
  310.                IGMN=MIN(IGAU,VELCHE(/1))
  311.                STRESS(ICOMP)=VELCHE(IGMN,IBMN)
  312.   710      CONTINUE
  313. C
  314. C        ON RECUPERE LES GRADIENTS
  315. C
  316.           CALL ZERO(GRADI,9,1)
  317.           MPTVAL=IVAGRA
  318.            DO 720 ICOMP=1,NGRAD
  319.                MELVAL=IVAL(ICOMP)
  320.                IBMN=MIN(IB,VELCHE(/2))
  321.                IGMN=MIN(IGAU,VELCHE(/1))
  322.                GRADI(ICOMP)=VELCHE(IGMN,IBMN)
  323.   720      CONTINUE
  324. C
  325. C            CALCUL  DE LA  DENSITE DE TRAVAIL
  326. C
  327.             IF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.63) THEN
  328. C* <=>      IF (MFR.NE.5) THEN
  329.             WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+
  330.      1   STRESS(3)*GRADI(9)+STRESS(4)*(GRADI(2)+GRADI(4))+
  331.      2                     STRESS(5)*(GRADI(3)+GRADI(7))+
  332.      3                     STRESS(6)*(GRADI(6)+GRADI(8))
  333.             ELSE
  334.             WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+
  335.      1         STRESS(3)*(GRADI(2)+GRADI(4))+
  336.      2         STRESS(4)*(GRADI(3)+GRADI(7))+
  337.      3         STRESS(5)*(GRADI(6)+GRADI(8))
  338.             ENDIF
  339. C
  340. C              STOCKAGE
  341. C
  342.               MELVAL=IELVAL(1)
  343.               IBMN=MIN(IB,VELCHE(/2))
  344.               VELCHE(IGAU,IBMN)=WO
  345. C
  346.   700    CONTINUE
  347. C
  348.  600    CONTINUE
  349. C
  350. C           ELEMENTS COQUES  MINCES
  351. C
  352.         ELSEIF(MFR.EQ.3.OR.MFR.EQ.9)THEN
  353.           IF(IFOUR.EQ.2)THEN
  354. C
  355. C         BOUCLE SUR  LES ELEMENTS
  356. C
  357.             DO 800 IB=1,NBELEM
  358. C
  359. C        BOUCLE SUR LES POINTS DE GAUSS
  360. C
  361.                DO 900 IGAU=1,NBPTEL
  362. C
  363. C        ON RECUPERE LES CONTRAINTES
  364. C
  365.               CALL ZERO(STRESS,8,1)
  366.               MPTVAL=IVASTR
  367.               DO 910 ICOMP=1,NSTR
  368.                 MELVAL=IVAL(ICOMP)
  369.                 IBMN=MIN(IB,VELCHE(/2))
  370.                 IGMN=MIN(IGAU,VELCHE(/1))
  371.                 STRESS(ICOMP)=VELCHE(IGMN,IBMN)
  372.   910         CONTINUE
  373. C
  374. C        ON RECUPERE LES GRADIENTS
  375. C
  376.              CALL ZERO(GRADI,9,1)
  377.              MPTVAL=IVAGRA
  378.              DO 920 ICOMP=1,NGRAD
  379.                MELVAL=IVAL(ICOMP)
  380.                IBMN=MIN(IB,VELCHE(/2))
  381.                IGMN=MIN(IGAU,VELCHE(/1))
  382.                GRADI(ICOMP)=VELCHE(IGMN,IBMN)
  383.   920        CONTINUE
  384. C
  385. C        ON RECUPERE LES GRADIENTS DE FLEXION
  386. C
  387.              CALL ZERO(GRADF,9,1)
  388.              MPTVAL=IVAGRF
  389.              DO 930 ICOMP=1,NGRAF
  390.                MELVAL=IVAL(ICOMP)
  391.                IBMN=MIN(IB,VELCHE(/2))
  392.                IGMN=MIN(IGAU,VELCHE(/1))
  393.                GRADF(ICOMP)=VELCHE(IGMN,IBMN)
  394.   930        CONTINUE
  395. C
  396. C            CALCUL  DE LA  DENSITE DE TRAVAIL
  397. C
  398.             IF(MFR.EQ.3)THEN
  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.             ELSE
  403.             WO=STRESS(1)*GRADI(1)+STRESS(2)*GRADI(5)+
  404.      1    STRESS(3)*(GRADI(2)+GRADI(4))+STRESS(4)*GRADF(1)+
  405.      2    STRESS(5)*GRADF(5)+STRESS(6)*(GRADF(2)+GRADF(4))+
  406.      3    STRESS(7)*(GRADI(3)+GRADI(7))+
  407.      4    STRESS(8)*(GRADI(6)+GRADI(8))
  408.             ENDIF
  409. C
  410. C              STOCKAGE
  411. C
  412.                MELVAL=IELVAL(1)
  413.                IBMN=MIN(IB,VELCHE(/2))
  414.                VELCHE(IGAU,IBMN)=WO
  415. C
  416.   900      CONTINUE
  417. C
  418.  800      CONTINUE
  419. C
  420.          ELSE
  421. C
  422. C        OPTION NON DISPONIBLE
  423. C
  424.             CALL ERREUR(251)
  425.             GO TO 9990
  426.           ENDIF
  427. C
  428.        ELSE
  429. C
  430. C        OPTION NON DISPONIBLE
  431. C
  432.           CALL ERREUR(251)
  433.           GO TO 9990
  434.       ENDIF
  435. C
  436. C       DESACTIVATION DES SEGMENTS
  437. C
  438.         IF(ISUP1.EQ.1)THEN
  439.            CALL DTMVAL(IVASTR,3)
  440.         ELSE
  441.           CALL DTMVAL(IVASTR,1)
  442.         ENDIF
  443. *
  444.         IF(ISUP2.EQ.1)THEN
  445.            CALL DTMVAL(IVAGRA,3)
  446.         ELSE
  447.           CALL DTMVAL(IVAGRA,1)
  448.         ENDIF
  449. *
  450.         IF(IPGRAF.NE.0)THEN
  451.          IF(ISUP3.EQ.1)THEN
  452.            CALL DTMVAL(IVAGRF,3)
  453.          ELSE
  454.           CALL DTMVAL(IVAGRF,1)
  455.          ENDIF
  456.         ENDIF
  457. *
  458.         MELVAL=IELVAL(1)
  459. *
  460.         NOMID=MOSTRS
  461.         if(lsupco)SEGSUP NOMID
  462.         NOMID=MOGRAD
  463.         if(lsupgd)SEGSUP NOMID
  464.         IF(IPGRAF.NE.0)THEN
  465.          NOMID=MOGRAF
  466.          if(lsupgf)SEGSUP NOMID
  467.         ENDIF
  468. *
  469. *
  470.  500  CONTINUE
  471.       if( n1.ne.isouss) then
  472.           n1=isouss
  473.           segadj mchelm
  474.       endif
  475.       IRET = 1
  476.       IPCHE4 = MCHELM
  477. *
  478.       RETURN
  479. *
  480. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  481. *
  482.  9990 CONTINUE
  483. *
  484.       IF(ISUP1.EQ.1)THEN
  485.            CALL DTMVAL(IVASTR,3)
  486.       ELSE
  487.           CALL DTMVAL(IVASTR,1)
  488.       ENDIF
  489. *
  490.       IF(ISUP2.EQ.1)THEN
  491.            CALL DTMVAL(IVAGRA,3)
  492.       ELSE
  493.           CALL DTMVAL(IVAGRA,1)
  494.       ENDIF
  495. *
  496.       IF(IPGRAF.NE.0)THEN
  497.          IF(ISUP3.EQ.1)THEN
  498.            CALL DTMVAL(IVAGRF,3)
  499.          ELSE
  500.           CALL DTMVAL(IVAGRF,1)
  501.          ENDIF
  502.       ENDIF
  503.        IF(IELVAL(1).NE.0)THEN
  504.          MELVAL=IELVAL(1)
  505.          SEGSUP,MELVAL
  506.        ENDIF
  507. *
  508.       IF(NSTR.NE.0)THEN
  509.        NOMID=MOSTRS
  510.        if(lsupco)SEGSUP NOMID
  511.       ENDIF
  512. *
  513.       IF(NGRAD.NE.0)THEN
  514.        NOMID=MOGRAD
  515.        if(lsupgd)SEGSUP NOMID
  516.       ENDIF
  517. *
  518.       IF(NGRAF.NE.0)THEN
  519.        NOMID=MOGRAF
  520.        if(lsupgf)SEGSUP NOMID
  521.       ENDIF
  522. *
  523.       IF(ICHAML(ISOUSs).NE.0)SEGSUP,MCHAML
  524.       ISOU=ISOUS-1
  525.       IF(ISOU.GE.1)THEN
  526.        DO 9996 IO=1,ISOU
  527.         MCHAML=ICHAML(ISOU)
  528.         SEGACT,MCHAML
  529.         MELVAL=IELVAL(1)
  530.         SEGSUP,MELVAL
  531.         SEGSUP,MCHAML
  532.  9996  CONTINUE
  533.       ENDIF
  534. *
  535.  9991 CONTINUE
  536.       SEGSUP,MCHELM
  537. *
  538.       IRET = 0
  539.       IPCHE4 = 0
  540. *
  541.       END
  542.  
  543.  
  544.  
  545.  
  546.  
  547.  
  548.  
  549.  

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