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/08    11:01:44     12596          
  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.                NBSOUS=CGEOMQ.LISOUS(/1)
  265. *               write(ioimp,*) 'N1,NBSOUS=',N1,NBSOUS
  266.                IF (N1.NE.NBSOUS) LREDU=.FALSE.
  267.             ENDIF
  268.             IF (.NOT.LREDU) THEN
  269. * 609 2
  270. * Le champ n'est pas defini aux bons points supports
  271.                CALL ERREUR(609)
  272.                GOTO 9999
  273.             ENDIF
  274. *            write(ioimp,*) 'cp2cv7: Apres REDU'
  275. *            call ecrobj('MCHAML',MCHEL2)
  276. *            call prlist
  277. *            CALL ACTOBJ('MCHAML  ',MCHEL2,1)
  278. *           SEGPRT,MCHEL2
  279. * Osons...
  280.             CALL DTCHAM(MCHELM)
  281.             SEGSUP MMODEL
  282.             MCHELM=MCHEL2
  283.             IF (IDISC.NE.3) SEGSUP MELEME
  284. *
  285. * Création et remplissage du champ par éléments
  286. * En même temps, on supprime les MELEME crees.
  287. *            SEGACT MELEME
  288.             NSOUS=CGEOMQ.LISOUS(/1)
  289.             CALL ACTOBJ('MCHAML  ',MCHELM,1)
  290. *         write(ioimp,*) 'MCHELM=',MCHELM
  291.             N1=NSOUS
  292.             SEGINI MYMCHA
  293.             DO 3 ISOUS=1,NSOUS
  294. *               write(ioimp,*) 'isous=',isous
  295. *               write(ioimp,*) 'ichaml(/1)=',ichaml(/1)
  296. *               write(ioimp,*) 'lisous(/1)=',lisous(/1)
  297.                SOUMAI=CGEOMQ.LISOUS(ISOUS)
  298.                SEGACT SOUMAI
  299.                SOUMEL=IMACHE(ISOUS)
  300.                SEGACT SOUMEL
  301.                MCHAML=ICHAML(ISOUS)
  302.                N2=IELVAL(/1)
  303. * Normalement, 1 seule composante vu qu'on a reduit le champ dessus
  304.                IF (N2.NE.1) THEN
  305.                   WRITE(IOIMP,*) 'Programming error 4'
  306.                   GOTO 9999
  307.                ENDIF
  308.                IF (TYPCHE(1).NE.'REAL*8') THEN
  309.                   WRITE(IOIMP,*) 'Error : component ',NOMCHE(1)
  310.      $                 ,' not REAL*8 in the MCHAML object'
  311.                   GOTO 9999
  312.                ENDIF
  313. *               write(ioimp,*) 'N1,N2=',N1,N2
  314. *            do i=1,n2
  315. *               write(ioimp,*) 'i,nomche',i,nomche(i)
  316. *            enddo
  317. *     SEGPRT,MYLMOT
  318. *            SEGPRT,MCHAML
  319.                ITQUAF=SOUMAI.ITYPEL
  320.                CALL KEEF(ITQUAF,MYDISC,
  321.      $              MYFALS,
  322.      $              MYLRF,
  323.      $              IMPR,IRET)
  324.                IF (IRET.NE.0) GOTO 9999
  325.                SEGACT MYLRF
  326.                NDDL=MYLRF.NPQUAF(/1)
  327.                NDDL2=SOUMEL.NUM(/1)
  328.                if (NDDL.NE.NDDL2) then
  329.                   write(ioimp,*) 'Erreur grave dimensions soumel'
  330.                   goto 9999
  331.                endif
  332.                NBEL=SOUMEL.NUM(/2)
  333.                MELVAL=IELVAL(1)
  334.                N1PTEL=VELCHE(/1)
  335.                N1EL=VELCHE(/2)
  336.                IF ((N1PTEL.NE.NDDL.AND.N1PTEL.NE.1).OR.
  337.      $             (N1EL.NE.1.AND.N1EL.NE.NBEL)) THEN
  338.                   write(ioimp,*) 'Erreur grave dimensions MELVAL'
  339.                   write(ioimp,*) 'N1PTEL,NDDL=',N1PTEL,NDDL
  340.                   write(ioimp,*) 'N1EL,NBEL=',N1EL,NBEL
  341.                   GOTO 9999
  342.                ENDIF
  343. * On initialise le MCHEVA a remplir
  344.                NBLIG=1
  345.                NBCOL=NDDL
  346.                N2LIG=1
  347.                N2COL=1
  348.                NBPOI=1
  349.                NBELM=N1EL
  350.                SEGINI MZMCHA
  351. *     Construisons le segment qui permet de parcourir les ddl dans
  352. *     l'ordre croissant des points du quaf
  353. *     Implicitement, on utilise le fait que les maillages LINE et QUAD
  354. *     parcourent les points du QUAF en croissant aussi.
  355. *     On utilise le tri par insertion car les listes sont petites
  356.                JG=NDDL
  357.                SEGINI MPQUAF
  358.                SEGINI IORDO
  359.                DO IG=1,JG
  360.                   MPQUAF.LECT(IG)=MYLRF.NPQUAF(IG)
  361.                   IORDO.LECT(IG)=IG
  362.                ENDDO
  363.                LCROI=.TRUE.
  364.                CALL ORDO04(MPQUAF.LECT(1),NDDL,LCROI,IORDO.LECT(1))
  365.                SEGDES MYLRF
  366. *
  367. *               DO IDDL=1,NDDL
  368. *                  write(ioimp,*) 'I,NPQUAF,IORDO=',IDDL
  369. *     $                 ,MYLRF.NPQUAF(IDDL),IORDO.LECT(IDDL)
  370. *               ENDDO
  371. *               SEGPRT,MYLRF
  372. *               SEGPRT,SOUMAI
  373. *               SEGPRT,SOUMEL
  374. *               SEGPRT,IORDO
  375.                DO I1EL=1,N1EL
  376.                   DO IDDL=1,NDDL
  377.                      JDDL=IORDO.LECT(IDDL)
  378. *********** Cette partie est un test que l'on pourrait supprimmer**********
  379. *                     NNQUA=MYLRF.NPQUAF(JDDL)
  380. *                     NNGLO=SOUMAI.NUM(NNQUA,I1EL)
  381. **                     do 99 jddl=1,nddl
  382. *                     NNGLO2=SOUMEL.NUM(IDDL,I1EL)
  383. **                        if (nnglo2.eq.nnglo) goto 999
  384. **     99                  continue
  385. *                     if (nnglo2.ne.nnglo) then
  386. *                        write(ioimp,*) 'Erreur grave'
  387. *                        write(ioimp,*) 'IDDL,NNQUA,JDDL=',IDDL,NNQUA
  388. *     $                       ,JDDL
  389. *                        write(ioimp,*) 'NNGLO,NNGLO2=',NNGLO,NNGLO2
  390. *                        goto 9999
  391. *                     endif
  392. ** 999                 continue
  393. ****************************************************************************
  394.                      IF (N1PTEL.EQ.1) THEN
  395.                         I1PTEL=1
  396.                      ELSE
  397.                         I1PTEL=IDDL
  398.                      ENDIF
  399.                      MZMCHA.WELCHE(1,JDDL,1,1,1,I1EL)=VELCHE(I1PTEL
  400.      $                    ,I1EL)
  401.                   ENDDO
  402.                ENDDO
  403.                SEGSUP IORDO
  404.                SEGSUP MPQUAF
  405.                SEGDES MZMCHA
  406.                MYMCHA.ICHEVA(ISOUS)=MZMCHA
  407.                SEGDES SOUMEL
  408.                SEGDES SOUMAI
  409.                MYMCHA.JMACHE(ISOUS)=SOUMAI
  410. *               IF (SOUMEL.NE.SOUMAI) SEGSUP SOUMEL
  411.  3          CONTINUE
  412. *        IMPR=6
  413.             IF (IMPR.GT.3) THEN
  414.                CALL PRCAEL(MYMCHA,IMPR,IRET)
  415.                IF (IRET.NE.0) GOTO 9999
  416.             ENDIF
  417. *         IMPR=0
  418.             SEGDES MYMCHA
  419.             SEGDES CGEOMQ
  420. *            SEGSUP MELEME
  421.             CALL DTCHAM(MCHELM)
  422.          ELSEIF (TYPCHA.EQ.'CHPOINT ') THEN
  423.             MYCHPO=ICHAM
  424. *
  425. * Transformation du chpoint en un objet MTRAV plus commode
  426. *
  427.             CALL CP2TRA(MYCHPO,
  428.      $           MYMTRA,LVIDE,
  429.      $           IMPR,IRET)
  430.             IF (IRET.NE.0) GOTO 9999
  431. *
  432. * Warning, si aucune valeur du chpoint n'a servi
  433. *
  434. *Pour débugger
  435.             LWARN=.TRUE.
  436. *     LWARN=.FALSE.
  437.             LINIZ=.FALSE.
  438. *
  439. * Segments de repérage dans MTRAV
  440. *
  441.             SEGACT MYMTRA
  442.             JGN=MYMTRA.INCO(/1)
  443.             NNIN=MYMTRA.INCO(/2)
  444.             NNNOE=MYMTRA.IGEO(/1)
  445. *  Création du segment de répérage dans IGEO
  446.             NTOGPO=nbpts
  447.             JG=NTOGPO
  448.             SEGINI,KRIGEO
  449.             CALL RSETEE(MYMTRA.IGEO,NNNOE,
  450.      $           KRIGEO.LECT,NTOGPO,
  451.      $           IMPR,IRET)
  452.             IF (IRET.NE.0) GOTO 9999
  453. *  Création du segment de repérage dans INCO
  454.             SEGACT MYLMOT
  455.             NNMDDL=MYLMOT.MOTS(/2)
  456.             JG=NNMDDL
  457.             SEGINI KRINCO
  458.             CALL CREPE2(JGN,NNMDDL,NNIN,
  459.      $           MYLMOT.MOTS,MYMTRA.INCO,
  460.      $           KRINCO.LECT,
  461.      $           IMPR,IRET)
  462.             IF (IRET.NE.0) GOTO 9999
  463. *
  464. * Création et remplissage du champ par éléments
  465. *
  466.             SEGACT CGEOMQ
  467.             NSOUS=CGEOMQ.LISOUS(/1)
  468.             N1=NSOUS
  469.             SEGINI MYMCHA
  470.             DO 1 ISOUS=1,NSOUS
  471.                SOUMAI=CGEOMQ.LISOUS(ISOUS)
  472.                SEGACT SOUMAI
  473. *            SEGPRT,SOUMAI
  474. * On cherche l'élément fini correspondant au QUAF
  475.                ITQUAF=SOUMAI.ITYPEL
  476.                CALL KEEF(ITQUAF,MYDISC,
  477.      $              MYFALS,
  478.      $              MYLRF,
  479.      $              IMPR,IRET)
  480.                IF (IRET.NE.0) GOTO 9999
  481. *               SEGPRT,MYLRF
  482.                SEGACT MYLRF
  483.                NDDL=MYLRF.NPQUAF(/1)
  484.                NBEL=SOUMAI.NUM(/2)
  485. * On initialise le MCHEVA a remplir
  486.                NBLIG=1
  487.                NBCOL=NDDL
  488.                N2LIG=1
  489.                N2COL=1
  490.                NBPOI=1
  491.                NBELM=NBEL
  492.                SEGINI MZMCHA
  493.                DO IBEL=1,NBEL
  494.                   DO IDDL=1,NDDL
  495.                      NNQUA=MYLRF.NPQUAF(IDDL)
  496.                      NNGLO=SOUMAI.NUM(NNQUA,IBEL)
  497.                      NNLOC=KRIGEO.LECT(NNGLO)
  498.                      NMQUA=MYLRF.NUMCMP(IDDL)
  499.                      NMLOC=KRINCO.LECT(NMQUA)
  500.                      IF (NNLOC.EQ.0.OR.NMLOC.EQ.0) THEN
  501.                         LINIZ=.TRUE.
  502.                         CONTRI=0.D0
  503.                      ELSE
  504.                         LDDLEX=MYMTRA.IBIN(NMLOC,NNLOC).EQ.1
  505.                         IF (.NOT.LDDLEX) THEN
  506.                            LINIZ=.TRUE.
  507.                            CONTRI=0.D0
  508.                         ELSE
  509.                            LWARN=.FALSE.
  510.                            CONTRI=MYMTRA.BB(NMLOC,NNLOC)
  511.                         ENDIF
  512.                      ENDIF
  513.                      MZMCHA.WELCHE(1,IDDL,1,1,1,IBEL)=CONTRI
  514.                   ENDDO
  515.                ENDDO
  516.                SEGDES MZMCHA
  517. *            SEGPRT,MZMCHA
  518.                MYMCHA.ICHEVA(ISOUS)=MZMCHA
  519.                SEGDES MYLRF
  520.                SEGDES SOUMAI
  521.                MYMCHA.JMACHE(ISOUS)=SOUMAI
  522.  1          CONTINUE
  523.             SEGDES MYMCHA
  524.             SEGDES CGEOMQ
  525.             SEGSUP KRINCO
  526.             SEGDES MYLMOT
  527.             SEGSUP KRIGEO
  528.             SEGSUP MYMTRA
  529. *      IMPR=6
  530.             IF (IMPR.GT.3) THEN
  531.                WRITE(IOIMP,*) 'On a créé',
  532.      $              ' MYMCHA(élément ,1, 1 , 1 ,1, ddl)'
  533.                CALL PRCAEL(MYMCHA,IMPR,IRET)
  534.                IF (IRET.NE.0) GOTO 9999
  535.             ENDIF
  536. *      IMPR=0
  537. *
  538. * Warning
  539. *
  540.             IF (LWARN.AND.(.NOT.LVIDE)) THEN
  541.                WRITE(IOIMP,*) 'Error : no values of the given CHPOINT',
  542.      $              ' were used'
  543.                GOTO 9999
  544.             ENDIF
  545.             IF (LINIZ) THEN
  546.                WRITE(IOIMP,*) 'Error : the given CHPOINT',
  547.      $              ' does not give all the required values'
  548.                GOTO 9999
  549.             ENDIF
  550.          ELSE
  551.             write(ioimp,*) 'TYPCHA=',TYPCHA,' unexpected'
  552.             goto 9999
  553.          ENDIF
  554.       ENDIF
  555. *
  556. * Normal termination
  557. *
  558.       IRET=0
  559.       RETURN
  560. *
  561. * Format handling
  562. *
  563. *
  564. * Error handling
  565. *
  566.  9999 CONTINUE
  567.       IRET=1
  568.       WRITE(IOIMP,*) 'An error was detected in subroutine cp2cv7'
  569.       RETURN
  570. *
  571. * End of subroutine CP2CV7
  572. *
  573.       END
  574.  
  575.  

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