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    CB215821  26/08/24    21:16:03     12622          
  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 50003 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. 50003 CONTINUE
  73.       IF (L.EQ.4.OR.L.EQ.8) GOTO 260
  74.       DO 250 IEL=1,IPT1.NUM(/2)
  75.       NFC(4,IEL+IELBAS)=0
  76.  250  CONTINUE
  77.  260  CONTINUE
  78.       IELBAS=IELBAS+IPT1.NUM(/2)
  79.       IF (LISOUS(/1).NE.0) SEGDES IPT1
  80.  220  CONTINUE
  81.       NVTOT=50
  82.       NPTOT=IK+50
  83.       SEGINI NPF,IFUT,XYZ,IVOL,IFAT
  84.       SEGDES MELEME
  85.       NFCMAX=IELBAS
  86.       NFACET=NFCMAX
  87.       NVOL=0
  88.       NPTMAX=IK
  89.       NPTINI=NPTMAX
  90.       SEGINI IDCP
  91.       DO 500 I=1,nbpts
  92.       if (icpr(i).ne.0) IDCP(ICPR(I))=I
  93.  500  CONTINUE
  94. C  REMPLIR IFUT
  95.       DO 400 I=1,NFACET
  96.       IFUT(I)=I
  97.  400  CONTINUE
  98.       DO 300 IP=1,nbpts
  99.       IPL=ICPR(IP)
  100.       IF (IPL.EQ.0) GOTO 300
  101.       IREF=4*(IP-1)
  102.       DO 310 IC=1,3
  103.       XYZ(IC,IPL)=XCOOR(IREF+IC)
  104.  310  CONTINUE
  105.  300  CONTINUE
  106.       SEGSUP ICPR
  107.       IF (IPREM.EQ.0.AND.IVERB.EQ.1) WRITE (IOIMP,*)
  108.      # ' DEMETE VERSION 2.0.beta (C) CEA/SEMT - P VERPEAUX '
  109.       IPREM=1
  110. *     WRITE (IOIMP,2000) NFCMAX,NFACET,NVOL,NPTMAX
  111. *2000 FORMAT (' DEMETE NFCMAX ',I5,' NFACET ',I5,' NVOL ',I5,
  112. *    # ' NPTMAX ',I5)
  113.       NPTBAS=nbpts
  114.       IF (IVERB.EQ.1) WRITE(IOIMP,*) ' nptbas,nptini ',nptbas,nptini
  115.       CALL DEMAIT(idcp,nptbas)
  116.       IF (IERR.NE.0) GOTO 1100
  117.       IF (NVOL.EQ.0) GOTO 1100
  118.       IF (IVERB.EQ.1) WRITE (IOIMP,*) ' DEMETE  MISSION ACCOMPLIE '
  119. *     WRITE (IOIMP,9702) NPTBAS,NPTINI,NPTMAX
  120. *9702 FORMAT(' DEMETE NPTBAS ',I5,' NPTINI ',I5,' NPTMAX ',I5)
  121.       IF (NPTINI.EQ.NPTMAX) GOTO 5001
  122.       NBPTA=nbpts
  123.       NBPTS=NBPTA+NPTMAX-NPTINI
  124.       SEGADJ MCOORD
  125.       DO 5000 I=NPTINI+1,NPTMAX
  126.       DO 5010 J=1,4
  127.       XCOOR(NBPTA*4+J)=XYZ(J,I)
  128.  5010 CONTINUE
  129.       NBPTA=NBPTA+1
  130.  5000 CONTINUE
  131.  5001 CONTINUE
  132.       NHE=0
  133.       NPR=0
  134.       NPY=0
  135.       NTE=0
  136.       DO 5800 I=1,NVOL
  137.       IF (IVOL(9,I).NE.20) GOTO 5805
  138.       NHE=NHE+1
  139.       GOTO 5800
  140.  5805 IF (IVOL(9,I).NE.30) GOTO 5810
  141.       NPR=NPR+1
  142.       GOTO 5800
  143.  5810 IF (IVOL(9,I).NE.35) GOTO 5815
  144.       NPY=NPY+1
  145.       GOTO 5800
  146.  5815 IF (IVOL(9,I).NE.25) GOTO 5800
  147.       NTE=NTE+1
  148.  5800 CONTINUE
  149.        IF (IVERB.EQ.1) WRITE (IOIMP,50002) NHE,NPR,NPY,NTE
  150. 50002 FORMAT(' HEXAEDRES PRISMES PYRAMIDES TETRAEDRES ',4I6)
  151. C  POUR EVITER LES ENNUIS AVEC L'OPTIMISEUR
  152.       IPT1=IVOL
  153.       IPT2=IVOL
  154.       IPT3=IVOL
  155.       IPT4=IVOL
  156.       IPT5=IVOL
  157.       NBS=0
  158.       NBSOUS=0
  159.       NBREF=0
  160.       IF (NHE.EQ.0) GOTO 5900
  161.       NBNN=8
  162.       NBELEM=NHE
  163.       SEGINI IPT1
  164.       IPT5=IPT1
  165.       IPT1.ITYPEL=14
  166.       NBS=NBS+1
  167.  5900 IF (NPR.EQ.0) GOTO 5901
  168.       NBNN=6
  169.       NBELEM=NPR
  170.       SEGINI IPT2
  171.       IPT5=IPT2
  172.       IPT2.ITYPEL=16
  173.       NBS=NBS+1
  174.  5901 IF (NPY.EQ.0) GOTO 5902
  175.       NBNN=5
  176.       NBELEM=NPY
  177.       SEGINI IPT3
  178.       IPT5=IPT3
  179.       IPT3.ITYPEL=25
  180.       NBS=NBS+1
  181.  5902 IF (NTE.EQ.0) GOTO 5903
  182.       NBNN=4
  183.       NBELEM=NTE
  184.       SEGINI IPT4
  185.       IPT5=IPT4
  186.       IPT4.ITYPEL=23
  187.       NBS=NBS+1
  188.  5903 CONTINUE
  189.       NHE=0
  190.       NPR=0
  191.       NPY=0
  192.       NTE=0
  193.       DO 6000 I=1,NVOL
  194.       IF (IVOL(9,I).NE.20) GOTO 6010
  195.       NHE=NHE+1
  196.       IPT1.ICOLOR(NHE)=IDCOUL
  197.       DO 6001 J=1,8
  198.       IP=IVOL(J,I)
  199.       IF (IP.LE.NPTINI) THEN
  200.         IPT1.NUM(J,NHE)=IDCP(IP)
  201.       ELSE
  202.         IPT1.NUM(J,NHE)=IP-NPTINI+NPTBAS
  203.       ENDIF
  204.  6001 CONTINUE
  205.       GOTO 6000
  206.  6010 IF (IVOL(9,I).NE.30) GOTO 6020
  207.       NPR=NPR+1
  208.       IPT2.ICOLOR(NPR)=IDCOUL
  209.       DO 6011 J=1,6
  210.       IP=IVOL(J,I)
  211.       IF (IP.LE.NPTINI) THEN
  212.         IPT2.NUM(J,NPR)=IDCP(IP)
  213.       ELSE
  214.         IPT2.NUM(J,NPR)=IP-NPTINI+NPTBAS
  215.       ENDIF
  216.  6011 CONTINUE
  217.       GOTO 6000
  218.  6020 IF (IVOL(9,I).NE.35) GOTO 6030
  219.       NPY=NPY+1
  220.       IPT3.ICOLOR(NPY)=IDCOUL
  221.       DO 6021 J=1,5
  222.       IP=IVOL(J,I)
  223.       IF (IP.LE.NPTINI) THEN
  224.         IPT3.NUM(J,NPY)=IDCP(IP)
  225.       ELSE
  226.         IPT3.NUM(J,NPY)=IP-NPTINI+NPTBAS
  227.       ENDIF
  228.  6021 CONTINUE
  229.       GOTO 6000
  230.  6030 IF (IVOL(9,I).NE.25) GOTO 6000
  231.       NTE=NTE+1
  232.       IPT4.ICOLOR(NTE)=IDCOUL
  233.       DO 6031 J=1,4
  234.       IP=IVOL(J,I)
  235.       IF (IP.LE.NPTINI) THEN
  236.         IPT4.NUM(J,NTE)=IDCP(IP)
  237.       ELSE
  238.         IPT4.NUM(J,NTE)=IP-NPTINI+NPTBAS
  239.       ENDIF
  240.  6031 CONTINUE
  241.  6000 CONTINUE
  242.       IF (NBS.EQ.1) GOTO 6200
  243.       NBREF=1
  244.       NBELEM=0
  245.       NBNN=0
  246.       NBSOUS=NBS
  247.       SEGINI MELEME
  248.       LISREF(1)=IPT8
  249.       NBS=0
  250.       IF (NHE.EQ.0) GOTO 6100
  251.       NBS=NBS+1
  252.       LISOUS(NBS)=IPT1
  253.       NBNN=IPT1.NUM(/1)
  254.       NBELEM=IPT1.NUM(/2)
  255.       SEGDES IPT1
  256.  6100 IF (NPR.EQ.0) GOTO 6101
  257.       NBS=NBS+1
  258.       LISOUS(NBS)=IPT2
  259.       SEGDES IPT2
  260.  6101 IF (NPY.EQ.0) GOTO 6102
  261.       NBS=NBS+1
  262.       LISOUS(NBS)=IPT3
  263.       SEGDES IPT3
  264.  6102 IF (NTE.EQ.0) GOTO 6103
  265.       NBS=NBS+1
  266.       LISOUS(NBS)=IPT4
  267.       SEGDES IPT4
  268.  6103 CONTINUE
  269.       SEGDES MELEME
  270.       GOTO 1100
  271.  1100 SEGSUP IDCP
  272.       GOTO 1020
  273.  6200 CONTINUE
  274.       NBREF=1
  275.       NBSOUS=0
  276.       NBNN=IPT5.NUM(/1)
  277.       NBELEM=IPT5.NUM(/2)
  278.       SEGINI MELEME
  279.       LISREF(1)=IPT8
  280.       ITYPEL=IPT5.ITYPEL
  281.       DO 50004 J=1,NBELEM
  282.       ICOLOR(J)=IPT5.ICOLOR(J)
  283.       DO 6210 I=1,NBNN
  284.       NUM(I,J)=IPT5.NUM(I,J)
  285.  6210 CONTINUE
  286. 50004 CONTINUE
  287.       SEGSUP IPT5
  288.       SEGDES MELEME
  289.       GOTO 1100
  290.  1000 SEGSUP ICPR
  291.  1020 SEGSUP NFC,NFV,NPF,IFUT,XYZ,IVOL,ICPR,IFAT
  292.       IF (IDEGR.EQ.2) CALL DEMCHA(MELSUR,MELEME)
  293.       RETURN
  294.       END
  295.  
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  
  302.  
  303.  
  304.  

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