Télécharger la plaquette Cast3M


fr en

Télécharger demete.eso

Retour à la liste

Numérotation des lignes : 

demete

  1. C DEMETE    SOURCE    PV        20/04/01    21:15:26     10569          
  2. C|-------------------------------------------------------------------|
  3. C|                                                                   |
  4. C|                 INTERFACE ENTRE VOLUME ET DEMAIT                  |
  5. C|              ALLOUE LES TABLEAUX ET LES INITIALISE                |
  6. C|                                                                   |
  7. C|-------------------------------------------------------------------|
  8. C
  9.        SUBROUTINE DEMETE(MELEME)
  10. C
  11.       IMPLICIT INTEGER(I-N)
  12.       IMPLICIT REAL*8(A-H,O-Z)
  13.       SEGMENT ICPR(nbpts)
  14.       SEGMENT IDCP(NPTINI)
  15. -INC SMCOORD
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC CCGEOME
  20. -INC SMELEME
  21. -INC TDEMAIT
  22.        DATA  IPREM/0/
  23.        IF (IDIM.NE.3) CALL ERREUR(16)
  24.        IF (IERR.NE.0) RETURN
  25.        MELSUR=MELEME
  26.        IPT8=MELEME
  27.        SEGACT MELEME
  28.        NBELEM=NUM(/2)
  29.        NBSOUS=LISOUS(/1)
  30.        IF (NBSOUS.EQ.0) GOTO 100
  31.        DO 10 IOB=1,NBSOUS
  32.         IPT1=LISOUS(IOB)
  33.         SEGACT IPT1
  34.         NBELEM=NBELEM+IPT1.NUM(/2)
  35.   10  CONTINUE
  36.  100  CONTINUE
  37. *  LES DIMENSIONS SERONT AJUSTEES EN FONCTION DES BESOINS DANS DEMAIT
  38.       NFTOT=NBELEM+100
  39.       SEGINI NFC
  40.       SEGINI NFV
  41.       SEGACT MCOORD*mod
  42.       SEGINI ICPR
  43. C*      DO 200 I=1,nbpts
  44. C*      ICPR(I)=0
  45. C* 200  CONTINUE
  46.       IK=0
  47.       IELBAS=0
  48.       IPT1=MELEME
  49.       IDEGR=0
  50.       DO 220 IOB=1,MAX(1,LISOUS(/1))
  51.       IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB)
  52.       L=IPT1.NUM(/1)
  53.       IF (IDEGR.EQ.0) THEN
  54.         IF (IPT1.ITYPEL.EQ.4.OR.IPT1.ITYPEL.EQ.8) IDEGR=1
  55.         IF (IPT1.ITYPEL.EQ.6.OR.IPT1.ITYPEL.EQ.10) IDEGR=2
  56.       ELSEIF (IDEGR.EQ.1) THEN
  57.         IF (IPT1.ITYPEL.EQ.6.OR.IPT1.ITYPEL.EQ.10) CALL ERREUR(16)
  58.       ELSEIF (IDEGR.EQ.2) THEN
  59.         IF (IPT1.ITYPEL.EQ.4.OR.IPT1.ITYPEL.EQ.8) CALL ERREUR(16)
  60.       ENDIF
  61.       IF (IDEGR.EQ.0) CALL ERREUR(16)
  62.       IF (IERR.NE.0) GOTO 1000
  63.       DO 230 INB=1,L,IDEGR
  64.       DO 230 IEL=1,IPT1.NUM(/2)
  65.       IP=IPT1.NUM(INB,IEL)
  66.       IF (ICPR(IP).NE.0) GOTO 240
  67.       IK=IK+1
  68.       ICPR(IP)=IK
  69.  240  CONTINUE
  70.       NFC((INB-1)/IDEGR+1,IEL+IELBAS)=ICPR(IP)
  71.  230  CONTINUE
  72.       IF (L.EQ.4.OR.L.EQ.8) GOTO 260
  73.       DO 250 IEL=1,IPT1.NUM(/2)
  74.       NFC(4,IEL+IELBAS)=0
  75.  250  CONTINUE
  76.  260  CONTINUE
  77.       IELBAS=IELBAS+IPT1.NUM(/2)
  78.       IF (LISOUS(/1).NE.0) SEGDES IPT1
  79.  220  CONTINUE
  80.       NVTOT=50
  81.       NPTOT=IK+50
  82.       SEGINI NPF,IFUT,XYZ,IVOL,IFAT
  83.       SEGDES MELEME
  84.       NFCMAX=IELBAS
  85.       NFACET=NFCMAX
  86.       NVOL=0
  87.       NPTMAX=IK
  88.       NPTINI=NPTMAX
  89.       SEGINI IDCP
  90.       DO 500 I=1,nbpts
  91.       if (icpr(i).ne.0) IDCP(ICPR(I))=I
  92.  500  CONTINUE
  93. C  REMPLIR IFUT
  94.       DO 400 I=1,NFACET
  95.       IFUT(I)=I
  96.  400  CONTINUE
  97.       DO 300 IP=1,nbpts
  98.       IPL=ICPR(IP)
  99.       IF (IPL.EQ.0) GOTO 300
  100.       IREF=4*(IP-1)
  101.       DO 310 IC=1,3
  102.       XYZ(IC,IPL)=XCOOR(IREF+IC)
  103.  310  CONTINUE
  104.  300  CONTINUE
  105.       SEGSUP ICPR
  106.       IF (IPREM.EQ.0.AND.IVERB.EQ.1) WRITE (IOIMP,*)
  107.      # ' DEMETE VERSION 2.0.beta (C) CEA/SEMT - P VERPEAUX '
  108.       IPREM=1
  109. *     WRITE (IOIMP,2000) NFCMAX,NFACET,NVOL,NPTMAX
  110. *2000 FORMAT (' DEMETE NFCMAX ',I5,' NFACET ',I5,' NVOL ',I5,
  111. *    # ' NPTMAX ',I5)
  112.       NPTBAS=nbpts
  113.       IF (IVERB.EQ.1) WRITE(IOIMP,*) ' nptbas,nptini ',nptbas,nptini
  114.       CALL DEMAIT(idcp,nptbas)
  115.       IF (IERR.NE.0) GOTO 1100
  116.       IF (NVOL.EQ.0) GOTO 1100
  117.       IF (IVERB.EQ.1) WRITE (IOIMP,*) ' DEMETE  MISSION ACCOMPLIE '
  118. *     WRITE (IOIMP,9702) NPTBAS,NPTINI,NPTMAX
  119. *9702 FORMAT(' DEMETE NPTBAS ',I5,' NPTINI ',I5,' NPTMAX ',I5)
  120.       IF (NPTINI.EQ.NPTMAX) GOTO 5001
  121.       NBPTA=nbpts
  122.       NBPTS=NBPTA+NPTMAX-NPTINI
  123.       SEGADJ MCOORD
  124.       DO 5000 I=NPTINI+1,NPTMAX
  125.       DO 5010 J=1,4
  126.       XCOOR(NBPTA*4+J)=XYZ(J,I)
  127.  5010 CONTINUE
  128.       NBPTA=NBPTA+1
  129.  5000 CONTINUE
  130.  5001 CONTINUE
  131.       NHE=0
  132.       NPR=0
  133.       NPY=0
  134.       NTE=0
  135.       DO 5800 I=1,NVOL
  136.       IF (IVOL(9,I).NE.20) GOTO 5805
  137.       NHE=NHE+1
  138.       GOTO 5800
  139.  5805 IF (IVOL(9,I).NE.30) GOTO 5810
  140.       NPR=NPR+1
  141.       GOTO 5800
  142.  5810 IF (IVOL(9,I).NE.35) GOTO 5815
  143.       NPY=NPY+1
  144.       GOTO 5800
  145.  5815 IF (IVOL(9,I).NE.25) GOTO 5800
  146.       NTE=NTE+1
  147.  5800 CONTINUE
  148.        IF (IVERB.EQ.1) WRITE (IOIMP,50002) NHE,NPR,NPY,NTE
  149. 50002 FORMAT(' HEXAEDRES PRISMES PYRAMIDES TETRAEDRES ',4I6)
  150. C  POUR EVITER LES ENNUIS AVEC L'OPTIMISEUR
  151.       IPT1=IVOL
  152.       IPT2=IVOL
  153.       IPT3=IVOL
  154.       IPT4=IVOL
  155.       IPT5=IVOL
  156.       NBS=0
  157.       NBSOUS=0
  158.       NBREF=0
  159.       IF (NHE.EQ.0) GOTO 5900
  160.       NBNN=8
  161.       NBELEM=NHE
  162.       SEGINI IPT1
  163.       IPT5=IPT1
  164.       IPT1.ITYPEL=14
  165.       NBS=NBS+1
  166.  5900 IF (NPR.EQ.0) GOTO 5901
  167.       NBNN=6
  168.       NBELEM=NPR
  169.       SEGINI IPT2
  170.       IPT5=IPT2
  171.       IPT2.ITYPEL=16
  172.       NBS=NBS+1
  173.  5901 IF (NPY.EQ.0) GOTO 5902
  174.       NBNN=5
  175.       NBELEM=NPY
  176.       SEGINI IPT3
  177.       IPT5=IPT3
  178.       IPT3.ITYPEL=25
  179.       NBS=NBS+1
  180.  5902 IF (NTE.EQ.0) GOTO 5903
  181.       NBNN=4
  182.       NBELEM=NTE
  183.       SEGINI IPT4
  184.       IPT5=IPT4
  185.       IPT4.ITYPEL=23
  186.       NBS=NBS+1
  187.  5903 CONTINUE
  188.       NHE=0
  189.       NPR=0
  190.       NPY=0
  191.       NTE=0
  192.       DO 6000 I=1,NVOL
  193.       IF (IVOL(9,I).NE.20) GOTO 6010
  194.       NHE=NHE+1
  195.       IPT1.ICOLOR(NHE)=IDCOUL
  196.       DO 6001 J=1,8
  197.       IP=IVOL(J,I)
  198.       IF (IP.LE.NPTINI) THEN
  199.         IPT1.NUM(J,NHE)=IDCP(IP)
  200.       ELSE
  201.         IPT1.NUM(J,NHE)=IP-NPTINI+NPTBAS
  202.       ENDIF
  203.  6001 CONTINUE
  204.       GOTO 6000
  205.  6010 IF (IVOL(9,I).NE.30) GOTO 6020
  206.       NPR=NPR+1
  207.       IPT2.ICOLOR(NPR)=IDCOUL
  208.       DO 6011 J=1,6
  209.       IP=IVOL(J,I)
  210.       IF (IP.LE.NPTINI) THEN
  211.         IPT2.NUM(J,NPR)=IDCP(IP)
  212.       ELSE
  213.         IPT2.NUM(J,NPR)=IP-NPTINI+NPTBAS
  214.       ENDIF
  215.  6011 CONTINUE
  216.       GOTO 6000
  217.  6020 IF (IVOL(9,I).NE.35) GOTO 6030
  218.       NPY=NPY+1
  219.       IPT3.ICOLOR(NPY)=IDCOUL
  220.       DO 6021 J=1,5
  221.       IP=IVOL(J,I)
  222.       IF (IP.LE.NPTINI) THEN
  223.         IPT3.NUM(J,NPY)=IDCP(IP)
  224.       ELSE
  225.         IPT3.NUM(J,NPY)=IP-NPTINI+NPTBAS
  226.       ENDIF
  227.  6021 CONTINUE
  228.       GOTO 6000
  229.  6030 IF (IVOL(9,I).NE.25) GOTO 6000
  230.       NTE=NTE+1
  231.       IPT4.ICOLOR(NTE)=IDCOUL
  232.       DO 6031 J=1,4
  233.       IP=IVOL(J,I)
  234.       IF (IP.LE.NPTINI) THEN
  235.         IPT4.NUM(J,NTE)=IDCP(IP)
  236.       ELSE
  237.         IPT4.NUM(J,NTE)=IP-NPTINI+NPTBAS
  238.       ENDIF
  239.  6031 CONTINUE
  240.  6000 CONTINUE
  241.       IF (NBS.EQ.1) GOTO 6200
  242.       NBREF=1
  243.       NBELEM=0
  244.       NBNN=0
  245.       NBSOUS=NBS
  246.       SEGINI MELEME
  247.       LISREF(1)=IPT8
  248.       NBS=0
  249.       IF (NHE.EQ.0) GOTO 6100
  250.       NBS=NBS+1
  251.       LISOUS(NBS)=IPT1
  252.       NBNN=IPT1.NUM(/1)
  253.       NBELEM=IPT1.NUM(/2)
  254.       SEGDES IPT1
  255.  6100 IF (NPR.EQ.0) GOTO 6101
  256.       NBS=NBS+1
  257.       LISOUS(NBS)=IPT2
  258.       SEGDES IPT2
  259.  6101 IF (NPY.EQ.0) GOTO 6102
  260.       NBS=NBS+1
  261.       LISOUS(NBS)=IPT3
  262.       SEGDES IPT3
  263.  6102 IF (NTE.EQ.0) GOTO 6103
  264.       NBS=NBS+1
  265.       LISOUS(NBS)=IPT4
  266.       SEGDES IPT4
  267.  6103 CONTINUE
  268.       SEGDES MELEME
  269.       GOTO 1100
  270.  1100 SEGSUP IDCP
  271.       GOTO 1020
  272.  6200 CONTINUE
  273.       NBREF=1
  274.       NBSOUS=0
  275.       NBNN=IPT5.NUM(/1)
  276.       NBELEM=IPT5.NUM(/2)
  277.       SEGINI MELEME
  278.       LISREF(1)=IPT8
  279.       ITYPEL=IPT5.ITYPEL
  280.       DO 6210 J=1,NBELEM
  281.       ICOLOR(J)=IPT5.ICOLOR(J)
  282.       DO 6210 I=1,NBNN
  283.       NUM(I,J)=IPT5.NUM(I,J)
  284.  6210 CONTINUE
  285.       SEGSUP IPT5
  286.       SEGDES MELEME
  287.       GOTO 1100
  288.  1000 SEGSUP ICPR
  289.  1020 SEGSUP NFC,NFV,NPF,IFUT,XYZ,IVOL,ICPR,IFAT
  290.       IF (IDEGR.EQ.2) CALL DEMCHA(MELSUR,MELEME)
  291.       RETURN
  292.       END
  293.  
  294.  
  295.  
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  

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