Télécharger la plaquette Cast3M


fr en

Télécharger cp2cv7.eso

Retour à la liste

Numérotation des lignes : 

cp2cv7

  1. C CP2CV7    SOURCE    GOUNAND   26/07/06    21:15:02     12592          
  2.       SUBROUTINE CP2CV7(CGEOMQ,MYLMOT,MYDISC,TYPCHA,ICHAM,MYREAL,
  3.      $     MYFALS,
  4.      $     MYMCHA,
  5.      $     IMPR,IRET)
  6.       IMPLICIT REAL*8 (A-H,O-Z)
  7.       IMPLICIT INTEGER (I-N)
  8. C***********************************************************************
  9. C NOM         : CP2CV7
  10. C DESCRIPTION : Transforme un chpoint en MCHAEL
  11. C
  12. C LANGAGE     : ESOPE
  13. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  14. C               mél : gounand@semt2.smts.cea.fr
  15. C***********************************************************************
  16. C APPELES          :
  17. C APPELE PAR       : PRLS63
  18. C***********************************************************************
  19. C ENTREES            : * CGEOMQ (type MELEME) : maillage de QUAFs
  20. C                        partitionné.
  21. C                      * MYDISC (type CH*(4)) : nom d'espace de
  22. C                        discrétisation (cf. NOMFA dans l'include
  23. C                        SFALRF)
  24. C                      * MYFALS (type FALRFS) : segment de description
  25. C                        des familles d'éléments de références.
  26. C SORTIES            : * MYMCHA (type MCHAEL) : champ par éléments de
  27. C                        la grandeur tensorielle (degrés de liberté de
  28. C                        la grandeur).
  29. C ENTREES/SORTIES    : -
  30. C TRAVAIL            :
  31. C                        (1, nb. ddl, NCOMPD, NCOMPP, 1, nb. élément)
  32. C
  33. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  34. C***********************************************************************
  35. C VERSION    : v1, 24/09/03, version initiale
  36. C HISTORIQUE : v1, 24/09/03, création
  37. C HISTORIQUE :     18/05/21, ajout lecture MCHAML
  38. C HISTORIQUE :
  39. C***********************************************************************
  40. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  41. C en cas de modification de ce sous-programme afin de faciliter
  42. C la maintenance !
  43. C***********************************************************************
  44.  
  45. -INC PPARAM
  46. -INC CCOPTIO
  47. -INC CCGEOME
  48. -INC SMCOORD
  49. -INC SMCHPOI
  50.       POINTEUR MYCHPO.MCHPOI
  51. -INC SMCHAML
  52.       POINTEUR MYCHAM.MCHAML
  53. -INC TMTRAV
  54.       POINTEUR MYMTRA.MTRAV
  55.       INTEGER NNIN,NNNOE
  56. -INC SMELEME
  57.       POINTEUR CGEOMQ.MELEME
  58.       POINTEUR SOUMAI.MELEME
  59.       POINTEUR SOUMEL.MELEME
  60. -INC SMLMOTS
  61.       POINTEUR MYLMOT.MLMOTS
  62.       INTEGER JGN
  63. -INC SMLENTI
  64.       POINTEUR KRIGEO.MLENTI
  65.       POINTEUR KRINCO.MLENTI
  66.       POINTEUR MPQUAF.MLENTI
  67.       POINTEUR IORDO.MLENTI
  68.       INTEGER JG
  69. -INC SMMODEL
  70. *
  71. * Includes persos
  72. *
  73. -INC TNLIN
  74. *-INC SMCHAEL
  75.       INTEGER N1
  76.       POINTEUR MYMCHA.MCHAEL
  77.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
  78.       POINTEUR MZMCHA.MCHEVA
  79. *-INC SFALRF
  80.       POINTEUR MYFALS.FALRFS
  81. *-INC SELREF
  82.       POINTEUR MYLRF.ELREF
  83. *
  84.       CHARACTER*(4) MYDISC,NOMEL1
  85.       CHARACTER*8 TYPCHA
  86. *
  87.       INTEGER IBEL,IDDL,ISOUS,ITQUAF
  88.       INTEGER NBEL,NDDL,NSOUS
  89.       INTEGER NMLOC,NMQUA,NNGLO,NNLOC,NNMDDL,NNQUA
  90.       INTEGER NTOGPO
  91.       LOGICAL LDDLEX,LREDU
  92.       REAL*8 MYREAL
  93.       REAL*8 CONTRI
  94.       LOGICAL LWARN,LVIDE,LINIZ,LCROI
  95. *
  96.       CHARACTER*(4) NMELEM,NMELEQ
  97.       PARAMETER (NDISC=3)
  98.       CHARACTER*(4) DISCS(NDISC),MOEF
  99.       INTEGER IMPR,IRET
  100.       PARAMETER (NQUAF=7)
  101.       CHARACTER*4 NMQUAF(NQUAF)
  102.       CHARACTER*4 NMQUAI(NQUAF)
  103.       CHARACTER*4 NMLINE(NQUAF)
  104. *
  105.       DATA DISCS/'LINE','QUAI','QUAF'/
  106.       DATA NMQUAF/'SEG3','TRI7','QUA9','CU27','PR21','TE15','PY19'/
  107.       DATA NMQUAI/'SEG3','TRI6','QUA8','CU20','PR15','TE10','PY13'/
  108.       DATA NMLINE/'SEG2','TRI3','QUA4','CUB8','PRI6','TET4','PYR5'/
  109. *
  110. * Executable statements
  111. *
  112.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans cp2cv7'
  113. *
  114. * Transformation du chpoint en un objet MTRAV plus commode
  115. *
  116.       IF (ICHAM.EQ.0) THEN
  117.          MYMCHA=0
  118. * Valeur scalaire
  119.       ELSEIF (ICHAM.LT.0) THEN
  120.          SEGACT CGEOMQ
  121.          NSOUS=CGEOMQ.LISOUS(/1)
  122.          N1=NSOUS
  123.          SEGINI MYMCHA
  124.          DO 2 ISOUS=1,NSOUS
  125.             SOUMAI=CGEOMQ.LISOUS(ISOUS)
  126.             SEGACT SOUMAI
  127. * On cherche l'élément fini correspondant au QUAF
  128.             ITQUAF=SOUMAI.ITYPEL
  129.             CALL KEEF(ITQUAF,MYDISC,
  130.      $           MYFALS,
  131.      $           MYLRF,
  132.      $           IMPR,IRET)
  133.             IF (IRET.NE.0) GOTO 9999
  134.             SEGACT MYLRF
  135.             NDDL=MYLRF.NPQUAF(/1)
  136. *            NBEL=SOUMAI.NUM(/2)
  137. * On initialise le MCHEVA a remplir
  138.             NBLIG=1
  139.             NBCOL=NDDL
  140.             N2LIG=1
  141.             N2COL=1
  142.             NBPOI=1
  143. * Astuce !
  144.             NBELM=1
  145.             SEGINI MZMCHA
  146.             DO IDDL=1,NDDL
  147.                MZMCHA.WELCHE(1,IDDL,1,1,1,1)=
  148.      $              MYREAL
  149.             ENDDO
  150.             SEGDES MZMCHA
  151.             MYMCHA.ICHEVA(ISOUS)=MZMCHA
  152.             SEGDES MYLRF
  153.             SEGDES SOUMAI
  154.             MYMCHA.JMACHE(ISOUS)=SOUMAI
  155.  2       CONTINUE
  156.          SEGDES MYMCHA
  157.          SEGDES CGEOMQ
  158. * ICHAM.GT.0
  159.       ELSE
  160.          IF (TYPCHA.EQ.'MCHAML  ') THEN
  161.             MYCHAM=ICHAM
  162. * Vérifions que MYDISC permet l'utilisation des MCHAML
  163.             CALL PLACE5(DISCS,NDISC,IDISC,MYDISC)
  164.             IF (IDISC.EQ.0) THEN
  165.                WRITE(IOIMP,*)
  166.      $              'MCHAML datum incompatible with discretization '
  167.      $              ,MYDISC
  168.                GOTO 9999
  169.             ENDIF
  170. * Réduisons le champ par élément sur les composantes de MYLMOT
  171. *     Normalement, il n'y a qu'un mot dans MYLMOT compte tenu des
  172. *     espaces de discrétisation envisagés (LINE, QUAI, QUAF)
  173.             SEGACT MYLMOT
  174.             NNMDDL=MYLMOT.MOTS(/2)
  175.             IF (NNMDDL.NE.1) THEN
  176.                WRITE(IOIMP,*) 'Programming error 3'
  177.                write(ioimp,*) 'NMELEM,NMELEQ,MYDISC=',NMELEM
  178.      $              ,NMELEQ,MYDISC
  179.                write(ioimp,*) 'NBNN,NDDL=',NBNN,NDDL
  180.                GOTO 9999
  181.             ENDIF
  182. *
  183.             CALL ACTOBJ('MCHAML  ',MYCHAM,1)
  184.             CALL EXCOC2(MYCHAM,MYLMOT,MCHELM,MYLMOT,0)
  185.             IF (IERR.NE.0) GOTO 9999
  186. *     Construisons le maillage issu de CGEOMQ (QUAF) qui ne va porter
  187. *     que sur les noeuds du QUAD ou du LINE si necessaire (voir aussi
  188. *     cv2cml.eso)
  189. *     On essaie de voir d'abord s'il ne serait pas stocké dans les
  190. *     références de CGEOMQ
  191.             SEGACT CGEOMQ
  192.             IF (IDISC.EQ.3) THEN
  193.                MELEME=CGEOMQ
  194.             ELSE
  195.                NBNN=0
  196.                NBELEM=0
  197.                NBREF=0
  198.                NBSOUS=CGEOMQ.LISOUS(/1)
  199.                SEGINI MELEME
  200.                DO ISOUS=1,NBSOUS
  201.                   IPT1=CGEOMQ.LISREF(ISOUS)
  202.                   IDX=0
  203.                   IF (IPT1.NE.0) THEN
  204.                      ITYP1=IPT1.ITYPEL
  205.                      NOMEL1=NOMS(ITYP1)
  206.                      IF (IDISC.EQ.1) THEN
  207.                         CALL PLACE5(NMLINE,NQUAF,IDX,NOMEL1)
  208.                      ELSE
  209.                         CALL PLACE5(NMQUAI,NQUAF,IDX,NOMEL1)
  210.                      ENDIF
  211.                   ENDIF
  212.                   IF (IDX.NE.0) THEN
  213.                      IPT2=IPT1
  214.                   ELSE
  215.                      IPT1=CGEOMQ.LISOUS(ISOUS)
  216.                      CALL ECROBJ('MAILLAGE',IPT1)
  217.                      IF (IDISC.EQ.1) THEN
  218.                         CALL CHANLI
  219.                      ELSE
  220.                         CALL CHANQU
  221.                      ENDIF
  222.                      CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  223.                      IF(IERR.NE.0) RETURN
  224.                   ENDIF
  225.                   LISOUS(ISOUS)=IPT2
  226.                ENDDO
  227.             ENDIF
  228. * Réduisons sur le maillage cree
  229. *            WRITE(IOIMP,*) 'MELEME'
  230. *            CALL ECROBJ('MAILLAGE',MELEME)
  231. *            CALL PRLIST
  232. *            CALL ECROBJ('MCHAML  ',MCHELM)
  233. *            CALL PRLIST
  234. * On passe par un modele car le REDUIC ne fait pas ce que l'on veut
  235. *            CALL REDUIC(MCHELM,MELEME,MCHEL2)
  236. *            IF (IERR.NE.0) GOTO 9999
  237.             nbs=meleme.lisous(/1)
  238.             if (nbs.ne.0) then
  239.               do ic=1,nbs
  240.                 ipt3=meleme.lisous(ic)
  241.                 moef=NOMS(ipt3.itypel)
  242.                 call ecrcha(moef)
  243.               enddo
  244.             else
  245.               moef=NOMS(meleme.itypel)
  246.               call ecrcha(moef)
  247.             endif
  248.             call ecrcha('MECANIQUE')
  249.             call ecrobj('MAILLAGE',MELEME)
  250.             call modeli
  251.             IF (IERR.NE.0) GOTO 9999
  252.             call lirobj('MMODEL  ',MMODEL,1,IRET)
  253.             IF (IERR.NE.0) GOTO 9999
  254. *            write(ioimp,*) 'cp2cv7: Avant REDU'
  255. *            SEGPRT,MCHELM
  256.             CALL REDUAF(MCHELM,MMODEL,MCHEL2,0,IR,KER)
  257.             IF(IR   .NE. 1) CALL ERREUR(KER)
  258.             IF(IERR .NE. 0) GOTO 9999
  259.             LREDU=.TRUE.
  260.             IF (MCHEL2.EQ.0) THEN
  261.                LREDU=.FALSE.
  262.             ELSE
  263.                N1=MCHEL2.ICHAML(/1)
  264.                IF (N1.NE.NBSOUS) LREDU=.FALSE.
  265.             ENDIF
  266.             IF (.NOT.LREDU) THEN
  267. * 609 2
  268. * Le champ n'est pas defini aux bons points supports
  269.                CALL ERREUR(609)
  270.                GOTO 9999
  271.             ENDIF
  272. *            write(ioimp,*) 'cp2cv7: Apres REDU'
  273. *            call ecrobj('MCHAML',MCHEL2)
  274. *            call prlist
  275. *            CALL ACTOBJ('MCHAML  ',MCHEL2,1)
  276. *           SEGPRT,MCHEL2
  277. * Osons...
  278.             CALL DTCHAM(MCHELM)
  279.             SEGSUP MMODEL
  280.             MCHELM=MCHEL2
  281.             IF (IDISC.NE.3) SEGSUP MELEME
  282. *
  283. * Création et remplissage du champ par éléments
  284. * En même temps, on supprime les MELEME crees.
  285. *            SEGACT MELEME
  286.             NSOUS=CGEOMQ.LISOUS(/1)
  287.             CALL ACTOBJ('MCHAML  ',MCHELM,1)
  288. *         write(ioimp,*) 'MCHELM=',MCHELM
  289.             N1=NSOUS
  290.             SEGINI MYMCHA
  291.             DO 3 ISOUS=1,NSOUS
  292. *               write(ioimp,*) 'isous=',isous
  293. *               write(ioimp,*) 'ichaml(/1)=',ichaml(/1)
  294. *               write(ioimp,*) 'lisous(/1)=',lisous(/1)
  295.                SOUMAI=CGEOMQ.LISOUS(ISOUS)
  296.                SEGACT SOUMAI
  297.                SOUMEL=IMACHE(ISOUS)
  298.                SEGACT SOUMEL
  299.                MCHAML=ICHAML(ISOUS)
  300.                N2=IELVAL(/1)
  301. * Normalement, 1 seule composante vu qu'on a reduit le champ dessus
  302.                IF (N2.NE.1) THEN
  303.                   WRITE(IOIMP,*) 'Programming error 4'
  304.                   GOTO 9999
  305.                ENDIF
  306.                IF (TYPCHE(1).NE.'REAL*8') THEN
  307.                   WRITE(IOIMP,*) 'Error : component ',NOMCHE(1)
  308.      $                 ,' not REAL*8 in the MCHAML object'
  309.                   GOTO 9999
  310.                ENDIF
  311. *               write(ioimp,*) 'N1,N2=',N1,N2
  312. *            do i=1,n2
  313. *               write(ioimp,*) 'i,nomche',i,nomche(i)
  314. *            enddo
  315. *     SEGPRT,MYLMOT
  316. *            SEGPRT,MCHAML
  317.                ITQUAF=SOUMAI.ITYPEL
  318.                CALL KEEF(ITQUAF,MYDISC,
  319.      $              MYFALS,
  320.      $              MYLRF,
  321.      $              IMPR,IRET)
  322.                IF (IRET.NE.0) GOTO 9999
  323.                SEGACT MYLRF
  324.                NDDL=MYLRF.NPQUAF(/1)
  325.                NDDL2=SOUMEL.NUM(/1)
  326.                if (NDDL.NE.NDDL2) then
  327.                   write(ioimp,*) 'Erreur grave dimensions soumel'
  328.                   goto 9999
  329.                endif
  330.                NBEL=SOUMEL.NUM(/2)
  331.                MELVAL=IELVAL(1)
  332.                N1PTEL=VELCHE(/1)
  333.                N1EL=VELCHE(/2)
  334.                IF ((N1PTEL.NE.NDDL.AND.N1PTEL.NE.1).OR.
  335.      $             (N1EL.NE.1.AND.N1EL.NE.NBEL)) THEN
  336.                   write(ioimp,*) 'Erreur grave dimensions MELVAL'
  337.                   write(ioimp,*) 'N1PTEL,NDDL=',N1PTEL,NDDL
  338.                   write(ioimp,*) 'N1EL,NBEL=',N1EL,NBEL
  339.                   GOTO 9999
  340.                ENDIF
  341. * On initialise le MCHEVA a remplir
  342.                NBLIG=1
  343.                NBCOL=NDDL
  344.                N2LIG=1
  345.                N2COL=1
  346.                NBPOI=1
  347.                NBELM=N1EL
  348.                SEGINI MZMCHA
  349. *     Construisons le segment qui permet de parcourir les ddl dans
  350. *     l'ordre croissant des points du quaf
  351. *     Implicitement, on utilise le fait que les maillages LINE et QUAD
  352. *     parcourent les points du QUAF en croissant aussi.
  353. *     On utilise le tri par insertion car les listes sont petites
  354.                JG=NDDL
  355.                SEGINI MPQUAF
  356.                SEGINI IORDO
  357.                DO IG=1,JG
  358.                   MPQUAF.LECT(IG)=MYLRF.NPQUAF(IG)
  359.                   IORDO.LECT(IG)=IG
  360.                ENDDO
  361.                LCROI=.TRUE.
  362.                CALL ORDO04(MPQUAF.LECT(1),NDDL,LCROI,IORDO.LECT(1))
  363.                SEGDES MYLRF
  364. *
  365. *               DO IDDL=1,NDDL
  366. *                  write(ioimp,*) 'I,NPQUAF,IORDO=',IDDL
  367. *     $                 ,MYLRF.NPQUAF(IDDL),IORDO.LECT(IDDL)
  368. *               ENDDO
  369. *               SEGPRT,MYLRF
  370. *               SEGPRT,SOUMAI
  371. *               SEGPRT,SOUMEL
  372. *               SEGPRT,IORDO
  373.                DO I1EL=1,N1EL
  374.                   DO IDDL=1,NDDL
  375.                      JDDL=IORDO.LECT(IDDL)
  376. *********** Cette partie est un test que l'on pourrait supprimmer**********
  377. *                     NNQUA=MYLRF.NPQUAF(JDDL)
  378. *                     NNGLO=SOUMAI.NUM(NNQUA,I1EL)
  379. **                     do 99 jddl=1,nddl
  380. *                     NNGLO2=SOUMEL.NUM(IDDL,I1EL)
  381. **                        if (nnglo2.eq.nnglo) goto 999
  382. **     99                  continue
  383. *                     if (nnglo2.ne.nnglo) then
  384. *                        write(ioimp,*) 'Erreur grave'
  385. *                        write(ioimp,*) 'IDDL,NNQUA,JDDL=',IDDL,NNQUA
  386. *     $                       ,JDDL
  387. *                        write(ioimp,*) 'NNGLO,NNGLO2=',NNGLO,NNGLO2
  388. *                        goto 9999
  389. *                     endif
  390. ** 999                 continue
  391. ****************************************************************************
  392.                      IF (N1PTEL.EQ.1) THEN
  393.                         I1PTEL=1
  394.                      ELSE
  395.                         I1PTEL=IDDL
  396.                      ENDIF
  397.                      MZMCHA.WELCHE(1,JDDL,1,1,1,I1EL)=VELCHE(I1PTEL
  398.      $                    ,I1EL)
  399.                   ENDDO
  400.                ENDDO
  401.                SEGSUP IORDO
  402.                SEGSUP MPQUAF
  403.                SEGDES MZMCHA
  404.                MYMCHA.ICHEVA(ISOUS)=MZMCHA
  405.                SEGDES SOUMEL
  406.                SEGDES SOUMAI
  407.                MYMCHA.JMACHE(ISOUS)=SOUMAI
  408. *               IF (SOUMEL.NE.SOUMAI) SEGSUP SOUMEL
  409.  3          CONTINUE
  410. *        IMPR=6
  411.             IF (IMPR.GT.3) THEN
  412.                CALL PRCAEL(MYMCHA,IMPR,IRET)
  413.                IF (IRET.NE.0) GOTO 9999
  414.             ENDIF
  415. *         IMPR=0
  416.             SEGDES MYMCHA
  417.             SEGDES CGEOMQ
  418. *            SEGSUP MELEME
  419.             CALL DTCHAM(MCHELM)
  420.          ELSEIF (TYPCHA.EQ.'CHPOINT ') THEN
  421.             MYCHPO=ICHAM
  422. *
  423. * Transformation du chpoint en un objet MTRAV plus commode
  424. *
  425.             CALL CP2TRA(MYCHPO,
  426.      $           MYMTRA,LVIDE,
  427.      $           IMPR,IRET)
  428.             IF (IRET.NE.0) GOTO 9999
  429. *
  430. * Warning, si aucune valeur du chpoint n'a servi
  431. *
  432. *Pour débugger
  433.             LWARN=.TRUE.
  434. *     LWARN=.FALSE.
  435.             LINIZ=.FALSE.
  436. *
  437. * Segments de repérage dans MTRAV
  438. *
  439.             SEGACT MYMTRA
  440.             JGN=MYMTRA.INCO(/1)
  441.             NNIN=MYMTRA.INCO(/2)
  442.             NNNOE=MYMTRA.IGEO(/1)
  443. *  Création du segment de répérage dans IGEO
  444.             NTOGPO=nbpts
  445.             JG=NTOGPO
  446.             SEGINI,KRIGEO
  447.             CALL RSETEE(MYMTRA.IGEO,NNNOE,
  448.      $           KRIGEO.LECT,NTOGPO,
  449.      $           IMPR,IRET)
  450.             IF (IRET.NE.0) GOTO 9999
  451. *  Création du segment de repérage dans INCO
  452.             SEGACT MYLMOT
  453.             NNMDDL=MYLMOT.MOTS(/2)
  454.             JG=NNMDDL
  455.             SEGINI KRINCO
  456.             CALL CREPE2(JGN,NNMDDL,NNIN,
  457.      $           MYLMOT.MOTS,MYMTRA.INCO,
  458.      $           KRINCO.LECT,
  459.      $           IMPR,IRET)
  460.             IF (IRET.NE.0) GOTO 9999
  461. *
  462. * Création et remplissage du champ par éléments
  463. *
  464.             SEGACT CGEOMQ
  465.             NSOUS=CGEOMQ.LISOUS(/1)
  466.             N1=NSOUS
  467.             SEGINI MYMCHA
  468.             DO 1 ISOUS=1,NSOUS
  469.                SOUMAI=CGEOMQ.LISOUS(ISOUS)
  470.                SEGACT SOUMAI
  471. *            SEGPRT,SOUMAI
  472. * On cherche l'élément fini correspondant au QUAF
  473.                ITQUAF=SOUMAI.ITYPEL
  474.                CALL KEEF(ITQUAF,MYDISC,
  475.      $              MYFALS,
  476.      $              MYLRF,
  477.      $              IMPR,IRET)
  478.                IF (IRET.NE.0) GOTO 9999
  479. *               SEGPRT,MYLRF
  480.                SEGACT MYLRF
  481.                NDDL=MYLRF.NPQUAF(/1)
  482.                NBEL=SOUMAI.NUM(/2)
  483. * On initialise le MCHEVA a remplir
  484.                NBLIG=1
  485.                NBCOL=NDDL
  486.                N2LIG=1
  487.                N2COL=1
  488.                NBPOI=1
  489.                NBELM=NBEL
  490.                SEGINI MZMCHA
  491.                DO IBEL=1,NBEL
  492.                   DO IDDL=1,NDDL
  493.                      NNQUA=MYLRF.NPQUAF(IDDL)
  494.                      NNGLO=SOUMAI.NUM(NNQUA,IBEL)
  495.                      NNLOC=KRIGEO.LECT(NNGLO)
  496.                      NMQUA=MYLRF.NUMCMP(IDDL)
  497.                      NMLOC=KRINCO.LECT(NMQUA)
  498.                      IF (NNLOC.EQ.0.OR.NMLOC.EQ.0) THEN
  499.                         LINIZ=.TRUE.
  500.                         CONTRI=0.D0
  501.                      ELSE
  502.                         LDDLEX=MYMTRA.IBIN(NMLOC,NNLOC).EQ.1
  503.                         IF (.NOT.LDDLEX) THEN
  504.                            LINIZ=.TRUE.
  505.                            CONTRI=0.D0
  506.                         ELSE
  507.                            LWARN=.FALSE.
  508.                            CONTRI=MYMTRA.BB(NMLOC,NNLOC)
  509.                         ENDIF
  510.                      ENDIF
  511.                      MZMCHA.WELCHE(1,IDDL,1,1,1,IBEL)=CONTRI
  512.                   ENDDO
  513.                ENDDO
  514.                SEGDES MZMCHA
  515. *            SEGPRT,MZMCHA
  516.                MYMCHA.ICHEVA(ISOUS)=MZMCHA
  517.                SEGDES MYLRF
  518.                SEGDES SOUMAI
  519.                MYMCHA.JMACHE(ISOUS)=SOUMAI
  520.  1          CONTINUE
  521.             SEGDES MYMCHA
  522.             SEGDES CGEOMQ
  523.             SEGSUP KRINCO
  524.             SEGDES MYLMOT
  525.             SEGSUP KRIGEO
  526.             SEGSUP MYMTRA
  527. *      IMPR=6
  528.             IF (IMPR.GT.3) THEN
  529.                WRITE(IOIMP,*) 'On a créé',
  530.      $              ' MYMCHA(élément ,1, 1 , 1 ,1, ddl)'
  531.                CALL PRCAEL(MYMCHA,IMPR,IRET)
  532.                IF (IRET.NE.0) GOTO 9999
  533.             ENDIF
  534. *      IMPR=0
  535. *
  536. * Warning
  537. *
  538.             IF (LWARN.AND.(.NOT.LVIDE)) THEN
  539.                WRITE(IOIMP,*) 'Error : no values of the given CHPOINT',
  540.      $              ' were used'
  541.                GOTO 9999
  542.             ENDIF
  543.             IF (LINIZ) THEN
  544.                WRITE(IOIMP,*) 'Error : the given CHPOINT',
  545.      $              ' does not give all the required values'
  546.                GOTO 9999
  547.             ENDIF
  548.          ELSE
  549.             write(ioimp,*) 'TYPCHA=',TYPCHA,' unexpected'
  550.             goto 9999
  551.          ENDIF
  552.       ENDIF
  553. *
  554. * Normal termination
  555. *
  556.       IRET=0
  557.       RETURN
  558. *
  559. * Format handling
  560. *
  561. *
  562. * Error handling
  563. *
  564.  9999 CONTINUE
  565.       IRET=1
  566.       WRITE(IOIMP,*) 'An error was detected in subroutine cp2cv7'
  567.       RETURN
  568. *
  569. * End of subroutine CP2CV7
  570. *
  571.       END
  572.  
  573.  

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