Télécharger la plaquette Cast3M


fr en

Télécharger fpcoqu.eso

Retour à la liste

Numérotation des lignes : 

fpcoqu

  1. C FPCOQU    SOURCE    MB234859  25/09/08    21:15:27     12358          
  2.  
  3.       SUBROUTINE FPCOQU(P,IPCHE1,IPCHM1,IPMODL,JMLU,IPTFP,IRET)
  4. *_____________________________________________________________________
  5. *
  6. *   CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES COQUES
  7. *
  8. *   ENTREES :
  9. *   ---------
  10. *
  11. *    P        VALEUR DE LA PRESSION SI ELLE EST CONSTANTE
  12. *    IPCHE1   CHPOINT CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  13. *    IPCHM1   CHAMELEM CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  14. *    ICONV    FLAG DE CONVERSION
  15. *    IPMODL   OBJET AFFECTE SUR LEQUEL S APPLIQUE LA PRESSION
  16. *    JMLU     1 SI MOT CLE NORMAL
  17. *             0 SINON IL FAUT APPELER PRORIE
  18. *             0   SI LE MOT CLE NORM A ETE INDIQUE
  19. *
  20. *   SORTIES :
  21. *   ---------
  22. *
  23. *    IPTFP    CHPOINT DES FORCES NODALES EQUIVALENTES
  24. *    IRET     1 OU 0 SUIVANT SUCCES OU NON
  25. *_____________________________________________________________________
  26.  
  27.       IMPLICIT INTEGER(I-N)
  28.       IMPLICIT REAL*8(A-H,O-Z)
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC CCHAMP
  33.  
  34. -INC SMCOORD
  35. -INC SMELEME
  36. -INC SMMODEL
  37. -INC SMCHAML
  38. -INC SMCHPOI
  39. -INC SMINTE
  40.  
  41. -INC TMPTVAL
  42.  
  43.       SEGMENT NOTYPE
  44.         CHARACTER*16 TYPE(NBTYPE)
  45.       ENDSEGMENT
  46.  
  47. *   Segment donnant le pointeur de maillage correcte au MCHAML de
  48. *   caracteristique apres creation d'un MMODEL
  49.       SEGMENT JPMAIL
  50.         INTEGER MAIL1 (NSOUS1)
  51.         INTEGER MAIL2 (NSOUS1)
  52.       ENDSEGMENT
  53.  
  54.       CHARACTER*8 MOT
  55.       CHARACTER*(NCONCH) CONM
  56.       PARAMETER (NINF=3)
  57.       INTEGER INFOS(NINF)
  58.       logical ltelq
  59.       INTEGER ISUPCA
  60.  
  61.       DATA MOT/'RIGIDITE'/
  62.  
  63.       IRET = 0
  64.  
  65.       IGEOM= 0
  66.  
  67.       lzero = 0
  68.  
  69.       nbtype = 1
  70.       SEGINI,notype
  71.       notype.TYPE(1) = 'REAL*8  '
  72.       MOTYR8 = notype
  73.  
  74.       nbrobl = 1
  75.       nbrfac = 0
  76.       SEGINI,nomid
  77.       nomid.LESOBL(1) = 'SCAL    '
  78.       MOSCAL = nomid
  79.  
  80.       NHRM=NIFOUR
  81.  
  82.       IFLAG=0
  83.       IVACAR=0
  84.       JPMAIL=0
  85.  
  86. * CHAMP PAR ELEMENT des CARACTERISTIQUES
  87.       IPCHE2 = 0
  88.       ISUPCA = 0
  89.       CALL LIROBJ('MCHAML  ',IPCHE2,0,IRT3)
  90.       IF (IERR.NE.0) RETURN
  91.  
  92. *     LE FLAG SERT A INDIQUER SI L'ON DOIT OU NON DETRUIRE LE MODELE
  93. *     EN CAS DE CREATION  ( 0 : DESTRUCTION D'UN MMODEL CREE )
  94.  
  95.       IF (IPCHE1.NE.0.OR.IPCHM1.NE.0) THEN
  96. *
  97. *        ON CREE LE MMODEL S'ACCROCHANT AU CHPOINT
  98. *
  99. *        ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHPOINT
  100. *
  101.          IF (IPCHE1.NE.0) THEN
  102.            CALL NOMCOM(IPCHE1,'SCAL',IPCHE,IRETOU)
  103.            IF (IERR.NE.0) RETURN
  104.            MCHPOI=IPCHE
  105.            SEGACT MCHPOI
  106.            NSOUPO=IPCHP(/1)
  107.            IPGEOM = 0
  108.            DO 1140 I=1,NSOUPO
  109.               MSOUPO=IPCHP(I)
  110.               SEGACT MSOUPO
  111.               IF (IPGEOM.EQ.0) THEN
  112.                  IPGEOM = IGEOC
  113.               ELSE
  114.                  IPP2 = IGEOC
  115.                  ltelq=.false.
  116.                  CALL FUSE (IPGEOM,IPP2,IPPT,ltelq)
  117.                  IPGEOM = IPPT
  118.               ENDIF
  119. 1140       CONTINUE
  120. *
  121. *        ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHAMELEM
  122. *
  123.          ELSE
  124.            CALL ECROBJ('MCHAML  ',IPCHM1)
  125.            CALL ECRCHA('SCAL')
  126.            CALL NOMC
  127.            IF (IERR.NE.0) RETURN
  128.            CALL LIROBJ('MCHAML  ',IPCHE,1,IRETOU)
  129.            IF (IERR.NE.0) RETURN
  130.            MCHEL2=IPCHE
  131.            SEGACT MCHEL2
  132.            DO 1150 I=1,MCHEL2.IMACHE(/1)
  133.              IMTMP=MCHEL2.IMACHE(I)
  134.              IF (I.GT.1) THEN
  135.                ltelq=.false.
  136.                CALL FUSE (IPGEOM,IMTMP,IPPT,ltelq)
  137.                IPGEOM = IPPT
  138.              ELSE
  139.                IPGEOM = IMTMP
  140.              ENDIF
  141. 1150       CONTINUE
  142.          ENDIF
  143.          IF (IERR.NE.0) RETURN
  144.  
  145.          N1=0
  146.          SEGINI MMODEL
  147.          IPMOD=MMODEL
  148.  
  149.          MMODE1=IPMODL
  150.          NSOUS1=MMODE1.KMODEL(/1)
  151.  
  152. *      BOUCLE SUR LES SOUS ZONE GEOMETRIQUES ELEMENTAIRES
  153.          IRRT=0
  154.          DO 50 ISOUS=1,NSOUS1
  155.             IMODE1=MMODE1.KMODEL(ISOUS)
  156.             ITGEOM=IMODE1.IMAMOD
  157.             CALL ECROBJ('MAILLAGE',IPGEOM)
  158.             CALL ECRCHA('STRI')
  159.             CALL ECRCHA('APPU')
  160.             CALL ECROBJ('MAILLAGE',ITGEOM)
  161.             CALL EXTREL(IRR,0,IBNOR)
  162.             IF (IRR.EQ.0) THEN
  163. *
  164. *              ON A VERIFIER L ADHERENCE DU CHPOINT A CE MAILLAGE
  165. *
  166.                CALL LIROBJ('MAILLAGE',IPOGEO,1,IRETOU)
  167.                IF (IERR.NE.0) THEN
  168.                   SEGSUP MMODEL
  169.                   RETURN
  170.                ENDIF
  171.                N1=N1+1
  172.                SEGADJ MMODEL
  173. *
  174. *              CREATION DE L'OBJET IMODEL DE CETTE SOUS ZONE
  175. *
  176.                NFOR=IMODE1.FORMOD(/2)
  177.                NMAT=IMODE1.MATMOD(/2)
  178.                MN3 =IMODE1.INFMOD(/1)
  179.                NPARMO=0
  180.                nobmod=0
  181.                SEGINI IMODEL
  182.                conmod(1:24)='        '
  183.                IMAMOD=IPOGEO
  184.                NEFMOD=IMODE1.NEFMOD
  185.                CONMOD=IMODE1.CONMOD
  186.                IPDPGE=IMODE1.IPDPGE
  187. *
  188. *              CREATION D'UN TABLEAU DE CORRESPONDANCE LE IMAMOD DU
  189. *              MMODEL (IPMODL) ET DU IMAMOD DU NVX MMODEL QUE L'ON CREE
  190. *              (UTILISE DANS LE KOMCHA POUR LE MCHAML DE CARATERISTIQUE
  191. *              POUR LES COQ6 ET COQ8)
  192. *
  193.                IF (NEFMOD.EQ.41.OR.NEFMOD.EQ.56) THEN
  194.                   IF (JPMAIL.EQ.0) SEGINI JPMAIL
  195.                   MAIL1(ISOUS)=ITGEOM
  196.                   MAIL2(ISOUS)=IPOGEO
  197.                ENDIF
  198.                DO 47 I=1,MN3
  199.                   INFMOD(I)=IMODE1.INFMOD(I)
  200.  47            CONTINUE
  201.                CONMOD=IMODE1.CONMOD
  202.                DO 48 I=1,NFOR
  203.                   FORMOD(I)=IMODE1.FORMOD(I)
  204.  48            CONTINUE
  205.                DO 49 I=1,NMAT
  206.                   MATMOD(I)=IMODE1.MATMOD(I)
  207.  49            CONTINUE
  208.                KMODEL(N1)=IMODEL
  209.                call inomid(imodel,lzero,lzero,lzero,lzero)
  210.                call prquoi(imodel)
  211.             ELSE
  212. *
  213. *              LE CHPOINT OU CHAMELEM N'ADHERE PAS A CETTE ZONE
  214. *
  215.                IRRT=IRRT+1
  216.             ENDIF
  217.  50      CONTINUE
  218. *
  219.          IF (NSOUPO.GT.1) THEN
  220.             MELEME=IPGEOM
  221.             SEGSUP MELEME
  222.          ENDIF
  223. *
  224.          IF (IRRT.EQ.NSOUS1) THEN
  225. *
  226. *           L'OBJET MAILLAGE ET LE CHPOINT OU CHAMELEM SONT INCOMPATIBLES
  227. *
  228.             MOTERR(1:8)='MAILLAGE'
  229.             IF (IPCHE1.NE.0) THEN
  230.               MOTERR(9:16)='CHPOINT'
  231.             ELSE
  232.               MOTERR(9:16)='CHAMELEM'
  233.             ENDIF
  234.             CALL ERREUR(135)
  235.             MMODEL=IPMOD
  236.             SEGSUP MMODEL
  237.             IF (JPMAIL.NE.0) SEGSUP JPMAIL
  238.             RETURN
  239.          ENDIF
  240.          IPMODI=IPMOD
  241.       ELSE
  242.          IPMODI=IPMODL
  243.          IFLAG=1
  244.       ENDIF
  245. *
  246. *-------EN 3D  ET DANS LE CAS OU NORM N'A PAS ETE INDIQUE
  247. *              ON CHARGE PRORIE DE REORIENTER LES ELEMENTS
  248. *
  249.       IF (IDIM.EQ.3.AND.JMLU.EQ.0) THEN
  250.          MMODE1=IPMODI
  251.          NSOUS=MMODE1.KMODEL(/1)
  252.          N1=NSOUS
  253.          SEGINI MMODEL
  254.          IPMOD=MMODEL
  255.          NBELEM=0
  256.          NBNN=0
  257.          NBREF=0
  258.          NBSOUS=NSOUS
  259.          SEGINI MELEME
  260.          DO 9 ISOUS=1,NSOUS
  261.             IMODEL=MMODE1.KMODEL(ISOUS)
  262.             LISOUS(ISOUS)=IMAMOD
  263.  9       CONTINUE
  264. *
  265. *        MAILLAGE A REORIENTER
  266. *
  267.          CALL ECROBJ('MAILLAGE',MELEME)
  268. *
  269. *        ORIENTATION PRORIE LIT LES DONNEES QUI LE CONCERNE
  270. *
  271.          CALL PRORIE
  272. *
  273. *        MAILLAGE REORIENTE
  274. *
  275.          CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  276.          IF (IERR.NE.0) THEN
  277.             SEGSUP MMODEL
  278.             IF (IFLAG.EQ.0) CALL DTMODL(IPMODI)
  279.             IF (JPMAIL.NE.0) SEGSUP JPMAIL
  280.             RETURN
  281.          ENDIF
  282.          SEGACT MELEME
  283.          DO 10 ISOUS=1,NSOUS
  284.             IMODE1=MMODE1.KMODEL(ISOUS)
  285.             SEGACT IMODE1
  286.             NFOR=IMODE1.FORMOD(/2)
  287.             NMAT=IMODE1.MATMOD(/2)
  288.             MN3 =IMODE1.INFMOD(/1)
  289.             NPARMO=0
  290.             nobmod=0
  291.             SEGINI IMODEL
  292.             conmod(1:24)='        '
  293.             KMODEL(ISOUS)=IMODEL
  294. *
  295. *           IMAMOD REORIENTE
  296. *
  297.             IMAMOD=LISOUS(ISOUS)
  298.             NEFMOD=IMODE1.NEFMOD
  299.             CONMOD=IMODE1.CONMOD
  300.             IPDPGE=IMODE1.IPDPGE
  301. *
  302. *           MISE A JOUR DU TABLEAU DE CORRESONDANCE DES IMAMOD
  303. *
  304.             IF (NEFMOD.EQ.41.OR.NEFMOD.EQ.56) THEN
  305.                IF (JPMAIL.EQ.0) THEN
  306.                   NSOUS1=NSOUS
  307.                   SEGINI JPMAIL
  308.                ENDIF
  309.                IF (IFLAG.EQ.1) MAIL1(ISOUS)=IMODE1.IMAMOD
  310.                MAIL2(ISOUS)=IMAMOD
  311.             ENDIF
  312.             CONMOD=IMODE1.CONMOD
  313.             DO 1 I=1,NFOR
  314.                FORMOD(I)=IMODE1.FORMOD(I)
  315.  1          CONTINUE
  316.             DO 2 I=1,NMAT
  317.                MATMOD(I)=IMODE1.MATMOD(I)
  318.  2          CONTINUE
  319.             DO 3 I=1,MN3
  320.                INFMOD(I)=IMODE1.INFMOD(I)
  321.  3          CONTINUE
  322.             IF (IFLAG.NE.1) THEN
  323.                SEGSUP IMODE1
  324.             ENDIF
  325.             call inomid(imodel,lzero,lzero,lzero,lzero)
  326.             call prquoi(imodel)
  327.  10      CONTINUE
  328.          IF (IFLAG.NE.1) SEGSUP MMODE1
  329.          IFLAG=0
  330.       ELSE
  331.          IPMOD=IPMODI
  332.       ENDIF
  333. *
  334. *     EN 2D ET EN 3D , ON VERIFIE QUE 2 ELEMENTS ADJACENTS
  335. *     ONT LA MEME ORIENTATION
  336. *
  337.       MMODEL=IPMOD
  338.       DO 11 ISOUS=1,KMODEL(/1)
  339.          IMODEL=KMODEL(ISOUS)
  340.          IF (ISOUS.GT.1) THEN
  341.             IPTGEO=IMAMOD
  342.             ltelq=.false.
  343.             CALL FUSE(IGEOM,IPTGEO,IPPT,ltelq)
  344.             IGEOM=IPPT
  345.          ELSE
  346.             IGEOM=IMAMOD
  347.          ENDIF
  348. 11    CONTINUE
  349.       CALL ECROBJ('MAILLAGE',IGEOM)
  350.       CALL VERSEN
  351.       CALL LIROBJ('MAILLAGE',IGEOM,1,IRETOU)
  352.       IF (IERR.NE.0) GOTO 9990
  353.  
  354.       IF (KMODEL(/1).GT.1) THEN
  355.          MELEME=IGEOM
  356.          SEGSUP MELEME
  357.       ENDIF
  358. *
  359. *     ON TRANSFORME LE CHPOINT DE PRESSION EN CHELEM
  360. *
  361.       IF (IPCHE1.EQ.0.AND.IPCHM1.EQ.0) THEN
  362.         CALL ZEROP(IPMOD,MOT,IPCH1)
  363.         IF (IERR.NE.0) RETURN
  364.         MCHEL1=IPCH1
  365.         SEGACT MCHEL1
  366.         NSOUS=MCHEL1.ICHAML(/1)
  367.         DO 12 ISOUS=1,NSOUS
  368.            MCHAM1=MCHEL1.ICHAML(ISOUS)
  369.            SEGACT MCHAM1
  370.            MELVA1=MCHAM1.IELVAL(1)
  371.            SEGACT MELVA1*MOD
  372.            N1PTEL=MELVA1.VELCHE(/1)
  373.            N1EL  =MELVA1.VELCHE(/2)
  374.            DO IB=1,N1EL
  375.              DO IGAU=1,N1PTEL
  376.                MELVA1.VELCHE(IGAU,IB)=P
  377.              ENDDO
  378.            ENDDO
  379.  12     CONTINUE
  380.       ELSE IF (IPCHE1.NE.0) THEN
  381. *
  382. *        On transforme le CHPOINT en MCHAML aux pts de Gauss pour la rigidite
  383. *
  384.          CALL CHAME1(0,IPMOD,IPCHE,' ',IPCH1,3)
  385.          IF (IERR.NE.0) GOTO 9990
  386.       ELSE
  387. *
  388. *       On change eventuellement le support du MCHAML
  389. *
  390.         CALL QUESUP(0,IPCHE,0,0,ISUP1,ISUP2)
  391.         IPCH1=IPCHE
  392.       ENDIF
  393.  
  394. *   Verification du lieu support du MCHAML de caracteristiques
  395.       IF (IPCHE2.NE.0) THEN
  396.         CALL QUESUP(IPMODL,IPCHE2,3,1,ISUPCA,iretca)
  397.         IF (ISUPCA.GT.1) GOTO 9990
  398.       ENDIF
  399.  
  400. *     ACTIVATION DU MODEL
  401. *
  402.       MMODEL=IPMOD
  403.       NSOUS=KMODEL(/1)
  404.  
  405.       DO 100 ISOUS=1,NSOUS
  406.  
  407.         IVAFOR=0
  408.         IVASCA=0
  409.         IVACAR=0
  410.         MOCARA = 0
  411. *
  412. *     TRAITEMENT DU MODEL
  413. *
  414.         IMODEL=KMODEL(ISOUS)
  415. *
  416. *     ON RECUPERE L INFORMATION GENERALE
  417. *
  418.         IPMAIL = IMAMOD
  419.         CONM   = CONMOD
  420.         MELE   = NEFMOD
  421.  
  422.         MELEME = IPMAIL
  423.         NBELEM = meleme.NUM(/2)
  424.         NBNN   = meleme.NUM(/1)
  425. *
  426. *        INFORMATION SUR L ELEMENT FINI
  427. *
  428.         MFR    = imodel.INFELE(13)
  429.         IPTINT = imodel.INFMOD(5)
  430.         IPTNOE = imodel.INFMOD(3)
  431.         IPPORE=0
  432.         IF (MFR.EQ.33) IPPORE=NBNN
  433. *
  434. *        RECHERCHE DU MELVAL DU CHAMELEM DE PRESSION
  435. *
  436. *       CREATION DU TABLEAU INFO
  437.         CALL IDENT(IPMAIL,CONM,IPCH1,0,INFOS,IRTD)
  438.         IF (IRTD.EQ.0) GOTO 910
  439. *
  440.         CALL KOMCHA(IPCH1,IPMAIL,CONM,MOSCAL,MOTYR8,1,INFOS,3,IVASCA)
  441.         IF (IERR.NE.0) GOTO 910
  442.         MPTVAL = IVASCA
  443.         IPTVPR = IVAL(1)
  444. *
  445. *     CHANGEMENT EVENTUEL DU SUPPORT DANS LE CAS OU UN MCHAML A ETE FOURNI
  446. *
  447.         IF (IPCHM1.NE.0) THEN
  448.           IF (ISUP2.EQ.4) THEN
  449.             CALL ERREUR(609)
  450.             GOTO 910
  451.           ELSE IF (ISUP2.EQ.1) THEN
  452.             IVPRES = IPTVPR
  453.             CALL VALMEL(IVPRES,IPTINT,IPTVPR)
  454.           ENDIF
  455.         ENDIF
  456. *
  457. *        RECHERCHE DES NOMS DE COMPOSANTES
  458. *
  459.         nomid = imodel.LNOMID(2)
  460.         if (nomid.ne.0) then
  461.           MOFORC=nomid
  462.           nfor=lesobl(/2)
  463.           nfac=0
  464.         else
  465.           CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC)
  466.           write(ioimp,*) 'FPCOQU : MOFORC = 0'
  467.           call erreur(5)
  468.         endif
  469.         NCOMP=NFOR
  470.         IF (IFOUR.EQ.-3) NCOMP=NFOR-3
  471. *
  472. *        CREATION DU MCHAML DE LA SOUS ZONE
  473. *
  474.          IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45.OR.MELE.EQ.93) THEN
  475.             N1PTEL=3
  476.          ELSE IF (MELE.EQ.44) THEN
  477.             N1PTEL=2
  478.          ELSE IF (MELE.EQ.49.OR.MELE.EQ.41.OR.MELE.EQ.56) THEN
  479.             N1PTEL=NBNN
  480.          ELSE
  481. *
  482. *           ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  483. *
  484.             MOTERR(1:4)=NOMTP(MELE)
  485.             MOTERR(5:12)='FPCOQU  '
  486.             CALL ERREUR(86)
  487.             GOTO 910
  488.          ENDIF
  489. *
  490.          N1EL=NBELEM
  491.          N2PTEL=0
  492.          N2EL  =0
  493.          N2=NCOMP
  494.          SEGINI MCHAML
  495.          NSR=1
  496.          NCOSOR=NCOMP
  497.          SEGINI MPTVAL
  498.          IVAFOR=MPTVAL
  499.          NOMID=MOFORC
  500.          DO 4 ICOMP=1,NCOMP
  501.             NOMCHE(ICOMP)=LESOBL(ICOMP)
  502.             TYPCHE(ICOMP)='REAL*8'
  503.             SEGINI MELVAL
  504.             IELVAL(ICOMP)=MELVAL
  505.             IVAL(ICOMP)=MELVAL
  506.  4       CONTINUE
  507. *_______________________________________________________________________
  508. *
  509. *          CALCUL DES FORCES NODALES EQUIVALENTES
  510. *        DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  511. *_______________________________________________________________________
  512. *
  513.       IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45
  514.      1                     .OR.MELE.EQ.93) THEN
  515. *
  516. *        ELEMENTS COQ3 , DKT OU DKTC
  517. *        ---------------------------
  518.          CALL FPCO3D(IPTVPR,IPMAIL,IVAFOR)
  519.       ELSE IF (MELE.EQ.44) THEN
  520. *
  521. *        ELEMENT COQ2
  522. *        ------------
  523. *
  524. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES
  525. *
  526.          IF (IFOUR.EQ.-2 .AND.IPCHE2.NE.0) THEN
  527. *
  528. *        CREATION DU TABLEAU INFO
  529. *
  530.              CALL IDENT(IPMAIL,CONM,IPCHE2,0,INFOS,IRTD)
  531.              IF (IRTD.EQ.0) GOTO 910
  532.  
  533.              NBROBL=0
  534.              NBRFAC=1
  535.              SEGINI NOMID
  536.              LESFAC(1)='DIM3'
  537.  
  538.              NCARA=NBROBL
  539.              NCARF=NBRFAC
  540.              NCARR=NCARA+NCARF
  541.              MOCARA = NOMID
  542.  
  543.              CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYR8,0,
  544.      +                                       INFOS,3,IVACAR)
  545.              IF (IERR.NE.0) GOTO 910
  546. *
  547.              IF (ISUP.EQ.1) THEN
  548.                CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  549.              ENDIF
  550.          ENDIF
  551. *
  552.          CALL FPCO2D (IPTVPR,IPMAIL,IVAFOR,IVACAR)
  553. *
  554. *        ELEMENTS COQ4
  555. *        -------------
  556.       ELSE IF (MELE.EQ.49) THEN
  557.          CALL FPCOQ4(IPTVPR,IPMAIL,IPTINT,IVAFOR)
  558. *
  559. *        ELEMENTS COQ6 OU COQ8
  560. *        ---------------------
  561.       ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  562.          IF (IPCHE2.EQ.0) THEN
  563. * Message a affiner
  564.            write(ioimp,*) 'Manque CARACTERISTIQUES COQ6&COQ8'
  565.            CALL ERREUR(21)
  566.            GOTO 910
  567.          ENDIF
  568. *____________________________________________________________________
  569. *
  570. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  571. *              CARACTERISTIQUES POUR LES COQ8 ET COQ6
  572. *____________________________________________________________________
  573. *
  574.          NBROBL=1
  575.          NBRFAC=0
  576.          SEGINI NOMID
  577.          LESOBL(1)='EPAI'
  578.  
  579.          NCARA=NBROBL
  580.          NCARF=NBRFAC
  581.          NCARR=NCARA+NCARF
  582.          MOCARA=NOMID
  583.  
  584.          IF (IFLAG.EQ.0) THEN
  585. *
  586. *           ON RECUPERE LE IMAMOD DU MMODEL D'ORIGINE POUR QUE LE IPMAIL
  587. *           DONNE CORRESPONDE A CELUI DE IPCHE21
  588. *
  589.             DO 60 KISOUS=1,NSOUS1
  590.                IF (IPMAIL.EQ.MAIL2(KISOUS)) THEN
  591.                   IPMAI1=MAIL1(KISOUS)
  592.                   GOTO 61
  593.                ENDIF
  594.  60         CONTINUE
  595. *
  596. *           NE DOIT NORMALEMENT JAMAIS SE PRODUIRE
  597. *
  598.             CALL ERREUR(472)
  599.             GOTO 910
  600. 61         CONTINUE
  601.          ELSE
  602.            IPMAI1=IPMAIL
  603.          ENDIF
  604.  
  605.          CALL KOMCHA(IPCHE2,IPMAI1,CONM,MOCARA,MOTYR8,1,INFOS,3,IVACAR)
  606.          IF (IERR.NE.0) GOTO 910
  607.  
  608.          IF (ISUPCA.EQ.1) THEN
  609.             CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  610.          ENDIF
  611.  
  612.          CALL FPCOQ8(IPTVPR,IPMAIL,IPTINT,IVACAR,IPTNOE,IVAFOR)
  613.  
  614.       ELSE
  615. *
  616. *        ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  617. *
  618.          MOTERR(1:4)=NOMTP(MELE)
  619.          MOTERR(5:12)='FPCOQU'
  620.          CALL ERREUR(86)
  621.          GOTO 910
  622.       ENDIF
  623. *
  624. *     INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES
  625. *
  626.         N1=1
  627.         L1=6
  628.         N3=6
  629.         SEGINI,MCHELM
  630.         IPCHEL=MCHELM
  631.         mchelm.TITCHE = 'FORCES'
  632.         mchelm.IFOCHE = IFOUR
  633.         mchelm.IMACHE(1) = IPMAIL
  634.         mchelm.CONCHE(1) = CONM
  635.         mchelm.ICHAML(1) = MCHAML
  636.         mchelm.INFCHE(1,1) = 0
  637.         mchelm.INFCHE(1,2) = 0
  638.         mchelm.INFCHE(1,3) = NHRM
  639.         mchelm.INFCHE(1,4) = IPTINT
  640.         mchelm.INFCHE(1,5) = 0
  641.         mchelm.INFCHE(1,6) = 3
  642. *
  643. *     ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN
  644. *
  645.         CALL CHAMPO(IPCHEL,0,IPCHPO,IRET)
  646.         CALL DTCHAM(IPCHEL)
  647.         IF (IRET.EQ.0) GOTO 910
  648.  
  649.         IF (ISOUS.GT.1) THEN
  650.           CALL ADCHPO(IPCHPO,IPTFP,IRET,1D0,1D0)
  651.           CALL DTCHPO(IPCHPO)
  652.           CALL DTCHPO(IPTFP)
  653.           IF (IRET.EQ.0) GOTO 910
  654.           IPTFP=IRET
  655.         ELSE
  656.           IPTFP=IPCHPO
  657.         ENDIF
  658.         ISOK = 1
  659.  
  660.  910    CONTINUE
  661.         IF (ISUPCA.EQ.1) THEN
  662.           CALL DTMVAL(IVACAR,3)
  663.         ELSE
  664.           CALL DTMVAL(IVACAR,1)
  665.         ENDIF
  666.         MPTVAL = IVASCA
  667.         IF (mptval.NE.0) SEGSUP,MPTVAL
  668.  
  669.         MPTVAL = IVAFOR
  670.         IF (mptval.NE.0) SEGSUP,MPTVAL
  671.  
  672.         NOMID = MOCARA
  673.         IF (nomid.NE.0) SEGSUP,NOMID
  674.  
  675. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  676.         IF (ISOK .NE. 1) GOTO 9997
  677.  
  678.  100  CONTINUE
  679.  
  680.       IRET = 1
  681. *
  682. *  FIN :
  683.  9997 CONTINUE
  684.       notype = MOTYR8
  685.       SEGSUP,notype
  686.       nomid = MOSCAL
  687.       SEGSUP,nomid
  688.  
  689.  9990 CONTINUE
  690.       IF (IFLAG.EQ.0) CALL DTMODL(IPMOD)
  691.       IF (JPMAIL.NE.0) SEGSUP,JPMAIL
  692.  
  693.       RETURN
  694.       END
  695.  
  696.  
  697.  
  698.  

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