Télécharger la plaquette Cast3M


fr en

Télécharger rtens.eso

Retour à la liste

Numérotation des lignes : 

rtens

  1. C RTENS     SOURCE    CB215821  24/04/12    21:17:13     11897          
  2.       SUBROUTINE RTENS(IPCHE,IPMODL,IMOT,KMOT,
  3.      &                 IPTV1,IPTV2,IPTV3,IPCHE1,ICAS,IPCHAM)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8(A-H,O-Z)
  6. *-----------------------------------------------------------------------*
  7. *     Operateur RTENS                                                   *
  8. *                                                                       *
  9. *     IPCHE  (e)   pointeur sur un MCHAML (CONTRAINTES ou DEFORMATIONS  *
  10. *                    ou DEFORMATIONS INELASTIQUES)                      *
  11. *     IPMODL (e)   pointeur sur un MMODEL                               *
  12. *     IMOT   (e)   0 : repere cartesien ou repere d'orthotropie         *
  13. *                  1 : repere en coordonnees polaires                   *
  14. *                  2 : repere en coordonnees cylindriques               *
  15. *                  3 : repere en coordonnees spheriques                 *
  16. *                  4 : repere en coordonnees toriques circulaires       *
  17. *                  5 : repere en coordonnees toriques cartesiennes      *
  18. *     KMOT   (e)   1 : transformation RT*A*R                            *
  19. *                  2 : transformation R*A*RT                            *
  20. *                  utilisé avec le champ de gradient
  21. *     IPTV1  (e)   1er vecteur  (IMOT = 0) ou 1er point  (IMOT <> 0)    *
  22. *     IPTV2  (e)   2eme vecteur (IMOT = 0) ou 2eme point (IMOT <> 0)    *
  23. *     IPTV3  (e)   3eme point (IMOT <> 0)                               *
  24. *     IPCHE1 (e)   pointeur sur un MCHAML de CARACTERISTIQUES           *
  25. *     ICAS   (e)   distingue les differents cas                         *
  26. *                  1 =
  27. *                  2 =
  28. *                  3 =
  29. *                  4 = option CHAM2 champ de gradient
  30. *     IPCHAM (s)   pointeur sur un MCHAML (CONTRAINTES ou DEFORMATIONS) *
  31. *                                         (ou VARIABLES INTERNES      ) *
  32. *                                                                       *
  33. *  Passage aux nouveaux Chamelem par S.RAMAHANDRY le 28/10/90           *
  34. *  Corrections / redecoupage / ajouts D. R.-M. le 18/3/94               *
  35. *-----------------------------------------------------------------------*
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC CCHAMP
  40. -INC SMCHAML
  41. -INC SMMODEL
  42. -INC SMINTE
  43. -INC SMCOORD
  44. -INC SMELEME
  45. *
  46.       SEGMENT NOTYPE
  47.          CHARACTER*16 TYPE(NBTYPE)
  48.       ENDSEGMENT
  49.       SEGMENT MPTVAL
  50.          INTEGER IPOS(NS) , NSOF(NS)
  51.          INTEGER IVAL(NCOSOU)
  52.          CHARACTER*16 TYVAL(NCOSOU)
  53.       ENDSEGMENT
  54.       POINTEUR MPTVA1.MPTVAL
  55. *
  56.       DIMENSION V1(4),V2(4),W2(3),W3(3)
  57.       DIMENSION CENTR1(3),CENTR2(3),AXEI1(3)
  58. *
  59.       PARAMETER ( NINF=3 )
  60.       INTEGER INFOS(NINF)
  61.       CHARACTER*(NCONCH) CONM
  62.       CHARACTER*8  CMATE
  63.       LOGICAL Lsupre,lsupgd
  64.       lsupre=.true.
  65.       lsupgd=.true.
  66. *
  67.       NHRM=NIFOUR
  68. *
  69. *     Activation du MMODEL
  70. *
  71.       MMODEL=IPMODL
  72.       NSOUS=KMODEL(/1)
  73. *
  74.       ICONT=0
  75.       IDEFO=0
  76.       IDEF = 0
  77.       IVARI=0
  78.       MOCOMP = 0
  79.       MOEP = 0
  80.       MOVEC = 0
  81.       MCHELM=IPCHE
  82.       IFOMEM=IFOCHE
  83.       IF (TITCHE .EQ.'CONTRAINTES')  ICONT = 1
  84.       IF (TITCHE .EQ.'DEFORMATIONS') IDEFO = 1
  85.       IF (TITCHE .EQ.'DEFORMATIONS INELASTIQUES') IDEFO = 2
  86.       if (idefo.gt.0) idef= 1
  87.       IF (TITCHE .EQ.'VARIABLES INTERNES') IVARI = 1
  88.       IF (ICAS.NE.4.AND.ICONT.NE.1.AND.IDEFO.NE.1.AND.IDEFO.NE.2) THEN
  89. *
  90. *        Le sous-type du MCHAML doit etre CONTRAINTES ou DEFORMATIONS
  91. *        sauf dans le cas gradient pour le moment
  92. *
  93.          MOTERR(1:24) ='CONTRAINTES'
  94.          MOTERR(25:48)='DEFORMATIONS'
  95.          CALL ERREUR(109)
  96.          RETURN
  97.       ENDIF
  98. *
  99. *     Verification du lieu support du MCHAML de contraintes
  100. *
  101. ***   CALL QUESUP (IPMODL,IPCHE,5,0,ISUP,IRETCO)
  102.       ISUP = 5
  103.       CALL CHASUP (IPMODL,IPCHE,IPPV,IRET,5)
  104.       IF (IRET.NE.0) RETURN
  105.       IPCHE=IPPV
  106. *
  107. *     Verification du lieu support du MCHAML de caracteristiques
  108. *
  109.       IF (IPCHE1.NE.0) THEN
  110. **       CALL QUESUP (IPMODL,IPCHE1,5,1,ISUP1,IRETCA)
  111. **       IF (ISUP1.NE.0) RETURN
  112.       ISUP1 = 5
  113.       CALL CHASUP (IPMODL,IPCHE1,IPPV,IRET,5)
  114.       IF (IRET.NE.0) RETURN
  115.       IPCHE1=IPPV
  116.       ENDIF
  117. *
  118. *     Creation du MCHAML resultat (apres rotation)
  119. *
  120. *     cas des champs de contraintes ou de deformations
  121. *
  122.       N1=NSOUS
  123.       L1=12
  124.       IF (IVARI.EQ.1) L1=18
  125.       if (idefo.eq.2) L1=25
  126.       N3=6
  127.       SEGINI MCHELM
  128.       IF (ICONT.EQ.1) THEN
  129.          TITCHE='CONTRAINTES'
  130.       ELSE IF (IDEFO.EQ.1) THEN
  131.          TITCHE='DEFORMATIONS'
  132.       ELSE IF (IDEFO.EQ.2) THEN
  133.          TITCHE='DEFORMATIONS INELASTIQUES'
  134.       ELSE IF (IVARI.EQ.1) THEN
  135.          TITCHE='VARIABLES INTERNES'
  136.       ENDIF
  137.       IFOCHE=IFOUR
  138.       IPCHAM=MCHELM
  139. *
  140. *     Boucle sur les zones du MMODEL
  141. *
  142.       ISOUSS = 0
  143.       DO 500 ISOUS=1,NSOUS
  144.          ISOUSS = ISOUSS + 1     
  145. *        compteurs de sous champs de lobjet rasutlat
  146.  
  147.  
  148. *
  149. *        Initialisations
  150. *
  151.          IVACOM=0
  152.          IVARES=0
  153.          IMODEL=0
  154.          NCOMP=0
  155.          MOCOMP=0
  156.          IVAVEC=0
  157.          MOVEC=0
  158.          NVEC=0
  159. *
  160. *        >>> Recuparation des informations generiques <<<
  161. *
  162.          IMODEL=KMODEL(ISOUS)
  163.          IPMAIL=IMAMOD
  164.          CONM  =CONMOD
  165.          IMACHE(ISOUSS)=IPMAIL
  166.          CONCHE(ISOUSS)=CONMOD
  167. *
  168. *        Informations contenues dans le MMODEL
  169. *
  170.          MELE=NEFMOD
  171.          MELEME=IMAMOD
  172. *
  173. *        Nature et formulation du materiau
  174. *
  175. C*       NFOR=FORMOD(/2)
  176. C*       NMAT=MATMOD(/2)
  177. C*       CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  178.          CMATE = CMATEE
  179.          MATE  = IMATEE
  180.          INAT  = INATUU
  181. *
  182.  
  183. c GG : si le sous modele est un sure rien a faire ne cree pas de sous champs
  184.          IF (NEFMOD.EQ.259) THEN
  185.  
  186.            ISOUSS = ISOUSS - 1   
  187.            GOTO 500
  188.          ENDIF   
  189.  
  190.          IF(IVARI.EQ.1) THEN
  191. *
  192. *           test sur le type de modele de materiau
  193. *           en cas de variables internes en attendant que
  194. *           tous les modeles soient branches
  195. *           on admet actuellement les modeles ou toutes
  196. *           les variables internes sont scalaires
  197. *
  198.             LEPROB=2
  199. *
  200. *           cas des materiaux ou on n'a rien a faire
  201. *
  202.             IF(INAT.EQ. 0.OR.INAT.EQ. 1.OR.INAT.EQ. 3.OR.
  203.      &         INAT.EQ. 5.OR.INAT.EQ.15.OR.INAT.EQ.33.OR.
  204.      &         INAT.EQ.48) THEN
  205.                  LEPROB=0
  206.             ENDIF
  207. *
  208. *           cas des materiaux a traiter ( A FAIRE )
  209. *
  210. *           IF(INAT.EQ. 4) THEN
  211. *              LEPROB=1
  212. *              ..........
  213. *           ENDIF
  214. *
  215. *        cas des materiaux non prevus
  216. *
  217.             IF(LEPROB.EQ.2) THEN
  218.                CALL ERREUR(19)
  219.                SEGSUP MCHELM
  220.                RETURN
  221.             ENDIF
  222.          ENDIF
  223. *
  224. *        Coque integree ou non ?
  225. *
  226.          IF(INFMOD(/1).NE.0)THEN
  227.             NPINT=INFMOD(1)
  228.          ELSE
  229.             NPINT=0
  230.          ENDIF
  231. *
  232. *        Informations concernant l'element-fini
  233. *
  234. *         CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  235. *         IF (IERR.NE.0) THEN
  236. *            SEGSUP MCHELM
  237. *            RETURN
  238. *         ENDIF
  239. *         INFO   = IPINF
  240.          MFR    = INFELE(13)
  241.          NBGS   = INFELE(4)
  242.          NSTRS  = INFELE(16)
  243. *         MINTE  = INFELE(11)
  244.          MINTE=INFMOD(7)
  245.          IPMINT = MINTE
  246.          MINTE1 = INFMOD(8)
  247. *         SEGSUP INFO
  248. *
  249. *        Test presence MCHAML CARACTERISTIQUES si MFR=5 et IMOT<>0
  250. *
  251.          IF (MFR.EQ.5.AND.ICAS.NE.1.AND.ICAS.NE.4
  252.      &               .AND.IPCHE1.EQ.0) THEN
  253.             MOTERR(1:32) = 'CARACTERISTIQUES'
  254.             CALL ERREUR(565)
  255.             SEGSUP MCHELM
  256.             RETURN
  257.          ENDIF
  258. *
  259. *        L'option GRADIENT ne fonctionne qu'en massif actuellement
  260. *
  261. c          IF (ICAS.EQ.4.AND.MFR.NE.1.AND.MFR.NE.31) THEN
  262.          IF (ICAS.EQ.4.AND.MFR.NE.1.AND.MFR.NE.31.AND.MFR.NE.63) THEN
  263.             CALL ERREUR(19)
  264.             SEGSUP MCHELM
  265.             RETURN
  266.          ENDIF
  267. *
  268. *        Creation du tableau INFOS
  269. *
  270.          CALL IDENT(IPMAIL,CONM,IPCHE,IPCHE1,INFOS,IRTD)
  271.          IF (IRTD.EQ.0) GOTO 9990
  272. *
  273.          INFCHE(ISOUSS,1)=0
  274.          INFCHE(ISOUSS,2)=0
  275.          INFCHE(ISOUSS,3)=NHRM
  276.          INFCHE(ISOUSS,4)=MINTE
  277.          INFCHE(ISOUSS,5)=0
  278.          INFCHE(ISOUSS,6)=5
  279. *
  280. *        Activation du segment MINTE
  281. *
  282.          NBPGAU=POIGAU(/1)
  283. *
  284. *        Activation du segment MELEME
  285. *
  286.          NBNN  =NUM(/1)
  287.          NBELEM=NUM(/2)
  288.          IPPORE=0
  289.          IF(MFR.EQ.33) IPPORE=NBNN
  290. *
  291. *        Recherche des noms de composantes
  292. *
  293.          lsupre=.true.
  294.          IF (ICONT.EQ.1) THEN
  295.            if(lnomid(4).ne.0) then
  296.              nomid=lnomid(4)
  297.              mocomp=nomid
  298.              ncomp=lesobl(/2)
  299.              nfac=lesfac(/2)
  300.              lsupre=.false.
  301.            else
  302.              CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  303.            endif
  304.          ELSE IF (IDEFO.EQ.1) THEN
  305.              if(lnomid(5).ne.0) then
  306.               nomid=lnomid(5)
  307.               ncomp=lesobl(/2)
  308.               mocomp=nomid
  309.               lsupre=.false.
  310.              else
  311.               CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  312.              endif
  313.          ELSE IF (IDEFO.EQ.2) THEN
  314.             if(lnomid(13).ne.0) then
  315.               nomid=lnomid(13)
  316.               mocomp=nomid
  317.               ncomp=lesobl(/2)
  318.               nfac=lesfac(/2)
  319.               lsupre=.false.
  320.             else
  321.               CALL IDDEIN(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  322.             endif
  323.          ELSE IF (IVARI.EQ.1) THEN
  324.                if(lnomid(10).ne.0) then
  325.                 nomid=lnomid(10)
  326.                 mocomp=nomid
  327.                 ncomp=lesobl(/2)
  328.                 nfac=lesfac(/2)
  329.                 lsupre=.false.
  330.               else
  331.                CALL IDVARI(MFR,IMODEL,MOCOMP,NCOMP,NFAC)
  332.               endif
  333.          ENDIF
  334. *
  335. *        Verification de leur presence
  336. *
  337.          IF(IVARI.EQ.1.AND.LEPROB.EQ.0) THEN
  338.            NBTYPE=0
  339.            SEGINI NOTYPE
  340.            MOTYPE=NOTYPE
  341.          ELSE
  342.            NBTYPE=1
  343.            SEGINI NOTYPE
  344.            MOTYPE=NOTYPE
  345.            TYPE(1)='REAL*8'
  346.          ENDIF
  347. *
  348.          CALL KOMCHA(IPCHE,IPMAIL,CONM,MOCOMP,MOTYPE,1,INFOS,3,IVACOM)
  349.          SEGSUP NOTYPE
  350.          IF (IERR.NE.0) GOTO 9990
  351.          IF (ISUP.EQ.1) THEN
  352.             CALL VALCHE(IVACOM,NCOMP,IPMINT,IPPORE,MOCOMP,MELE)
  353.          ENDIF
  354. *
  355. *        Cas des variables internes
  356. *         Si rien a faire, on se contente de recopier la
  357. *         zone elementaire du MCHAML
  358. *
  359.          IF(IVARI.EQ.1.AND.LEPROB.EQ.0) THEN
  360.            MPTVAL=IVACOM
  361.            NCOS=IVAL(/1)
  362.            IE=0
  363.            DO 1021 ICOMP=1,NCOS
  364.              IF(IVAL(ICOMP).NE.0) IE=IE+1
  365. 1021       CONTINUE
  366. *
  367.            N2=IE
  368.            SEGINI MCHAML
  369.            ICHAML(ISOUSS)=MCHAML
  370.            NCOSOU=N2
  371.            NS=1
  372.            SEGINI MPTVA1
  373.            IVARES=MPTVA1
  374.            NOMID=MOCOMP
  375.            NBROBL=LESOBL(/2)
  376.            NBRFAC=LESFAC(/2)
  377.            IE=0
  378.            DO 1022 ICOMP=1,NCOMP
  379.              IF(IVAL(ICOMP).NE.0) THEN
  380.                IE=IE+1
  381.                IF(ICOMP.LE.NBROBL) THEN
  382.                  NOMCHE(IE)=LESOBL(ICOMP)
  383.                ELSE
  384.                  NOMCHE(IE)=LESFAC(ICOMP-NBROBL)
  385.                ENDIF
  386.                TYPCHE(IE)=TYVAL(ICOMP)
  387.                MELVA1=IVAL(ICOMP)
  388.                SEGINI,MELVAL=MELVA1
  389.                IELVAL(IE)=MELVAL
  390.                MPTVA1.IVAL(IE)=MELVAL
  391.              ENDIF
  392.  1022      CONTINUE
  393.            GO TO 510
  394.          ENDIF
  395. *
  396. *        Taille des MELVAL a allouer (champ non constant a priori)
  397. *
  398.          N1PTEL=NBGS
  399.          N1EL  =NBELEM
  400.          NBPTEL=N1PTEL
  401.          NEL   =N1EL
  402. *
  403. *        Creation du MCHAML pour la zone ISOUS
  404. *
  405.          N2=NCOMP
  406.          SEGINI MCHAML
  407.          ICHAML(ISOUSS)=MCHAML
  408.          NS=1
  409.          NCOSOU=NCOMP
  410.          SEGINI MPTVAL
  411.          IVARES=MPTVAL
  412.          NOMID=MOCOMP
  413.          DO 102 ICOMP=1,NCOMP
  414.             NOMCHE(ICOMP)=LESOBL(ICOMP)
  415.             TYPCHE(ICOMP)='REAL*8'
  416.             N2PTEL=0
  417.             N2EL=0
  418.             SEGINI MELVAL
  419.             IELVAL(ICOMP)=MELVAL
  420.             IVAL(ICOMP)=MELVAL
  421.  102     CONTINUE
  422. *
  423. *        Coordonnees des points caracterisant les
  424. *        reperes choisis (spherique, cylindrique, ...)
  425. *
  426.          lsupgd=.true.
  427.          IF (IMOT.NE.0) THEN
  428.             IF (IMOT.EQ.1) THEN
  429. *
  430. *              Coordonnees POLAIRES
  431. *
  432.                IF (IDIM.EQ.2) THEN
  433.                   IREF=(IPTV1-1)*(IDIM+1)
  434.                   CENTR1(1)=XCOOR(IREF+1)
  435.                   CENTR1(2)=XCOOR(IREF+2)
  436.                   DO 12 II=1,4
  437.                     V1(II)=0.D0
  438.  12               CONTINUE
  439.                ELSE
  440.                   CALL ERREUR(31)
  441.                   GOTO 9990
  442.                ENDIF
  443.             ELSE IF (IDIM.EQ.3) THEN
  444. *
  445. *              Autres coordonnees
  446. *
  447.                IREF1=(IPTV1-1)*(IDIM+1)
  448.                CENTR1(1)=XCOOR(IREF1+1)
  449.                CENTR1(2)=XCOOR(IREF1+2)
  450.                CENTR1(3)=XCOOR(IREF1+3)
  451.                IREF2=(IPTV2-1)*(IDIM+1)
  452.                AXEI1(1)=XCOOR(IREF2+1)
  453.                AXEI1(2)=XCOOR(IREF2+2)
  454.                AXEI1(3)=XCOOR(IREF2+3)
  455.                DO 103 IC=1,IDIM
  456.                   V1(IC)=AXEI1(IC)-CENTR1(IC)
  457.  103           CONTINUE
  458.                V1(4)=SQRT(V1(1)**2+V1(2)**2+V1(3)**2)
  459.                IF (V1(4).EQ.0.D0) THEN
  460.                   CALL ERREUR(277)
  461.                   GOTO 9990
  462.                ENDIF
  463.                DO 104 IC=1,IDIM
  464.                   V1(IC) = V1(IC) / V1(4)
  465.  104           CONTINUE
  466.                IF (IPTV3.NE.0) THEN
  467.                   IREF3=(IPTV3-1)*(IDIM+1)
  468.                   CENTR2(1)=XCOOR(IREF3+1)
  469.                   CENTR2(2)=XCOOR(IREF3+2)
  470.                   CENTR2(3)=XCOOR(IREF3+3)
  471.                ENDIF
  472.             ENDIF
  473.          ELSE IF (ICAS.EQ.2) THEN
  474. *
  475. *           Repere cartesien (IPCHE1 = 0 et IMOT = 0)
  476. *
  477.             IF (IDIM.EQ.2) THEN
  478.                IREF=(IPTV1-1)*(IDIM+1)
  479.                V1(1)=XCOOR(IREF+1)
  480.                V1(2)=XCOOR(IREF+2)
  481.                V1(4)=SQRT(V1(1)**2+V1(2)**2)
  482.                IF (V1(4).EQ.0.) THEN
  483.                   CALL ERREUR(277)
  484.                   GOTO 9990
  485.                ENDIF
  486.             ELSE IF (IDIM.EQ.3) THEN
  487.                IREF1=(IPTV1-1)*(IDIM+1)
  488.                V1(1)=XCOOR(IREF1+1)
  489.                V1(2)=XCOOR(IREF1+2)
  490.                V1(3)=XCOOR(IREF1+3)
  491.                V1(4)=SQRT(V1(1)**2+V1(2)**2+V1(3)**2)
  492.                IF (V1(4).EQ.0.D0) THEN
  493.                   CALL ERREUR(277)
  494.                   GOTO 9990
  495.                ENDIF
  496.                IF (IPTV2.NE.0) THEN
  497.                   IREF2=(IPTV2-1)*(IDIM+1)
  498.                   V2(1)=XCOOR(IREF2+1)
  499.                   V2(2)=XCOOR(IREF2+2)
  500.                   V2(3)=XCOOR(IREF2+3)
  501.                   V2(4)=SQRT(V2(1)**2+V2(2)**2+V2(3)**2)
  502.                   IF (V2(4).EQ.0.D0) THEN
  503.                      CALL ERREUR(277)
  504.                      GOTO 9990
  505.                   ENDIF
  506.                   W3(1)=(V1(2)*V2(3)-V1(3)*V2(2))/(V1(4)*V2(4))
  507.                   W3(2)=(V1(3)*V2(1)-V1(1)*V2(3))/(V1(4)*V2(4))
  508.                   W3(3)=(V1(1)*V2(2)-V1(2)*V2(1))/(V1(4)*V2(4))
  509.                   W2(1)=(W3(2)*V1(3)-W3(3)*V1(2))/V1(4)
  510.                   W2(2)=(W3(3)*V1(1)-W3(1)*V1(3))/V1(4)
  511.                   W2(3)=(W3(1)*V1(2)-W3(2)*V1(1))/V1(4)
  512.                ENDIF
  513.             ENDIF
  514.          ELSEIF (ICAS.EQ.1) THEN
  515. *
  516. *        On veut le tenseur dans le repere d'orthotropie. Il est
  517. *        stocke pour chaque element dans un MCHAML de CARACTERISTIQUES
  518. *        (IMOT = 0 et IPCHE1 <> 0)
  519. *
  520.             IF (MFR.EQ.1 .OR. MFR.EQ.31) THEN
  521.                IF (IDIM.EQ.2) THEN
  522.                   NBROBL=2
  523.                   NBRFAC=0
  524.                   SEGINI NOMID
  525.                   MOVEC=NOMID
  526.                   LESOBL(1)='V1X '
  527.                   LESOBL(2)='V1Y '
  528.                ELSE
  529.                   NBROBL=6
  530.                   NBRFAC=0
  531.                   SEGINI NOMID
  532.                   MOVEC=NOMID
  533.                   LESOBL(1)='V1X '
  534.                   LESOBL(2)='V1Y '
  535.                   LESOBL(3)='V1Z '
  536.                   LESOBL(4)='V2X '
  537.                   LESOBL(5)='V2Y '
  538.                   LESOBL(6)='V2Z '
  539.                ENDIF
  540.             ELSE IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  541.                NBROBL=2
  542.                NBRFAC=0
  543.                SEGINI NOMID
  544.                MOVEC=NOMID
  545.                LESOBL(1)='V1X '
  546.                LESOBL(2)='V1Y '
  547.             ENDIF
  548.             NVEC = NBROBL+NBRFAC
  549.             NBTYPE=1
  550.             SEGINI NOTYPE
  551.             MOTYPE=NOTYPE
  552.             TYPE(1)='REAL*8'
  553.             CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOVEC,MOTYPE,
  554.      &                  1,INFOS,3,IVAVEC)
  555.             SEGSUP NOTYPE
  556.             IF (IERR.NE.0) GOTO 9990
  557. *
  558. *        cas du champ de gradient
  559. *
  560.          ELSE IF (ICAS.EQ.4) THEN
  561. *
  562. *        On veut tourner le tenseur la matrice contenue dans
  563. *        un MCHAML de GRADIENT  ( IPCHE1 )
  564.         if(lnomid(3).ne.0) then
  565.            nomid=lnomid(3)
  566.            movec=nomid
  567.            nvec=lesobl(/2)
  568.            nfac=lesfac(/2)
  569.            lsupgd=.false.
  570.         else
  571.            CALL IDGRAD(MFR,IFOUR,MOVEC,NVEC,NFAC)
  572.            lsupgd=.true.
  573.         endif
  574. *
  575. *       VERIFICATION DE LEUR PRESENCE
  576. *
  577.             NBTYPE=1
  578.             SEGINI NOTYPE
  579.             MOTYPE=NOTYPE
  580.             TYPE(1)='REAL*8'
  581.             CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOVEC,MOTYPE,
  582.      &                  1,INFOS,3,IVAVEC)
  583.             SEGSUP NOTYPE
  584.             IF (IERR.NE.0) GOTO 9990
  585. *
  586.          ENDIF
  587. *
  588.          IF (ICAS.NE.1.AND.MFR.EQ.5) THEN
  589. *
  590. *           Caracteristiques pour les coques epaisses
  591. *
  592.             NBROBL = 1
  593.             NBRFAC = 0
  594.             SEGINI NOMID
  595.             MOEP = NOMID
  596.             LESOBL(1) = 'EPAI'
  597.             NVEC = NBROBL + NBRFAC
  598.             NBTYPE = 1
  599.             SEGINI NOTYPE
  600.             MOTYPE = NOTYPE
  601.             TYPE(1) = 'REAL*8'
  602.             CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOEP,MOTYPE,
  603.      &                  1,INFOS,3,IVAEP)
  604.             SEGSUP NOTYPE
  605.             IF (IERR.NE.0) GOTO 9990
  606.          ENDIF
  607. *
  608. *        MASSI COQUE COQEP POUT  CIST  THER  TUYAU LISP
  609. *
  610.          GOTO (10,66,30,66,50,66,66,66,90,66,66,66,66,66,66),MFR
  611.          IF (MFR.EQ.31.or.MFR.EQ.63) GOTO 10
  612. *
  613.   66     CONTINUE
  614.          MOTERR(1:8)=NOMFR(MFR)
  615.          CALL ERREUR(194)
  616.          GOTO 9990
  617.  10      CONTINUE
  618. *
  619. *        Formulations massive et incompressible
  620. *
  621.          IF (ICAS.EQ.4) THEN
  622. *
  623. *          cas du champ de gradient
  624. *
  625.            CALL RTENS6(IPCHE1,IFOMEM,MELEME,IVAVEC,IVACOM,IVARES,
  626.      &                 IDEF,MINTE,MELE,NPINT,NVEC,KMOT)
  627.            IF(IERR.NE.0) GO TO 9990
  628.          ELSE
  629. *
  630. *          autres cas
  631. *
  632.            CALL RTENS1(IPCHE1,IFOMEM,IMOT,IPTV2,MELEME,
  633.      &                 IVAVEC,IVACOM,IVARES,IDEF,MINTE,MELE,NPINT,
  634.      &                 NVEC,V1,V2,W2,W3,CENTR1,CENTR2,AXEI1,IER1)
  635.            IF (IER1.NE.0) GOTO 9990
  636.          ENDIF
  637.          GOTO 510
  638.   30     CONTINUE
  639. *
  640. *        Formulation coque (COQ2, COQ3, DKT ...)
  641. *
  642.          IF (IFOMEM.LT.2) THEN
  643.             CALL ERREUR(339)
  644.             GOTO 9990
  645.          ENDIF
  646.         CALL RTENS2(IPCHE1,IFOMEM,IMOT,IPTV2,MELEME,IVAVEC,IVACOM,
  647.      &              IVARES,IDEF,MINTE,MELE,NPINT,NVEC,V1,V2,W2,W3,
  648.      &              CENTR1,CENTR2,AXEI1,IER1)
  649.          IF (IER1.NE.0) GOTO 9990
  650.          GOTO 510
  651.   50     CONTINUE
  652. *
  653. *        Formulation coque epaisse (COQ6, COQ8 ...)
  654. *
  655.          CALL RTENS3(IPCHE1,IFOMEM,IMOT,IPTV2,MELEME,IVAVEC,IVACOM,
  656.      &               IVARES,IVAEP,IDEF,MINTE,MINTE1,MELE,NPINT,NVEC,
  657.      &               V1,V2,W2,W3,CENTR1,CENTR2,AXEI1,ICAS,IER1)
  658.          IF (IER1.NE.0) GOTO 9990
  659.          GOTO 510
  660.   90     CONTINUE
  661. *
  662. *        Formulation coque avec cisaillement transverse
  663. *        (COQ4, DST ...)
  664. *
  665.          IF (IFOMEM.LT.2) THEN
  666.             CALL ERREUR(339)
  667.             GOTO 9990
  668.          ENDIF
  669.          CALL RTENS4(IPCHE1,IFOMEM,IMOT,IPTV2,MELEME,IVAVEC,IVACOM,
  670.      &               IVARES,IDEF,MINTE,MELE,NPINT,NVEC,V1,V2,W2,W3,
  671.      &               CENTR1,CENTR2,AXEI1,ICAS,IER1)
  672.          IF (IER1.NE.0) GOTO 9990
  673.          GOTO 510
  674. *
  675. *        Desactivation des segments de la zone ISOUS
  676. *
  677.   510    CONTINUE
  678. *
  679.          IF (ISUP.EQ.1) THEN
  680.            CALL DTMVAL(IVACOM,3)
  681.          ELSE
  682.            CALL DTMVAL(IVACOM,1)
  683.          ENDIF
  684.          CALL DTMVAL(IVARES,1)
  685.          CALL DTMVAL(IVAVEC,1)
  686. *
  687.          NOMID=MOCOMP
  688.          if(lsupre)SEGSUP NOMID
  689.          NOMID=MOVEC
  690.          IF (NOMID.NE.0.and.lsupgd) SEGSUP NOMID
  691.          NOMID = MOEP
  692.          IF (NOMID.NE.0) SEGSUP NOMID
  693. *
  694. *        Fin de la boucle sur les zones du MCHAML
  695. *
  696.   500 CONTINUE
  697.  
  698.       IF (N1.NE.ISOUSS) then
  699.         N1=ISOUSS
  700.         SEGADJ MCHELM
  701.       ENDIF
  702.       RETURN
  703. *
  704.  9990 CONTINUE
  705. *
  706. *     Erreur dans une zone : desactivation puis retour
  707. *
  708.       CALL DTMVAL(IVACOM,1)
  709.       IF (ISUP.EQ.1) THEN
  710.         CALL DTMVAL(IVARES,3)
  711.       ELSE
  712.         CALL DTMVAL(IVARES,1)
  713.       ENDIF
  714.       CALL DTMVAL(IVAVEC,1)
  715. *
  716.       NOMID=MOCOMP
  717.       IF (NOMID.NE.0.and.lsupre) SEGSUP NOMID
  718.       NOMID=MOVEC
  719.       IF (NOMID.NE.0.and.lsupgd) SEGSUP NOMID
  720.       NOMID = MOEP
  721.       IF (NOMID.NE.0) SEGSUP NOMID
  722.  
  723.       IF (ISOUS.GT.1) SEGSUP MCHAML
  724. *
  725.       SEGSUP MCHELM
  726.       END
  727.  
  728.  
  729.  
  730.  
  731.  
  732.  
  733.  

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