Télécharger la plaquette Cast3M


fr en

Télécharger formch.eso

Retour à la liste

Numérotation des lignes : 

formch

  1. C FORMCH    SOURCE    CB215821  24/04/12    21:16:01     11897          
  2.       SUBROUTINE FORMCH(IPMODL,IPCHEL,IRET,IPT,IPCH1)
  3. C
  4. C--------------------------------------------------------------------
  5. C
  6. C   REACTUALISATION DES CARACTERISTIQUES POUR CERTAINES FORMULATIONS
  7. C   ROUTINE APPELE PAR FOMM
  8. C
  9. C--------------------------------------------------------------------
  10. C
  11. C  ENTREES :
  12. C  ---------
  13. C
  14. C     IPMODL   POINTEUR SUR UN MMODEL
  15. C     IPCHEL   POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
  16. C     IPT      POINTEUR SUR UN CHPOINT
  17. C
  18. C
  19. C  SORTIE :
  20. C  --------
  21. C
  22. C     IRET      1 SI L'OPERATION EST POSSIBLE
  23. C               0 SI L'OPERATION EST IMPOSSIBLE
  24. C     IPCH1    POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUES
  25. C
  26. C
  27. C     PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 20 09 90
  28. C
  29. C-------------------------------------------------------------------
  30. C
  31.       IMPLICIT INTEGER(I-N)
  32.       IMPLICIT REAL*8(A-H,O-Z)
  33. -INC SMCHAML
  34. -INC SMCOORD
  35. -INC SMELEME
  36. -INC SMMODEL
  37.  
  38. -INC PPARAM
  39. -INC CCOPTIO
  40. -INC CCHAMP
  41. C
  42.       SEGMENT IWRK
  43.          REAL*8 XDDL(LRE),XE(3,NBNN),WORK(LW)
  44.       ENDSEGMENT
  45. C
  46.       SEGMENT INFO
  47.          INTEGER INFELL(JG)
  48.       ENDSEGMENT
  49. *
  50.       SEGMENT NOTYPE
  51.          CHARACTER*16 TYPE(NBTYPE)
  52.       ENDSEGMENT
  53. C
  54.       SEGMENT MPTVAL
  55.          INTEGER IPOS(NS)    ,NSOF(NS)
  56.          INTEGER      IVAL(NCOSOU)
  57.          CHARACTER*16 TYVAL(NCOSOU)
  58.       ENDSEGMENT
  59. C
  60.       CHARACTER*8 CMATE
  61.       CHARACTER*(NCONCH) CONM
  62.       PARAMETER ( NINF=3 )
  63.       INTEGER INFOS(NINF)
  64.       LOGICAL lsupdp
  65. C
  66. C
  67.       DIMENSION VECT(6)
  68. *
  69.       lsupdp=.TRUE.
  70. C
  71. C  ON VERIFIE QUE LE MCHAML DE CARACTERISTIQUE EST SUR SON SUPPORT
  72. C
  73.       CALL QUESUP (IPMODL,IPCHEL,3,1,ISUP,IRETCA)
  74.       IF (ISUP.NE.0) THEN
  75.          IRET=0
  76.          RETURN
  77.       ENDIF
  78. C
  79. C
  80. C     ON COPIE LE CHAMELEM DE CARACTERISTIQUES
  81. C
  82.       CALL COPIE8(IPCHEL,IPCH1)
  83. C
  84. C     ON CONVERTIT LE CHAMP POINT EN CHAMP PAR ELEMENT
  85. C
  86.       CALL  CHAME1(0,IPMODL,IPT,' ',IPCHAM1,1)
  87.       IF (IERR.NE.0) THEN
  88.          CALL DTCHAM(IPCH1)
  89.          IRET=0
  90.          RETURN
  91.       ENDIF
  92. C
  93. C     ACTIVATION DU MODELE
  94. C
  95.       IRET=1
  96.       MMODEL=IPMODL
  97.       SEGACT MMODEL
  98.       NSOUS=KMODEL(/1)
  99.       NSOU1=NSOUS
  100. C____________________________________________________________________
  101. C
  102. C  BOUCLE SUR LES SOUS-ZONES
  103. C____________________________________________________________________
  104. C
  105.       DO 200 ISOUS=1,NSOU1
  106.          KERRE=0
  107.          IVACAR=0
  108.          IVACA1=0
  109.          IVADEP=0
  110. C
  111. C        ON RECUPERE L INFORMATION GENERALE
  112. C
  113.          IMODEL=KMODEL(ISOUS)
  114.          SEGACT IMODEL
  115.          IPMAIL=IMAMOD
  116.          CONM  =CONMOD
  117. C
  118. C        TRAITEMENT DU MODELE
  119. C
  120.          MELE=NEFMOD
  121.          MELEME=IMAMOD
  122. C____________________________________________________________________
  123. C
  124. C        INFORMATION SUR L'ELEMENT FINI
  125. C____________________________________________________________________
  126. C
  127.          CALL ELQUOI(MELE,0,6,IPINF,IMODEL)
  128.          IF (IERR.NE.0) THEN
  129.             SEGDES IMODEL,MMODEL
  130.             CALL DTCHAM(IPCH1)
  131.             IRET=0
  132.             RETURN
  133.          ENDIF
  134. C
  135.          INFO=IPINF
  136.          IFORM=INFELL(13)
  137.          NBG  =INFELL(6)
  138. C         ICARA=INFELL(5)
  139.          LW   =INFELL(7)
  140.          LRE  =INFELL(9)
  141. C
  142. C        ACTIVATION DU MELEME
  143. C
  144.          SEGACT MELEME
  145.          NBNN  =NUM(/1)
  146.          NBELEM=NUM(/2)
  147. C
  148. C        CREATION DU TABLEAU INFOS
  149. C
  150.          CALL IDENT(IPMAIL,CONM,IPCH1,IPCHAM1,INFOS,IRTD)
  151.          IF (IRTD.EQ.0) THEN
  152.             NCARA=0
  153.             NCARF=0
  154.             NDEP=0
  155.             MOCARA=0
  156.             MODEPL=0
  157.             GOTO 9990
  158.          ENDIF
  159. C
  160. C        RECHERCHE DES NOMS DE COMPOSANTES
  161. C
  162.          IF(lnomid(1).ne.0) THEN
  163.             nomid=lnomid(1)
  164.             segact nomid
  165.             modepl=nomid
  166.             ndep=lesobl(/2)
  167.             nfac=lesfac(/2)
  168.             lsupdp=.false.
  169.          ELSE
  170.             lsupdp=.true.
  171.             CALL IDPRIM(IMODEL,IFORM,MODEPL,NDEP,NFAC)
  172.          ENDIF
  173. C
  174. C        VERIFICATION DE LEUR PRESENCE
  175. C
  176.          NBTYPE=1
  177.          SEGINI NOTYPE
  178.          MOTYPE=NOTYPE
  179.          TYPE(1)='REAL*8'
  180.          CALL KOMCHA(IPCHAM1,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP)
  181.          SEGSUP NOTYPE
  182.          IF (IERR.NE.0) THEN
  183.             NCARA=0
  184.             NCARF=0
  185.             MOCARA=0
  186.             GOTO 9990
  187.          ENDIF
  188. C____________________________________________________________________
  189. C
  190. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  191. C____________________________________________________________________
  192. C
  193.          NBROBL=0
  194.          NBRFAC=0
  195.          MOCARA=0
  196.          NCARA=0
  197.          NCARF=0
  198.          NCARR=0
  199.          IVECT=0
  200. *
  201. * CARACTERISTIQUES POUR LES BARRES
  202. *
  203.          IF (IFORM.EQ.27) THEN
  204.             NBROBL=1
  205.             SEGINI NOMID
  206.             MOCARA=NOMID
  207.             LESOBL(1)='SECT'
  208. *
  209.             NBTYPE=1
  210.             SEGINI NOTYPE
  211.             MOTYPE=NOTYPE
  212.             TYPE(1)='REAL*8'
  213. *
  214. * CARACTERISTIQUES POUR LES POUTRES ET LES TUYAU
  215. *
  216.          ELSE IF ((IFORM.EQ.7.OR.IFORM.EQ.13).AND.(IDIM.EQ.3)) THEN
  217.             NBRFAC=3
  218.             SEGINI NOMID
  219.             MOCARA=NOMID
  220.             LESFAC(1)='VX'
  221.             LESFAC(2)='VY'
  222.             LESFAC(3)='VZ'
  223.             IVECT=1
  224. *
  225.             NBTYPE=3
  226.             SEGINI NOTYPE
  227.             MOTYPE=NOTYPE
  228.             TYPE(1)='REAL*8'
  229.             TYPE(2)='REAL*8'
  230.             TYPE(3)='REAL*8'
  231. *
  232. * CARACTERISTIQUES POUR LES LINESPRING
  233. *
  234.          ELSE IF (IFORM.EQ.15) THEN
  235.             NBROBL=3
  236.             SEGINI NOMID
  237.             MOCARA=NOMID
  238.             LESOBL(1)='VX  '
  239.             LESOBL(2)='VY  '
  240.             LESOBL(3)='VZ  '
  241. *
  242.             NBTYPE=1
  243.             SEGINI NOTYPE
  244.             MOTYPE=NOTYPE
  245.             TYPE(1)='REAL*8'
  246. *
  247. * CARACTERISTIQUES POUR LES TUFI
  248. *
  249.          ELSE IF (IFORM.EQ.17) THEN
  250.             NBROBL=6
  251.             SEGINI NOMID
  252.             MOCARA=NOMID
  253.             LESOBL(1)='VX  '
  254.             LESOBL(2)='VY  '
  255.             LESOBL(3)='VZ  '
  256.             LESOBL(4)='VXF '
  257.             LESOBL(5)='VYF '
  258.             LESOBL(6)='VZF '
  259. *
  260.             NBTYPE=1
  261.             SEGINI NOTYPE
  262.             MOTYPE=NOTYPE
  263.             TYPE(1)='REAL*8'
  264. *
  265. * (fdp) CARACTERISTIQUES POUR LES JOI1
  266. *
  267.          ELSE IF (IFORM.EQ.75) THEN
  268.             IF (IDIM.EQ.2) THEN
  269.                NBROBL=2
  270.                SEGINI NOMID
  271.                MOCARA=NOMID
  272.                LESOBL(1)='V1X '
  273.                LESOBL(2)='V1Y '
  274.             ENDIF
  275.             IF (IDIM.EQ.3) THEN
  276.                NBROBL=6
  277.                SEGINI NOMID
  278.                MOCARA=NOMID
  279.                LESOBL(1)='V1X '
  280.                LESOBL(2)='V1Y '
  281.                LESOBL(3)='V1Z '
  282.                LESOBL(4)='V2X '
  283.                LESOBL(5)='V2Y '
  284.                LESOBL(6)='V2Z '
  285.             ENDIF
  286. *
  287.             NBTYPE=1
  288.             SEGINI NOTYPE
  289.             MOTYPE=NOTYPE
  290.             TYPE(1)='REAL*8'
  291.          ENDIF
  292. *
  293.          IF (MOCARA.NE.0)  THEN
  294. *
  295.             CALL KOMCHA(IPCHEL,IPMAIL,CONM,MOCARA,MOTYPE,1,
  296.      &                  INFOS,3,IVACAR)
  297. *      write (6,*) ' formch apres komcha 1 ivacar ',ivacar
  298.             IF (IERR.NE.0)THEN
  299.                SEGSUP NOTYPE
  300.                GOTO 9990
  301.             ENDIF
  302.             CALL KOMCHA(IPCH1,IPMAIL,CONM,MOCARA,MOTYPE,1,
  303.      &                  INFOS,3,IVACA1)
  304.             SEGSUP NOTYPE
  305.             IF (IERR.NE.0) GOTO 9990
  306.             IF (IVECT.EQ.1) THEN
  307.                MPTVAL=IVACAR
  308.                IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN
  309. *
  310. *                 MOT CLE VECT EN CAS DE CONVERSION
  311. *
  312.                   IVECT=2
  313.                   NOMID=MOCARA
  314.                   SEGSUP NOMID
  315.                   NBRFAC=0
  316.                   NBROBL=3
  317.                   SEGINI NOMID
  318.                   MOCARA=NOMID
  319.                   LESOBL(1)='VX  '
  320.                   LESOBL(2)='VY  '
  321.                   LESOBL(3)='VZ  '
  322. *
  323.                   NBTYPE=3
  324.                   SEGINI NOTYPE
  325.                   MOTYPE=NOTYPE
  326.                   TYPE(1)='REAL*8'
  327.                   TYPE(2)='REAL*8'
  328.                   TYPE(3)='REAL*8'
  329. *
  330.                   CALL KOMCHA(IPCHEL,IPMAIL,CONM,MOCARA,MOTYPE,1,
  331.      &                        INFOS,3,IVACAR)
  332.        write (6,*) ' formch apres komcha 2 ivacar ',ivacar
  333.                   IF (IERR.NE.0)THEN
  334.                      SEGSUP NOTYPE
  335.                      GOTO 9990
  336.                   ENDIF
  337.                   CALL KOMCHA(IPCH1,IPMAIL,CONM,MOCARA,MOTYPE,1,
  338.      &                        INFOS,3,IVACA1)
  339.                   SEGSUP NOTYPE
  340.                   IF (IERR.NE.0) GOTO 9990
  341.                ENDIF
  342.             ENDIF
  343.          ENDIF
  344.          NCARA=NBROBL
  345.          NCARF=NBRFAC
  346.          NCARR=NCARA+NCARF
  347.          IF (MOCARA.NE.0) SEGDES NOMID
  348. *
  349. *        AJUSTEMENT DE LA DIMENSION DES MELVAL
  350. *
  351.          IF ((iform.EQ.7).OR.(iform.EQ.13).OR.(iform.EQ.15).OR.
  352.      &       (iform.EQ.17).OR.(iform.EQ.75)) THEN
  353.             IF (NCARR.NE.0) THEN
  354.                MPTVAL=IVACAR
  355.                MELVAL=IVAL(1)
  356. C              cas d'une composante scalaire
  357.                   N1PTEL=VELCHE(/1)
  358.                   N1EL  =VELCHE(/2)
  359. C (fdp) correction : on remplace .LT. par .LE. pour gerer le cas ou il
  360. C                    n'y a qu'un seul element
  361. C                    (sinon plantage dans le cas d'un seul element TUFI)
  362.                   IF((N1EL.LE.NBELEM).OR.(N1PTEL.LE.NBG)) THEN
  363.                      N1EL  = MAX(N1EL,NBELEM)
  364.                      N1PTEL= MAX(N1PTEL,NBG)
  365.                      N2EL  = 0
  366.                      N2PTEL= 0
  367.                      IF (IFORM.EQ.7.OR.IFORM.EQ.13) N1PTEL=1
  368.                      MPTVAL=IVACA1
  369.                      DO 128 ID=1,NBROBL+NBRFAC
  370.                         MELVAL=IVAL(ID)
  371. **                      write(6,*) 'boucle 128 segadj melval',melval
  372.                         IF(MELVAL.NE.0) SEGADJ MELVAL
  373.  128                 CONTINUE
  374.                   ENDIF
  375.  
  376.             ENDIF
  377.          ENDIF
  378. *
  379. *
  380. *        MASSI COQUE COQEP POUT  CIST  THER  TUYA  LISP
  381. *
  382. C (fdp) on prevoit le cas des elements JOI1 (iform = 75)
  383.          IF(iform.EQ.75) GOTO 66
  384.          IF(iform.GT.38) GOTO 30
  385.          GOTO (30,22,30,22,30,22,120,22,30,22,22,22,120,22,90,22,
  386. *
  387. *        TUFI  RCMA  RCCO  SULI  MEMB  UNIA  THER  INCO  PORE
  388. *
  389.      &         70,22,22,22,22,22,22,22,22,22,30,22,22,22,30,22,30,22,
  390. *
  391. *        RACO  HOMO
  392. *
  393.      &         30,22,22,22),IFORM
  394. C
  395.  22      CONTINUE
  396.          IRET=0
  397.          MOTERR(1:8)=NOMFR(IFORM)
  398.          CALL ERREUR(193)
  399.          GOTO 9990
  400. C______________________________________________________________________
  401. C
  402. C    FORMULATION MASSIVE - RIEN DE SPECIAL A FAIRE
  403. C    FORMULATION POREUSE - RIEN DE SPECIAL A FAIRE
  404. C    FORMULATIONS COQUE  - ON NE FAIT RIEN
  405. C    FORMULATIONS UNIAXIALE  - ON NE FAIT RIEN
  406. C______________________________________________________________________
  407. C
  408.  30      CONTINUE
  409.          GOTO 150
  410. C______________________________________________________________________
  411. C
  412. C    FORMULATION LINESPRING
  413. C______________________________________________________________________
  414. C
  415.  90      CONTINUE
  416.          SEGINI IWRK
  417.          DO     IB=1,NBELEM
  418. C
  419. C           ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS
  420. C
  421.             CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  422.             IE=1
  423.             DO      IGAU=1,NBNN
  424.                MPTVAL=IVADEP
  425.                DO      ICOMP=1,NDEP
  426.                   MELVAL=IVAL(ICOMP)
  427.                   IGMN=MIN(IGAU,VELCHE(/1))
  428.                   IBMN=MIN(IB  ,VELCHE(/2))
  429.                   XDDL(IE)=VELCHE(IGMN,IBMN)
  430.                   IE=IE+1
  431.                enddo      
  432.             enddo      
  433. C
  434.             DO     IC=1,NBG
  435.                MPTVAL=IVACAR
  436.                IF(IC.EQ.2) GO TO 948
  437.                DO 923 ID=1,3
  438.                   MELVAL=IVAL(ID)
  439.                   IGMN=MIN(IC,VELCHE(/1))
  440.                   IBMN=MIN(IB,VELCHE(/2))
  441.                   VECT(ID)=VELCHE(IGMN,IBMN)
  442.  923           CONTINUE
  443.                ICC=1
  444.                IF(IC.GT.1) ICC=2
  445.                CALL LSPFRM(IWRK,KERRE,VECT,ICC)
  446. C
  447.                IF(KERRE.NE.0) THEN
  448.                  INTERR(1)=ISOUS
  449.                  INTERR(2)=IB
  450.                  GO TO 927
  451.                ENDIF
  452. C
  453. C              REMPLISSAGE
  454. C
  455.  948           CONTINUE
  456.                MPTVAL=IVACA1
  457.                DO     ID=1,3
  458.                   MELVAL=IVAL(ID)
  459.                   VELCHE(IC,IB)=VECT(ID)
  460. *
  461.                enddo
  462.             enddo 
  463.          enddo     
  464. C
  465.   927    SEGSUP IWRK
  466.          GOTO 151
  467. C_______________________________________________________________________
  468. C
  469. C    FORMULATION TUYAU FISSURE
  470. C_______________________________________________________________________
  471. C
  472.  70      CONTINUE
  473.          SEGINI IWRK
  474.          DO     IB=1,NBELEM
  475. C
  476. C           ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS
  477. C
  478.             CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  479.             IE=1
  480.             DO      IC=1,NBNN
  481.                MPTVAL=IVADEP
  482.                DO      ID=1,NDEP
  483.                   MELVAL=IVAL(ID)
  484.                   IGMN=MIN(IC,VELCHE(/1))
  485.                   IBMN=MIN(IB,VELCHE(/2))
  486.                   XDDL(IE)=VELCHE(IGMN,IBMN)
  487.                   IE=IE+1
  488.                enddo    
  489.             enddo    
  490. C
  491.             MPTVAL=IVACAR
  492.             DO 723 ID=1,6
  493.                MELVAL=IVAL(ID)
  494.                IBMN=MIN(IB,VELCHE(/2))
  495.                VECT(ID)=VELCHE(1,IBMN)
  496.  723        CONTINUE
  497. C
  498.             CALL TUYFRM(IWRK,KERRE,VECT,VECT(4))
  499. C
  500.             IF(KERRE.NE.0) THEN
  501.                INTERR(1)=ISOUS
  502.                INTERR(2)=IB
  503.                GO TO 727
  504.             ENDIF
  505. C
  506. C           REMPLISSAGE
  507. C
  508.             DO     IC=1,NBG
  509.                MPTVAL=IVACA1
  510.                DO 726 ID=1,6
  511.                   MELVAL=IVAL(ID)
  512.                   VELCHE(IC,IB)=VECT(ID)
  513.  726           CONTINUE
  514. C
  515.             enddo
  516.          enddo    
  517. C
  518.  727     SEGSUP IWRK
  519.          GOTO 151
  520. C_______________________________________________________________________
  521. C
  522. C (fdp) FORMULATION JOINT 1 AVEC REPERE LOCAL LIE
  523. C_______________________________________________________________________
  524. C
  525.  66      CONTINUE
  526.          SEGINI IWRK
  527. C
  528.          DO IB=1,NBELEM
  529. C
  530. C           ON CHERCHE LES COORDONNEES DES NOEUDS, LES DEPLACEMENTS ET
  531. C           LES ROTATIONS
  532. C
  533.             CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  534.             IE=1
  535.             DO IC=1,NBNN
  536.                MPTVAL=IVADEP
  537.                DO ID=1,NDEP
  538.                   MELVAL=IVAL(ID)
  539.                   IGMN=MIN(IC,VELCHE(/1))
  540.                   IBMN=MIN(IB,VELCHE(/2))
  541.                   XDDL(IE)=VELCHE(IGMN,IBMN)
  542.                   IE=IE+1
  543.                ENDDO
  544.             ENDDO
  545. C
  546. C           ON CHERCHE LES VECTEURS ORIENTANT L'ELEMENT JOINT DANS LE
  547. C           CHAMP DE CARACTERISTIQUES
  548. C
  549.             MPTVAL=IVACAR
  550.             DO IC=1,NBROBL
  551.                MELVAL=IVAL(IC)
  552.                IBMN=MIN(IB,VELCHE(/2))
  553.                VECT(IC)=VELCHE(1,IBMN)
  554.             ENDDO
  555. C
  556. C           ON APPLIQUE LA ROTATION AUX VECTEURS ORIENTANT LE JOINT
  557. C
  558.             ITOUR=-1*INFMOD(9)
  559.             IF (ITOUR.EQ.1) THEN
  560.                CALL JOIFRM(IWRK,KERRE,VECT,IDIM)
  561.                IF (KERRE.EQ.1) THEN
  562.                  CALL ERREUR(277)
  563.                  RETURN
  564.                ENDIF
  565.             ENDIF
  566. C
  567. C           REMPLISSAGE DU CHAMP DE CARACTERISTIQUES AVEC LES NOUVEAUX
  568. C           VECTEURS
  569. C
  570.             MPTVAL=IVACA1
  571.             DO IC=1,NBROBL
  572.                MELVAL=IVAL(IC)
  573.                VELCHE(1,IB)=VECT(IC)
  574.             ENDDO
  575. C
  576.          ENDDO
  577. C
  578.          SEGSUP IWRK
  579.          GOTO 151
  580. C_______________________________________________________________________
  581. C
  582. C    FORMULATION POUTRE ET TUYAU
  583. C_______________________________________________________________________
  584. C
  585.  120     CONTINUE
  586.          SEGINI IWRK
  587. C
  588.          DO 121 IB=1,NBELEM
  589. C
  590. C           ON CHERCHE LES COORDONNEES DES NOEUDS ET LES DEPLACEMENTS
  591. C
  592.             CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  593.             IE=1
  594.             DO      IC=1,NBNN
  595.                MPTVAL=IVADEP
  596.                DO      ID=1,NDEP
  597.                   MELVAL=IVAL(ID)
  598.                   IGMN=MIN(IC,VELCHE(/1))
  599.                   IBMN=MIN(IB,VELCHE(/2))
  600.                   XDDL(IE)=VELCHE(IGMN,IBMN)
  601.                   IE=IE+1
  602.                enddo
  603.             enddo
  604. C
  605. C
  606.             MPTVAL=IVACAR
  607.             IF (IVECT.EQ.1) THEN
  608.               do id=1,3
  609.                MELVAL=IVAL(id)
  610.                segact melval
  611. **             write(6,*) 'melval ',melval,velche(/1),velche(/2)
  612.                IBMN=MIN(IB,VELCHE(/2))
  613.                 vect(id)=vELCHE(1,IBMN)
  614.               enddo
  615. C
  616. C           CAS DU CHAMELEM COMVERTI
  617. C
  618.             ELSE IF (IVECT.EQ.2) THEN
  619.                DO 6429 IC=1,3
  620.                   MELVAL=IVAL(IC)
  621.                   IBMN=MIN(IB,VELCHE(/2))
  622.                   VECT(IC)=VELCHE(1,IBMN)
  623.  6429          CONTINUE
  624.             ENDIF                                            
  625. C
  626.             IF (IVECT.NE.0) THEN
  627.                CALL POUFRM(IWRK,KERRE,VECT)
  628. C
  629.                IF(KERRE.NE.0) THEN
  630.                   INTERR(1)=ISOUS
  631.                   INTERR(2)=IB
  632.                   GO TO 127
  633.                ENDIF
  634. C
  635. C              REMPLISSAGE
  636. C
  637.                   MPTVAL=IVACA1
  638.                   DO 126 ID=1,3
  639.                      MELVAL=IVAL(ID)
  640.                      SEGACT MELVAL*MOD
  641.                      VELCHE(1,IB)=VECT(ID)
  642. **                write(6,*) vect(id)
  643.  126              CONTINUE
  644.  
  645.             ENDIF
  646.  121     CONTINUE
  647. C
  648.  127     SEGSUP IWRK
  649.          GOTO 151
  650. C_______________________________________________________________________
  651. C
  652. C    AUTRE FORMULATION
  653. C_______________________________________________________________________
  654. C
  655.  151     CONTINUE
  656.          IF(KERRE.EQ.1) CALL ERREUR(128)
  657.          IF(KERRE.EQ.2) CALL ERREUR(138)
  658.          IF(KERRE.EQ.3) CALL ERREUR(277)
  659.  150     CONTINUE
  660.          SEGDES MELEME
  661.          SEGSUP INFO
  662.          SEGDES IMODEL
  663.          MPTVAL=IVACAR
  664.          IF (MPTVAL.NE.0) THEN
  665.             SEGACT MPTVAL
  666.             DO 152 I=1,ival(/1)
  667.               IF (IVAL(I).NE.0) THEN
  668.                  MELVAL=IVAL(I)
  669.                  SEGDES MELVAL
  670.               ENDIF
  671.  152        CONTINUE
  672.             IF (MOCARA.NE.0) SEGSUP MPTVAL
  673.          ENDIF
  674. C
  675.          MPTVAL=IVACA1
  676.          IF (MPTVAL.NE.0) THEN
  677.             SEGACT MPTVAL
  678.             DO I=1,IVAL(/1)
  679.                IF (IVAL(I).NE.0) THEN
  680.                   MELVAL=IVAL(I)
  681.                   SEGDES MELVAL
  682.                ENDIF
  683.             ENDDO
  684.             IF (MOCARA.NE.0) SEGSUP MPTVAL
  685.          ENDIF
  686. C
  687.          MPTVAL=IVADEP
  688.          IF (MPTVAL.NE.0) THEN
  689.             SEGACT MPTVAL
  690.             DO 153 I=1,ival(/1)
  691.                IF (IVAL(I).NE.0) THEN
  692.                   MELVAL=IVAL(I)
  693.                   SEGDES MELVAL
  694.                ENDIF
  695.  153        CONTINUE
  696.             SEGSUP MPTVAL
  697.          ENDIF
  698. C
  699.          NOMID=MOCARA
  700.          IF (MOCARA.NE.0) SEGSUP NOMID
  701.          NOMID=MODEPL
  702.          IF(lsupdp) SEGSUP NOMID
  703. C
  704.          IF(KERRE.NE.0) THEN
  705.             IRET=0
  706.             SEGDES MMODEL
  707.             CALL DTCHAM(IPCH1)
  708.             RETURN
  709.          ENDIF
  710. C
  711.  200  CONTINUE
  712. C
  713.       SEGDES MMODEL
  714.       RETURN
  715. C
  716.  9990 CONTINUE
  717. C
  718. C     ERREUR DANS UNE SOUS ZONE DESACTIVATION ET RETOUR
  719. C
  720.       SEGDES MELEME
  721. *      SEGSUP INFO
  722.       SEGDES IMODEL
  723.       MPTVAL=IVACAR
  724.       DO 9152 I=1,IVAL(/1)
  725.          IF (IVAL(I).NE.0) THEN
  726.             MELVAL=IVAL(I)
  727.             SEGDES MELVAL
  728.          ENDIF
  729.  9152 CONTINUE
  730.       IF (MOCARA.NE.0) SEGSUP MPTVAL
  731. C
  732.       MPTVAL=IVACA1
  733.       if (mptval.ne.0) then
  734.       DO I=1,IVAL(/1)
  735.          IF (IVAL(I).NE.0) THEN
  736.             MELVAL=IVAL(I)
  737.             SEGDES MELVAL
  738.          ENDIF
  739.       ENDDO
  740.       IF (MOCARA.NE.0) SEGSUP MPTVAL
  741.       endif
  742. C
  743.       MPTVAL=IVADEP
  744.       if (mptval.ne.0) then
  745.       DO 9153 I=1,IVAL(/1)
  746.          IF (IVAL(I).NE.0) THEN
  747.             MELVAL=IVAL(I)
  748.             SEGDES MELVAL
  749.          ENDIF
  750.  9153 CONTINUE
  751.       IF (MODEPL.NE.0) SEGSUP MPTVAL
  752.       endif
  753. C
  754.       NOMID=MOCARA
  755.       IF (MOCARA.NE.0) SEGSUP NOMID
  756.       NOMID=MODEPL
  757.       IF (MODEPL.NE.0.AND.lsupdp) SEGSUP NOMID
  758. C
  759.       RETURN
  760.       END
  761.  
  762.  
  763.  
  764.  
  765.  
  766.  
  767.  

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