Télécharger la plaquette Cast3M


fr en

Télécharger restso.eso

Retour à la liste

Numérotation des lignes : 

restso

  1. C RESTSO    SOURCE    CB215821  25/04/23    21:15:39     12247          
  2.  
  3. C=======================================================================
  4. C   APPELE PAR L'OPERATEUR SORTIR:LECTURE DU FICHIER TTMF
  5. C   LIREFI LIT LE FICHIER SORTIR, RESTSO LIT DES PILES (COMME RESTITUER)
  6. C
  7. C   APPELLE : ERREUR(12) LFCDIM LFCDIE LFCDIR  SORT5 ENTNOF
  8. C   ECRIT PAR FARVACQUE
  9. C=======================================================================
  10.       SUBROUTINE RESTSO(IQUOI,NBANC,NIVOLU)
  11.  
  12.       IMPLICIT INTEGER(I-N)
  13.       IMPLICIT REAL*8(A-H,O-Z)
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC CCGEOME
  18.  
  19. -INC SMELEME
  20. -INC SMCHPOI
  21. -INC SMCOORD
  22.       SEGMENT ILIST(ILL)
  23.       SEGMENT ISORTA(0)
  24. -INC TMCOLAC
  25.       SEGMENT/ITBBE1/( ITABE1(NN))
  26.       SEGMENT/ITBBE2/( ITABE2(NN))
  27.       SEGMENT/ITBBM1/( ITABM1(NM))
  28.       SEGMENT/NOMM1/(NOM1(NOBJN1))
  29.       SEGMENT/NOMM2/(NOM2(NOBJN2))
  30.  
  31.       CHARACTER*(8) ITYPE
  32.       CHARACTER*(8) NOMM
  33.       CHARACTER*(72) CK
  34.       REAL*8 XK
  35.       LOGICAL BK
  36.  
  37.       ITOTO=1
  38.       IRETOU=0
  39.       NOBJN1=0
  40.       NOBJN2=0
  41.       SEGINI NOMM1,NOMM2
  42.       NITLAC=20
  43.       SEGINI ICOLAC
  44.       DO 1 IFILE=1,NITLAC
  45.       SEGINI ITLACC
  46.       KCOLA(IFILE)=ITLACC
  47. C      KCOLAC(IFILE)=0
  48.    1  CONTINUE
  49.       GOTO 1096
  50. C
  51.  1097 CONTINUE
  52.       READ(IOCAR,74,END=1000,ERR=1000) IQUOI
  53.   74  FORMAT(7X,I5)
  54. C
  55.  1096 CONTINUE
  56.       IF(IQUOI.EQ.5) GOTO 1000
  57. C  *** FIN DES LECTURES ***********
  58. C
  59. C   ***** LECTURE D'UN TITRE
  60. C
  61. C     IF(IQUOI.NE.3) GOTO 5000
  62. C     CALL LFCDIM(IOCAR,18,TITREE,IRETOU)
  63. C     IF(IRETOU.NE.0) GOTO 1000
  64. C     GOTO 1097
  65. C
  66. C   ***** LECTURE D'UNE PILE
  67. C5000 CONTINUE
  68.       IF(IQUOI.NE.2) GOTO 1000
  69.       READ(IOCAR,75,END=1000,ERR=1000) IFILE,NOBJN,IMAX1
  70.   75  FORMAT(7X,I5,15X,I5,17X,I5)
  71.       ITYPE='        '
  72.       CALL TYPFIL(ITYPE,IFILE)
  73.       WRITE(IOIMP,703)IFILE,ITYPE,IMAX1,NOBJN
  74.  703  FORMAT(///' * LA FILE NUMERO',I4,' CONSTITUEE D''OBJETS DE TYPE
  75.      1 ',A8,' CONTIENT',I5,
  76.      1 ' OBJETS, PARMI LESQUELS ',I5,' SONT NOMMES.')
  77. C
  78.       IF(NOBJN.NE.0) CALL ENTNOF(IOCAR,NOBJN,NOMM1,NOMM2,IRETOU)
  79.       IF(IRETOU.NE.0) GOTO 1000
  80.       ITLACC=KCOLA(IFILE)
  81.       GO TO (6001,6002),IFILE
  82. C    **************************MELEME**********************************
  83.  6001 CONTINUE
  84. C  LECTURE DES OBJETS
  85.       DO 7 IOB=1,IMAX1
  86.       READ (IOCAR,107,END=1000,ERR=1000) NOMLU,NBSOUS,NBREF,NBNN,NBELEM
  87.  107  FORMAT(I4,12X,I4,11X,I4,10X,I4,8X,I4)
  88.       IF (IIMPI.NE.0) WRITE(IOIMP,205) NOMLU,NBSOUS,NBREF,NBNN,NBELEM
  89.  205  FORMAT(' ITYPEL',I4,' NBSOUS ',I4,' NBREF ',I4,'NBNN ',I4,' NBELEM
  90.      # ',I4)
  91.       SEGINI MELEME
  92.       ITLAC(**)=MELEME
  93.       IF (NBSOUS.EQ.0) GOTO 8
  94.       READ(IOCAR,108,END=1000,ERR=1000) (LISOUS(I),I=1,NBSOUS)
  95.  108  FORMAT(20I4)
  96.    8  IF (NBREF.EQ.0) GOTO 9
  97.       READ(IOCAR,108,END=1000,ERR=1000) (LISREF(I),I=1,NBREF)
  98.    9  CONTINUE
  99.       IF (NBELEM.EQ.0) GOTO 7
  100. C EST CE UN TYPE D'ELEM CONNU
  101. C     DO 10 I=1,NOMBR
  102. C     IF (NOMLU.EQ.NOMS(I)) GOTO 11
  103. C 10  CONTINUE
  104. C     MCOT(1)=NOMLU
  105. C     WRITE (MOT(1:4),FMT='(A4)') MCOT
  106. C     SEGSUP MELEME,ISGTR
  107. C     RETURN
  108. C 11  ITYPEL=I
  109.       ITYPEL=NOMLU
  110. C     IF( NIVOLU .EQ. 0 ) THEN
  111.       DO I = 1,NBELEM
  112.         ICOLOR(I)=IDCOUL
  113.       ENDDO
  114. C     ELSE
  115. C     SEGINI NOMCL
  116. C     READ (IOCAR,112,END=1000,ERR=1000)(NOMCL(I),I=1,NBELEM)
  117. C112  FORMAT (16(1X,A4))
  118. C     DO 18 I=1,NBELEM
  119. C     IREP=0
  120. C     DO 19 J=1,NBCOUL
  121. C 19  IF (NOMCL(I).EQ.NCOUL(J)) IREP=J
  122. C     IF (IREP.EQ.0) THEN
  123. C      MCOT(1)=NOMCL(I)
  124. C      WRITE (MOT(1:4),FMT='(A4)') MCOT
  125. C      SEGSUP MELEME,ISGTR,NOMCL
  126. C      RETURN
  127. C     ELSE
  128. C      ICOLOR(I)=IREP
  129. C     ENDIF
  130. C18   CONTINUE
  131. C     SEGSUP NOMCL
  132. C     ENDIF
  133.       L=NBELEM*NBNN
  134.       CALL LFCDIE(IOCAR,L,NUM,IRETOU,ITOTO)
  135.       DO JK=1,NBELEM
  136.         DO IK=1,NBNN
  137.           NUM(IK,JK)=NUM(IK,JK)+NBANC
  138.         ENDDO
  139.       ENDDO
  140.       SEGDES MELEME
  141.    7  CONTINUE
  142.       GOTO 1098
  143. C     **************************CHPOINT*********************************
  144.  6002 CONTINUE
  145.       NN=0
  146.       NM=0
  147.       SEGINI ITBBE1
  148.       SEGINI ITBBM1
  149.       DO 1101 IEL=1,IMAX1
  150.       READ (IOCAR,1199,END=1000,ERR=1000)NSOUPO,NM
  151.  1199 FORMAT(8X,I5,4X,I5)
  152.       NAT=1
  153.       SEGINI MCHPOI
  154.       ITLAC(**)=MCHPOI
  155.       NN=3*NSOUPO
  156.       SEGADJ ITBBE1
  157.       SEGADJ ITBBM1
  158.       CALL LFCDIE(IOCAR,NN,ITABE1,IRETOU,ITOTO)
  159.       IF(IRETOU.NE.0) GOTO 1000
  160.       CALL LFCDIM(IOCAR,NM,ITABM1,IRETOU,ITOTO)
  161.       IF(IRETOU.NE.0) GOTO 1000
  162.       READ(IOCAR,113,END=1000,ERR=1000) MTYPOI,MOCHDE
  163.  113  FORMAT (A8,A72)
  164.       ICC=0
  165.       DO 1103 ISOU=1,NSOUPO
  166.       NC=ITABE1(3*ISOU)
  167.       SEGINI MSOUPO
  168.       IPCHP(ISOU)=MSOUPO
  169.       IGEOC=ITABE1(3*ISOU -2)
  170.       N=ITABE1(3*ISOU -1)
  171.       DO 1102 IC=1,NC
  172.       ICC=ICC+1
  173.       WRITE (NOCOMP(IC),FMT='(A4)') ITABM1(ICC)
  174.  1102 CONTINUE
  175.       SEGINI MPOVAL
  176.       IPOVAL=MPOVAL
  177.       LMAX=N*NC
  178.       CALL LFCDIR(IOCAR,LMAX,VPOCHA,IRETOU)
  179.   104 FORMAT(E22.15)
  180.       IF(IRETOU.NE.0) GOTO 1000
  181.       SEGDES MPOVAL,MSOUPO
  182.  1103 CONTINUE
  183.       SEGDES MCHPOI
  184.  1101 CONTINUE
  185.       SEGSUP ITBBE1,ITBBM1
  186.       GOTO 1098
  187. C
  188. C     *****FIN DE LECTURE D'UNE PILE : NOM DES OBJETS*******************
  189. C
  190.  1098 CONTINUE
  191. C      KCOLAC(IFILE)=KCOLAC(IFILE)+IMAX1
  192.       IF(NOBJN.EQ.0) GOTO 1095
  193.       DO 1094 I=1,NOBJN
  194.       J=NOM1(I)
  195.       IF(J.GT.ITLAC(/1)) THEN
  196.         WRITE(IOIMP,708) ITYPE,NOM2(2*I-1),NOM2(2*I)
  197.       ELSE
  198.         K=ITLAC(J)
  199.         WRITE(IOIMP,701)ITYPE,NOM2(2*I-1),NOM2(2*I),K
  200.        WRITE(NOMM,FMT='(2A4)') NOM2(2*I-1),NOM2(2*I)
  201.        IF(ITYPE.EQ.'ENTIER  '.OR.ITYPE.EQ.'FLOTTANT'.OR.ITYPE.EQ.
  202.      $ 'LOGIQUE '.OR.ITYPE.EQ.'MOT     ')
  203.      $  CALL QUEVAL(K,ITYPE,IERT,IK,XK,CK,BK,IOK)
  204.         IF(IERT.EQ.1 ) THEN
  205.                 CALL ERREUR(5)
  206.                 RETURN
  207.         ENDIF
  208.          IF(ITYPE.EQ.'ENTIER  ') THEN
  209.                CALL NOMENT(NOMM,IK)
  210.          ELSEIF(ITYPE.EQ.'FLOTTANT') THEN
  211.                CALL NOMREE(NOMM,XK)
  212.          ELSEIF(ITYPE.EQ.'LOGIQUE ') THEN
  213.                CALL NOMLOG(NOMM,BK)
  214.          ELSEIF(ITYPE.EQ.'MOT     ') THEN
  215.                CALL NOMCHA(NOMM,CK)
  216.                                    ELSE
  217.                CALL NOMOBJ(ITYPE,NOMM,K)
  218.          ENDIF
  219.       ENDIF
  220.  1094 CONTINUE
  221.   701 FORMAT(2X,A8,2X,2A4,2X,I5)
  222.   708 FORMAT(2X,A8,'  * ATTENTION ERREUR SUR L''OBJET ',2A4)
  223.  1095 CONTINUE
  224.       GOTO 1097
  225.  1000 CONTINUE
  226. C
  227.       SEGDES ICOLAC
  228.       CALL SORT5(ICOLAC)
  229.       SEGACT ICOLAC
  230.       DO 1001 I=1,NITLAC
  231.       ITLACC=KCOLA(I)
  232.       SEGSUP ITLACC
  233.  1001 CONTINUE
  234.       SEGSUP ICOLAC
  235.  
  236.       RETURN
  237.       END
  238.  
  239.  
  240.  
  241.  

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