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    OF166741  25/02/21    21:16:36     12166          
  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.INFELE(12)
  431. *        IPTNOE = imodel.INFMOD(8)
  432.         IPPORE=0
  433.         IF (MFR.EQ.33) IPPORE=NBNN
  434. *
  435. *        RECHERCHE DU MELVAL DU CHAMELEM DE PRESSION
  436. *
  437. *       CREATION DU TABLEAU INFO
  438.         CALL IDENT(IPMAIL,CONM,IPCH1,0,INFOS,IRTD)
  439.         IF (IRTD.EQ.0) GOTO 910
  440. *
  441.         CALL KOMCHA(IPCH1,IPMAIL,CONM,MOSCAL,MOTYR8,1,INFOS,3,IVASCA)
  442.         IF (IERR.NE.0) GOTO 910
  443.         MPTVAL = IVASCA
  444.         IPTVPR = IVAL(1)
  445. *
  446. *     CHANGEMENT EVENTUEL DU SUPPORT DANS LE CAS OU UN MCHAML A ETE FOURNI
  447. *
  448.         IF (IPCHM1.NE.0) THEN
  449.           IF (ISUP2.EQ.4) THEN
  450.             CALL ERREUR(609)
  451.             GOTO 910
  452.           ELSE IF (ISUP2.EQ.1) THEN
  453.             IVPRES = IPTVPR
  454.             CALL VALMEL(IVPRES,IPTINT,IPTVPR)
  455.           ENDIF
  456.         ENDIF
  457. *
  458. *        RECHERCHE DES NOMS DE COMPOSANTES
  459. *
  460.         nomid = imodel.LNOMID(2)
  461.         if (nomid.ne.0) then
  462.           MOFORC=nomid
  463.           nfor=lesobl(/2)
  464.           nfac=0
  465.         else
  466.           CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC)
  467.           write(ioimp,*) 'FPCOQU : MOFORC = 0'
  468.           call erreur(5)
  469.         endif
  470.         NCOMP=NFOR
  471.         IF (IFOUR.EQ.-3) NCOMP=NFOR-3
  472. *
  473. *        CREATION DU MCHAML DE LA SOUS ZONE
  474. *
  475.          IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45.OR.MELE.EQ.93) THEN
  476.             N1PTEL=3
  477.          ELSE IF (MELE.EQ.44) THEN
  478.             N1PTEL=2
  479.          ELSE IF (MELE.EQ.49.OR.MELE.EQ.41.OR.MELE.EQ.56) THEN
  480.             N1PTEL=NBNN
  481.          ELSE
  482. *
  483. *           ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  484. *
  485.             MOTERR(1:4)=NOMTP(MELE)
  486.             MOTERR(5:12)='FPCOQU  '
  487.             CALL ERREUR(86)
  488.             GOTO 910
  489.          ENDIF
  490. *
  491.          N1EL=NBELEM
  492.          N2PTEL=0
  493.          N2EL  =0
  494.          N2=NCOMP
  495.          SEGINI MCHAML
  496.          NSR=1
  497.          NCOSOR=NCOMP
  498.          SEGINI MPTVAL
  499.          IVAFOR=MPTVAL
  500.          NOMID=MOFORC
  501.          DO 4 ICOMP=1,NCOMP
  502.             NOMCHE(ICOMP)=LESOBL(ICOMP)
  503.             TYPCHE(ICOMP)='REAL*8'
  504.             SEGINI MELVAL
  505.             IELVAL(ICOMP)=MELVAL
  506.             IVAL(ICOMP)=MELVAL
  507.  4       CONTINUE
  508. *_______________________________________________________________________
  509. *
  510. *          CALCUL DES FORCES NODALES EQUIVALENTES
  511. *        DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  512. *_______________________________________________________________________
  513. *
  514.       IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45
  515.      1                     .OR.MELE.EQ.93) THEN
  516. *
  517. *        ELEMENTS COQ3 , DKT OU DKTC
  518. *        ---------------------------
  519.          CALL FPCO3D(IPTVPR,IPMAIL,IVAFOR)
  520.       ELSE IF (MELE.EQ.44) THEN
  521. *
  522. *        ELEMENT COQ2
  523. *        ------------
  524. *
  525. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES
  526. *
  527.          IF (IFOUR.EQ.-2 .AND.IPCHE2.NE.0) THEN
  528. *
  529. *        CREATION DU TABLEAU INFO
  530. *
  531.              CALL IDENT(IPMAIL,CONM,IPCHE2,0,INFOS,IRTD)
  532.              IF (IRTD.EQ.0) GOTO 910
  533.  
  534.              NBROBL=0
  535.              NBRFAC=1
  536.              SEGINI NOMID
  537.              LESFAC(1)='DIM3'
  538.  
  539.              NCARA=NBROBL
  540.              NCARF=NBRFAC
  541.              NCARR=NCARA+NCARF
  542.              MOCARA = NOMID
  543.  
  544.              CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYR8,0,
  545.      +                                       INFOS,3,IVACAR)
  546.              IF (IERR.NE.0) GOTO 910
  547. *
  548.              IF (ISUP.EQ.1) THEN
  549.                CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  550.              ENDIF
  551.          ENDIF
  552. *
  553.          CALL FPCO2D (IPTVPR,IPMAIL,IVAFOR,IVACAR)
  554. *
  555. *        ELEMENTS COQ4
  556. *        -------------
  557.       ELSE IF (MELE.EQ.49) THEN
  558.          CALL FPCOQ4(IPTVPR,IPMAIL,IPTINT,IVAFOR)
  559. *
  560. *        ELEMENTS COQ6 OU COQ8
  561. *        ---------------------
  562.       ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  563.          IF (IPCHE2.EQ.0) THEN
  564. * Message a affiner
  565.            write(ioimp,*) 'Manque CARACTERISTIQUES COQ6&COQ8'
  566.            CALL ERREUR(21)
  567.            GOTO 910
  568.          ENDIF
  569. *____________________________________________________________________
  570. *
  571. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  572. *              CARACTERISTIQUES POUR LES COQ8 ET COQ6
  573. *____________________________________________________________________
  574. *
  575.          NBROBL=1
  576.          NBRFAC=0
  577.          SEGINI NOMID
  578.          LESOBL(1)='EPAI'
  579.  
  580.          NCARA=NBROBL
  581.          NCARF=NBRFAC
  582.          NCARR=NCARA+NCARF
  583.          MOCARA=NOMID
  584.  
  585.          IF (IFLAG.EQ.0) THEN
  586. *
  587. *           ON RECUPERE LE IMAMOD DU MMODEL D'ORIGINE POUR QUE LE IPMAIL
  588. *           DONNE CORRESPONDE A CELUI DE IPCHE21
  589. *
  590.             DO 60 KISOUS=1,NSOUS1
  591.                IF (IPMAIL.EQ.MAIL2(KISOUS)) THEN
  592.                   IPMAI1=MAIL1(KISOUS)
  593.                   GOTO 61
  594.                ENDIF
  595.  60         CONTINUE
  596. *
  597. *           NE DOIT NORMALEMENT JAMAIS SE PRODUIRE
  598. *
  599.             CALL ERREUR(472)
  600.             GOTO 910
  601. 61         CONTINUE
  602.          ELSE
  603.            IPMAI1=IPMAIL
  604.          ENDIF
  605.  
  606.          CALL KOMCHA(IPCHE2,IPMAI1,CONM,MOCARA,MOTYR8,1,INFOS,3,IVACAR)
  607.          IF (IERR.NE.0) GOTO 910
  608.  
  609.          IF (ISUPCA.EQ.1) THEN
  610.             CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  611.          ENDIF
  612.  
  613.          CALL FPCOQ8(IPTVPR,IPMAIL,IPTINT,IVACAR,IPTNOE,IVAFOR)
  614.  
  615.       ELSE
  616. *
  617. *        ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  618. *
  619.          MOTERR(1:4)=NOMTP(MELE)
  620.          MOTERR(5:12)='FPCOQU'
  621.          CALL ERREUR(86)
  622.          GOTO 910
  623.       ENDIF
  624. *
  625. *     INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES
  626. *
  627.         N1=1
  628.         L1=6
  629.         N3=6
  630.         SEGINI,MCHELM
  631.         IPCHEL=MCHELM
  632.         mchelm.TITCHE = 'FORCES'
  633.         mchelm.IFOCHE = IFOUR
  634.         mchelm.IMACHE(1) = IPMAIL
  635.         mchelm.CONCHE(1) = CONM
  636.         mchelm.ICHAML(1) = MCHAML
  637.         mchelm.INFCHE(1,1) = 0
  638.         mchelm.INFCHE(1,2) = 0
  639.         mchelm.INFCHE(1,3) = NHRM
  640.         mchelm.INFCHE(1,4) = IPTINT
  641.         mchelm.INFCHE(1,5) = 0
  642.         mchelm.INFCHE(1,6) = 3
  643. *
  644. *     ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN
  645. *
  646.         CALL CHAMPO(IPCHEL,0,IPCHPO,IRET)
  647.         CALL DTCHAM(IPCHEL)
  648.         IF (IRET.EQ.0) GOTO 910
  649.  
  650.         IF (ISOUS.GT.1) THEN
  651.           CALL ADCHPO(IPCHPO,IPTFP,IRET,1D0,1D0)
  652.           CALL DTCHPO(IPCHPO)
  653.           CALL DTCHPO(IPTFP)
  654.           IF (IRET.EQ.0) GOTO 910
  655.           IPTFP=IRET
  656.         ELSE
  657.           IPTFP=IPCHPO
  658.         ENDIF
  659.         ISOK = 1
  660.  
  661.  910    CONTINUE
  662.         IF (ISUPCA.EQ.1) THEN
  663.           CALL DTMVAL(IVACAR,3)
  664.         ELSE
  665.           CALL DTMVAL(IVACAR,1)
  666.         ENDIF
  667.         MPTVAL = IVASCA
  668.         IF (mptval.NE.0) SEGSUP,MPTVAL
  669.  
  670.         MPTVAL = IVAFOR
  671.         IF (mptval.NE.0) SEGSUP,MPTVAL
  672.  
  673.         NOMID = MOCARA
  674.         IF (nomid.NE.0) SEGSUP,NOMID
  675.  
  676. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  677.         IF (ISOK .NE. 1) GOTO 9997
  678.  
  679.  100  CONTINUE
  680.  
  681.       IRET = 1
  682. *
  683. *  FIN :
  684.  9997 CONTINUE
  685.       notype = MOTYR8
  686.       SEGSUP,notype
  687.       nomid = MOSCAL
  688.       SEGSUP,nomid
  689.  
  690.  9990 CONTINUE
  691.       IF (IFLAG.EQ.0) CALL DTMODL(IPMOD)
  692.       IF (JPMAIL.NE.0) SEGSUP,JPMAIL
  693.  
  694.       RETURN
  695.       END
  696.  
  697.  
  698.  

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