Télécharger la plaquette Cast3M


fr en

Télécharger fpmass.eso

Retour à la liste

Numérotation des lignes : 

fpmass

  1. C FPMASS    SOURCE    JK148537  24/11/05    21:15:04     12066          
  2.       SUBROUTINE FPMASS(IPCHE1,IPCHM1,IPMODL,IPTFP,JPMAIL,XP,IRET)
  3. C_____________________________________________________________________
  4. C
  5. C   CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES MASSIFS
  6. C
  7. C   ENTREES :
  8. C   ---------
  9. C
  10. C    IPCHE1   CHPOINT CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  11. C              DE LA FACE D UN MASSIF
  12. C    IPCHM1   CHAMELEM CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  13. C              DE LA FACE D UN MASSIF
  14. C    IPMODL   OBJET MODELE  SUR LEQUEL S APPLIQUE LA PRESSION
  15. C
  16. C    JPMAIL   POINTEUR SUR LE MAILLAGE SI ON A LU UN FLOTTANT ET
  17. C             UN MAILLAGE, SINON 0
  18. C
  19. C    XP       LA VALEUR DE LA PRESSION SI ON L'A LUE
  20. C
  21. C  SORTIES  :
  22. C  ----------
  23. C
  24. C    IPTFP  = CHPOINT DES FORCES NODALES EQUIVALENTES
  25. C    IRET   = 1 OU 0 SUIVANT SUCCES OU NON
  26. C
  27. C     REVISION JACQUELINE BROCHARD  SEPTEMBRE 86
  28. C     MISE A JOUR P VERPEAUX MAI 88
  29. C
  30. C     PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 17 09 90
  31. C_______________________________________________________________________
  32.  
  33.       IMPLICIT INTEGER(I-N)
  34.       IMPLICIT REAL*8(A-H,O-Z)
  35.  
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. -INC CCREEL
  39. -INC CCHAMP
  40.  
  41. -INC SMCOORD
  42. -INC SMELEME
  43. -INC SMMODEL
  44. -INC SMCHAML
  45. -INC SMCHPOI
  46. -INC SMINTE
  47.  
  48.       SEGMENT INFO
  49.         INTEGER INFELL(JG)
  50.       ENDSEGMENT
  51.  
  52.       SEGMENT NOTYPE
  53.         CHARACTER*16 TYPE(NBTYPE)
  54.       ENDSEGMENT
  55.  
  56.       SEGMENT MPTVAL
  57.         INTEGER IPOS(NS)    ,NSOF(NS)
  58.         INTEGER      IVAL(NCOSOU)
  59.         CHARACTER*16 TYVAL(NCOSOU)
  60.       ENDSEGMENT
  61.  
  62.       segment netn(nbpts+1)
  63.       segment ietn(letn)
  64.  
  65.       DIMENSION V(3),F(3)
  66.       CHARACTER*4 MOSTRI,MOAPPU,MOGEOM
  67.       CHARACTER*(NCONCH) CONM
  68.       PARAMETER (NINF=3)
  69.       INTEGER INFOS(NINF)
  70.       LOGICAL LSUPFO,ltelq
  71.       CHARACTER*8 MOFO
  72.  
  73.       DATA MOAPPU/'APPU'/,MOSTRI/'STRI'/
  74.       DATA MOGEOM/'GEOM'/
  75.  
  76.       IRET = 0
  77.       IGEOM = 0
  78.  
  79.       NHRM=NIFOUR
  80.       IPTVPR=0
  81.  
  82.       IPCHE2 = 0
  83.       ISUPCA = 0
  84. C Prevoir la lecture en amont !
  85.       CALL LIROBJ('MCHAML  ',IPCHE2,0,IRT3)
  86.       IF (IERR.NE.0) RETURN
  87.       IF (IPCHE2.NE.0) THEN
  88.         CALL ACTOBJ('MCHAML  ',IPCHE2,1)
  89.         IF (IERR.NE.0) RETURN
  90.  
  91.         CALL REDUAF(IPCHE2,MODORI,ipche20,0,iretca,kerr)
  92.         if (iretca.ne.1) call erreur(kerr)
  93.         IF (IERR.NE.0) RETURN
  94.         IPCHE2 = ipche20
  95. C
  96. C   Verification du lieu support du MCHAML de caracteristiques
  97. C
  98.         CALL QUESUP(IPMODL,IPCHE2,3,1,ISUPCA,iretca)
  99.         IF (ISUPCA.GT.1) RETURN
  100.       ENDIF
  101. C
  102. C     CAS OU UN CHPOP EST FOURNI
  103. C     ON CREE L OBJET GEOMETRIQUE CONTENANT TOUS LES PTS SI BESOIN
  104. C
  105.       IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) THEN
  106.         MCHPOI=IPCHE1
  107.         DO 50 I=1,IPCHP(/1)
  108.            MSOUPO=IPCHP(I)
  109.            IF (I.GT.1) THEN
  110.               ltelq=.false.
  111.               CALL FUSE(IGEOM,IGEOC,IPPT,ltelq)
  112.               IGEOM=IPPT
  113.            ELSE
  114.               IGEOM=IGEOC
  115.            ENDIF
  116.  50     CONTINUE
  117.         IF (IERR.NE.0) RETURN
  118.       ENDIF
  119. C
  120. C     CAS OU UN CHAMELEM EST FOURNI
  121. C     ON CREE L OBJET GEOMETRIQUE CONTENANT TOUS LES PTS SI BESOIN
  122. C
  123.       IF (IPCHM1.NE.0) THEN
  124.         MCHEL2 = IPCHM1
  125.         DO 60 I=1,MCHEL2.IMACHE(/1)
  126.           IMTMP=MCHEL2.IMACHE(I)
  127.           IF (I.GT.1) THEN
  128.             ltelq=.false.
  129.             CALL FUSE(IGEOM,IMTMP,IPPT,ltelq)
  130.             IGEOM=IPPT
  131.           ELSE
  132.             IGEOM=IMTMP
  133.           ENDIF
  134.  60     CONTINUE
  135.         IF (IERR.NE.0) RETURN
  136.       ENDIF
  137.  
  138.       idimp1=IDIM+1
  139. C= Cas des modes de calculs en DEFORMATIONS GENERALISEES
  140.       IF (IFOUR.EQ.-3) THEN
  141.         NDPGE=3
  142.       ELSE IF (IFOUR.EQ.11) THEN
  143.         NDPGE=2
  144.       ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ. 9.OR.
  145.      .         IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  146.         NDPGE=1
  147.       ELSE
  148.         NDPGE=0
  149.       ENDIF
  150.  
  151.       nbtype = 1
  152.       SEGINI,notype
  153.       notype.TYPE(1) = 'REAL*8  '
  154.       MOTYR8 = notype
  155. C
  156. C     ACTIVATION DU MODEL
  157. C
  158.       MMODEL=IPMODL
  159.       NSOUS=KMODEL(/1)
  160.  
  161.       IRRT=0
  162.       DO 100 ISOUS=1,NSOUS
  163. C
  164.          ISOK = 0
  165. C
  166. C        ON RECUPERE L INFORMATION GENERALE
  167. C
  168.          IMODEL=KMODEL(ISOUS)
  169.          IPMAIL=IMAMOD
  170.          CONM  =CONMOD
  171. C
  172. C        TRAITEMENT DU MODEL
  173. C
  174.          MELM=NEFMOD
  175. C         write(*,*) ISOUS,'/',NSOUS,' : ',IMODEL,'NEFMOD=',MELM
  176.          if ((melm . eq . 22).OR.(melm . eq . 259)) then
  177. C      ... Ici sous modele de multiplicateur de lagrange on
  178. C          incrémente le compteur et on passe à la zone suivante ...
  179.             IRRT=IRRT+1
  180.             go to 100
  181.          endif
  182. C
  183. C        ON RECUPERE LES ELTS DE L ENVELOPPE DU MASSIF APPUYES
  184. C        STRICTEMENT SUR LE CHPOINT DE PRESSIONS OU appartenant au
  185. C        MAILLAGE DONNE
  186. C
  187.          CALL ECROBJ('MAILLAGE',IPMAIL)
  188.          IF (IDIM.EQ.2) THEN
  189.            CALL PRCONT
  190.          ELSE IF (IDIM.EQ.3) THEN
  191.            CALL ENVELO
  192.          ELSE IF (IDIM.EQ.1) THEN
  193.            CALL PREX1D
  194.          ENDIF
  195.          IF (IERR.NE.0) GOTO 9900
  196.          CALL LIROBJ('MAILLAGE',ienvel,1,IRETOU)
  197.          IF (IERR .NE. 0) GOTO 9900
  198.          CALL ACTOBJ('MAILLAGE',ienvel,1)
  199. C     ... si un CHPOINT a été donné, on va chercher la partie de
  200. C         l'enveloppe s'appuyant strictement sur le support du CHPOINT ...
  201.            IF(JPMAIL.EQ.0) THEN
  202.               CALL ECROBJ('MAILLAGE',IGEOM)
  203.               CALL ECRCHA(MOSTRI)
  204.               CALL ECRCHA(MOAPPU)
  205.               CALL ECROBJ('MAILLAGE',ienvel)
  206.               CALL EXTREL (IRR,0,IBNOR)
  207.            ELSE
  208. C      ... sinon, on va chercher l'intersection de l'enveloppe avec
  209. C          le maillage fourni ...
  210.               CALL INTERB(ienvel,jpmail,irr,IPOGEO)
  211.            ENDIF
  212. C      ... Ici on teste si intersection est vide, si OUI on
  213. C          incrémente le compteur et on passe à la zone suivante ...
  214.            IF (irr.gt.0) THEN
  215.               IRRT=IRRT+1
  216.               GOTO 100
  217.            ENDIF
  218.            IF(JPMAIL.EQ.0) THEN
  219.              CALL LIROBJ('MAILLAGE',IPOGEO,1,iret)
  220.              IF (IERR.NE.0) GOTO 9900
  221.              CALL ACTOBJ('MAILLAGE',IPOGEO,1)
  222.            ENDIF
  223. C
  224. C     ON DETERMINE LA FORMULATION ASSOCIEE A L OBJET
  225. C     GEOMETRIQUE ELEMENTAIRE DE SURFACE
  226. C
  227.          IPT3 = IPOGEO
  228.          NBSOU3 = IPT3.LISOUS(/1)
  229.          IPT2=IPT3
  230. C
  231. C     BOUCLE SUR LES SOUS ZONES DE L ENVELOPPE
  232. C
  233.       DO 110 IB=1,MAX(1,NBSOU3)
  234.  
  235.          MOCARA = 0
  236.          IVACAR = 0
  237.          IVAFOR = 0
  238.          IPMOD1 = 0
  239.          ISOK = 0
  240.  
  241.          IF (NBSOU3.NE.0) THEN
  242.             IPT2=IPT3.LISOUS(IB)
  243.          ENDIF
  244.          IPOGEO=IPT2
  245.  
  246.          NBNN  = IPT2.NUM(/1)
  247.          LETYP = IPT2.ITYPEL
  248. C
  249. C        PETIT TEST SUR LE TYPE
  250. C
  251.          IF (LETYP.EQ.1.AND.IDIM.NE.1) THEN
  252.             CALL ERREUR(16)
  253.             GOTO 9990
  254.          ENDIF
  255. C
  256.          CALL TYPFAC(MELM,NBNN,MELE)
  257. C          write(*,*) 'TYPFAC --> MELE=',MELE
  258.          IF (MELE.EQ.0) THEN
  259. C
  260. C        ERREUR : IMPOSSIBLE D UTILISER L OPERATEUR PRESSI POUR
  261. C                 LES ELEMENTS DE FORMULATION MELM
  262. C
  263.             MOTERR(1:8)=NOMTP(MELM)
  264.             CALL ERREUR(193)
  265.             GOTO 9990
  266.          ENDIF
  267. C
  268. C        CAS OU UN CHAMP PAR POINT A ETE FOURNI
  269. C        ON CREE L OBJET MODEL ASSOCIE A LA SURFACE ELEMENTAIRE
  270. C
  271.          IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) THEN
  272.            N1=1
  273.            SEGINI MMODE1
  274.            IPMOD1=MMODE1
  275.            NFOR=FORMOD(/2)
  276.            NMAT=MATMOD(/2)
  277. c*           MN3=INFMOD(/1)
  278.            MN3=1
  279.            NPARMO=0
  280.            nobmod=0
  281.            SEGINI IMODE1
  282.            MMODE1.KMODEL(1)=IMODE1
  283.            IMODE1.IMAMOD=IPOGEO
  284.            IMODE1.NEFMOD=MELE
  285.            IMODE1.CONMOD=CONMOD
  286.            DO 10 I=1,NFOR
  287.               IMODE1.FORMOD(I)=FORMOD(I)
  288.  10        CONTINUE
  289.            DO 11 I=1,NMAT
  290.               IMODE1.MATMOD(I)=MATMOD(I)
  291.  11        CONTINUE
  292. c*           DO I=1,MN3
  293. c*              IMODE1.INFMOD(I)=INFMOD(I)
  294. c*           ENDDO
  295. c*           call inomid(imode1,lzero,lzero,lzero,lzero)
  296. c*           call prquoi(imode1)
  297. C
  298. C            ON TRANSFORME LE CHPOINT DE PRESSION EN CHELEM ELEMENTAIRE
  299. C
  300.              CALL CHAME1(0,IPMOD1,IPCHE1,' ',ICHELP,3)
  301.              IF (IERR.NE.0) GOTO 9990
  302.              MCHEL1=ICHELP
  303.              MCHAM1=MCHEL1.ICHAML(1)
  304.              IPTVPR=MCHAM1.IELVAL(1)
  305.  
  306.          ENDIF
  307. C
  308. C        INFORMATION SUR L'ELEMENT FINI
  309. C
  310.          CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  311. Cbp : on aurait voulu faire CALL ELQUOI(MELE,0,3,IPINF,IMODE1),
  312. C   : mais cela ne marche evidemment pas bien...
  313.          IF (IERR.NE.0) GOTO 9990
  314.          INFO=IPINF
  315.          IPTINT=INFELL(11)
  316.          MFR   =INFELL(13)
  317. C*OF En DIMEnsion 1, on force FORMULATION MASSIVE pour POI1
  318.          IF (IDIM.EQ.1.AND.MELE.EQ.45) MFR=1
  319.          IPPORE=0
  320.          IF(MFR.EQ.33) IPPORE=NBNN
  321. C Destruction immediate du segment
  322.          SEGSUP,INFO
  323. C Caracteristiques d'integration
  324.          MINTE=IPTINT
  325. C
  326. C        CAS OU UN CHAMP PAR ELEMENT A ETE FOURNI
  327. C        -> Verification de son support
  328. C
  329.          IF (IPCHM1.NE.0) THEN
  330.            CALL QUESUP(0,IPCHM1,0,0,ISUP1,ISUP2)
  331.            MCHEL2=IPCHM1
  332.            MCHAM2 = MCHEL2.ICHAML(1)
  333.            IF (ISUP2.NE.3) THEN
  334.              IF (ISUP2.EQ.4) THEN
  335.                CALL ERREUR(609)
  336.                GOTO 9990
  337.              ELSE IF (ISUP2.EQ.5) THEN
  338.                IPTVPR = MCHAM2.IELVAL(1)
  339.              ELSE IF (ISUP2.EQ.1.OR.ISUP2.EQ.2) THEN
  340.                IVPRES = MCHAM2.IELVAL(1)
  341.                CALL VALMEL(IVPRES,IPTINT,IPTVPR)
  342.              ENDIF
  343.            ELSE
  344.              IPTVPR = MCHAM2.IELVAL(1)
  345.            ENDIF
  346.          ENDIF
  347. C
  348. C        INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES
  349. C
  350.          N1=1
  351.          L1=6
  352.          N3=6
  353.          SEGINI MCHELM
  354.          TITCHE='FORCES'
  355.          IFOCHE=IFOUR
  356.          IPCHEL=MCHELM
  357. C
  358.          IMACHE(1)=IPOGEO
  359.          INFCHE(1,1)=0
  360.          INFCHE(1,2)=0
  361.          INFCHE(1,3)=NHRM
  362.          INFCHE(1,4)=IPTINT
  363.          INFCHE(1,5)=0
  364.          INFCHE(1,6)=3
  365. C
  366. C        RECHERCHE DE LA TAILLE DES MELVALS
  367. C
  368.          MELEME=IPOGEO
  369.          N1PTEL=NUM(/1)
  370.          N1EL  =NUM(/2)
  371.          N2PTEL=0
  372.          N2EL  =0
  373. C
  374. C        RECHERCHE DES NOM DE COMPOSANTES
  375. C
  376.         if(lnomid(2).ne.0) then
  377.           nomid=lnomid(2)
  378.           moforc=nomid
  379.           nfor=lesobl(/2)
  380.           nfac=0
  381.           lsupfo=.false.
  382. C           write(*,*) 'nomid deja existant dans IMODEL',IMODEL
  383.         else
  384.          lsupfo=.true.
  385.          CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC)
  386.            write(*,*) 'FPMASS : appel a IDFORC pour creer nomid'
  387.         endif
  388.          NCOMP=NFOR-NDPGE
  389. C**      IF (IFOUR.EQ.-3) NCOMP=NFOR-3
  390. C
  391. C        CREATION DU MCHAML DE LA SOUS ZONE
  392. C
  393.          N2=NCOMP
  394.          SEGINI MCHAML
  395.          ICHAML(1)=MCHAML
  396.          NS=1
  397.          NCOSOU=NCOMP
  398.          SEGINI MPTVAL
  399.          IVAFOR=MPTVAL
  400.          NOMID=MOFORC
  401.  
  402. Cbp      on verifie qu on a suffisamment de composantes d'effort
  403.          NFO=0
  404.          IF(MELE.EQ.2.OR.MELE.EQ.3) NFO=2
  405.          IF(MELE.EQ.31.OR.MELE.EQ.32.OR.MELE.EQ.33.OR.MELE.EQ.34) NFO=3
  406.          IF(MELE.EQ.45) NFO=1
  407. C          IF(NFO.eq.0) --> erreur + tard
  408.          IF(NFO.ne.0) THEN
  409.            IF(NCOMP.lt.NFO) GOTO 444
  410.            DO 44 ICOMP=1,NFO
  411.               MOFO=LESOBL(ICOMP)
  412.               IF(MOFO(1:1).NE.'F') GOTO 444
  413.  44        CONTINUE
  414. C          pas d'erreur ?
  415.            GOTO 440
  416. C         -erreur
  417.  444       CONTINUE
  418.            WRITE(IOIMP,*) 'on attend un MODELE avec au moins',NFO,
  419.      &    'composantes de FORCES !'
  420.            write(IOIMP,*) 'Ici, on a :',(LESOBL(iou),iou=1,NCOMP)
  421.            MOTERR(1:16)='MECANIQUE, ...  '
  422.            CALL ERREUR(719)
  423.            GOTO 9990
  424. C         -pas d'erreur
  425.  440       CONTINUE
  426.          ENDIF
  427.  
  428.          DO 4 ICOMP=1,NCOMP
  429.             NOMCHE(ICOMP)=LESOBL(ICOMP)
  430.             TYPCHE(ICOMP)='REAL*8'
  431.             SEGINI MELVAL
  432.             IELVAL(ICOMP)=MELVAL
  433.             IVAL(ICOMP)=MELVAL
  434.  4       CONTINUE
  435. C____________________________________________________________________
  436. C
  437. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  438. C____________________________________________________________________
  439.          IF (IPCHE2.NE.0 .AND. IFOUR.EQ.-2) THEN
  440. C
  441. C        CREATION DU TABLEAU INFOS
  442. C
  443.              CALL IDENT (IPMAIL,CONM,IPCHE2,0,INFOS,IRTD)
  444.              IF (IRTD.EQ.0) GOTO 9990
  445. C
  446.              NBROBL=0
  447.              NBRFAC=1
  448.              SEGINI NOMID
  449.              MOCARA=NOMID
  450.              LESFAC(1)='DIM3'
  451. C
  452.              CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYR8,0,
  453.      +                                       INFOS,3,IVACAR)
  454.              IF (IERR.NE.0) GOTO 9990
  455.              NCARA=NBROBL
  456.              NCARF=NBRFAC
  457.              NCARR=NCARA+NCARF
  458. C
  459.              IF (ISUPCA.EQ.1) THEN
  460.                CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  461.                IF (IERR.NE.0) THEN
  462.                  ISUPCA = 0
  463.                  GOTO 9990
  464.                ENDIF
  465.              ENDIF
  466. C
  467.          ENDIF
  468. C
  469.          MELEME=IPOGEO
  470.          IPT1=IPMAIL
  471. C
  472. C  pour accelerer la recherche, utilisation d'un tableau des elements touchant un noeud.
  473.          segact mcoord
  474.          segini netn
  475.          do 1050 j=1,ipt1.num(/2)
  476.           do 1050 i=1,ipt1.num(/1)
  477.            netn(ipt1.num(i,j))=netn(ipt1.num(i,j))+1
  478.  1050    continue
  479.          do 1060 i=2,netn(/1)
  480.             netn(i)=netn(i)+netn(i-1)
  481.  1060    continue
  482.          letn=netn(netn(/1))
  483.          segini ietn
  484.          do 1070 j=1,ipt1.num(/2)
  485.           do 1070 i=1,ipt1.num(/1)
  486.            ietn(netn(ipt1.num(i,j)))=j
  487.            netn(ipt1.num(i,j))=netn(ipt1.num(i,j))-1
  488.  1070     continue
  489.           ietn1 = ietn
  490.           netn1 = netn
  491.  
  492. C        CALCUL DES FORCES NODALES EQUIVALENTES
  493. C        DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  494. C
  495.          IF (MELE.EQ.2.OR.MELE.EQ.3) THEN
  496. C
  497. C           CAS DES ELEMENTS MASSIFS BIDIMENSIONNELS
  498. C           FACES ASSOCIEES SEG2 OU SEG3
  499. C
  500.             CALL FPMA2D(IPTVPR,IPOGEO,ipt1,IPTINT,IVAFOR,IVACAR,XP
  501.      +                   ,netn1,ietn1)
  502. C
  503.          ELSE IF(MELE.EQ.31.OR.MELE.EQ.32.OR.MELE.EQ.33.
  504.      +                                   OR.MELE.EQ.34)THEN
  505. C
  506. C           CAS DES ELEMENTS MASSIFS TRIDIMENSIONNELS
  507. C           FACES ASSOCIEES FAC3,FAC4,FAC6 OU FAC8
  508. C
  509.             CALL FPMA3D(IPTVPR,IPOGEO,ipt1,IPTINT,IVAFOR,XP
  510.      +                  ,netn1,ietn1)
  511. C
  512. C= Cas des elements MASSIFs UNIDIMENSIONNELs (1D)
  513. C= Face associee : POI1 (numero 45)
  514.          ELSE IF (MELE.EQ.45) THEN
  515.             CALL FPMA1D(IPTVPR,IPOGEO,ipt1,IPTINT,IVAFOR,XP
  516.      +                  ,netn1,ietn1)
  517.  
  518.          ELSE
  519. C
  520. C           ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  521. C
  522.             MOTERR(1:4)=NOMTP(MELE)
  523.             MOTERR(5:12)='FPMASS'
  524.             CALL ERREUR (86)
  525.             GOTO 9990
  526.          ENDIF
  527. C
  528. C        POUR CHAQUE ELEMENT,
  529. C        ON DETERMINE UN VECTEUR DIRIGE VERS L INTERIEUR DU MASSIF
  530. C        A PARTIR D UN POINT DE LA FACE ET DU CENTRE DE GRAVITE DU MASSI
  531. C
  532. C   prob optimiseur il faut initialiser melva1
  533.          MELVA1=IPMODL
  534.          IF(IPTVPR.NE.0) THEN
  535.            MELVA1=IPTVPR
  536.          ENDIF
  537.          DO 150 IEF=1,NUM(/2)
  538.             NBM=IPT1.NUM(/1)
  539.             NBMA1=NUM(/1)
  540.             MPTVAL=IVAFOR
  541.             DO 220 INF=1,N1PTEL
  542.                DO 220 ICOMP=1,NCOMP
  543.                   MELVAL=IVAL(ICOMP)
  544.                   VELCHE(INF,IEF)=VELCHE(INF,IEF)
  545.  220        CONTINUE
  546.  150     CONTINUE
  547.          segsup netn,ietn
  548. C
  549. C        ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN
  550. C        ET ON ADDITIONNE LES CHAM/POIN ELEMENTAIRES
  551. C
  552.          CALL CHAMPO(IPCHEL,0,IPCHPO,IPPT)
  553.          CALL DTCHAM(IPCHEL)
  554.          IF (IPPT.EQ.0) THEN
  555.             GOTO 9990
  556.          ENDIF
  557.          IF ((ISOUS-IRRT).GT.1.OR.IB.GT.1) THEN
  558.             CALL ADCHPO(IPCHPO,IPTFP,IPPT,1D0,1D0)
  559. C            CALL ECRCHA(MOGEOM)
  560.             CALL DTCHPO(IPCHPO)
  561. C            CALL ECRCHA(MOGEOM)
  562.             CALL DTCHPO(IPTFP)
  563.             IF (IPPT.EQ.0) GOTO 9990
  564.             IPTFP=IPPT
  565.          ELSE
  566.             IPTFP=IPCHPO
  567.          ENDIF
  568.  
  569.          ISOK = 1
  570.  
  571.  9990    CONTINUE
  572.          NOMID=MOFORC
  573.          if (lsupfo .AND. NOMID.NE.0) SEGSUP,NOMID
  574.          MPTVAL=IVAFOR
  575.          IF (mptval.NE.0) SEGSUP,MPTVAL
  576.          IF (IVACAR.NE.0) THEN
  577.            IF (ISUPCA.EQ.1) THEN
  578.              CALL DTMVAL(IVACAR,3)
  579.            ELSE
  580.              CALL DTMVAL(IVACAR,1)
  581.            ENDIF
  582.          ENDIF
  583.          NOMID = MOCARA
  584.          IF (MOCARA.NE.0) SEGSUP,NOMID
  585.          IF (IPMOD1.NE.0) CALL DTMODL(IPMOD1)
  586.  
  587.          IF (ISOK.EQ.0) GOTO 9900
  588.  
  589.  110   CONTINUE
  590.  
  591.  9900  IF (ISOK.EQ.0) GOTO 9000
  592.  
  593.  100  CONTINUE
  594.  
  595.       IF (IRRT.EQ.KMODEL(/1)) THEN
  596.          IRET = 0
  597.          CALL ERREUR(395)
  598.       ELSE
  599.          IRET = 1
  600.       ENDIF
  601.  
  602.  9000 CONTINUE
  603.       notype = MOTYR8
  604.       SEGSUP,notype
  605.  
  606.       RETURN
  607.       END
  608.  
  609.  
  610.  

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