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  20/11/25    13:39:12     10792          
  2.       SUBROUTINE RESTSO(IQUOI,NBANC)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. C=======================================================================
  6. C   APPELE PAR L'OPERATEUR SORTIR:LECTURE DU FICHIER TTMF
  7. C   LIREFI LIT LE FICHIER SORTIR, RESTSO LIT DES PILES (COMME RESTITUER)
  8. C
  9. C   APPELLE : ERREUR(12) LFCDIM LFCDIE LFCDIR  SORT5 ENTNOF
  10. C   ECRIT PAR FARVACQUE
  11. C
  12. C=======================================================================
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC CCGEOME
  16. -INC SMELEME
  17. -INC SMCHPOI
  18.       SEGMENT ILIST(ILL)
  19.       SEGMENT ISORTA(0)
  20. -INC TMCOLAC
  21.       SEGMENT/ITBBE1/( ITABE1(NN))
  22.       SEGMENT/ITBBE2/( ITABE2(NN))
  23.       SEGMENT/ITBBM1/( ITABM1(NM))
  24.       SEGMENT/NOMM1/(NOM1(NOBJN1))
  25.       SEGMENT/NOMM2/(NOM2(NOBJN2))
  26. C
  27.       CHARACTER*(8) ITYPE
  28.       CHARACTER*(8) NOMM
  29.       CHARACTER*(72) CK
  30.       REAL*8 XK
  31.       LOGICAL BK
  32. C
  33. C
  34. C
  35.       ITOTO=1
  36.       IRETOU=0
  37.       NOBJN1=0
  38.       NOBJN2=0
  39.       SEGINI NOMM1,NOMM2
  40.       NITLAC=20
  41.       SEGINI ICOLAC
  42.       DO 1 IFILE=1,NITLAC
  43.       SEGINI ITLACC
  44.       KCOLA(IFILE)=ITLACC
  45. C      KCOLAC(IFILE)=0
  46.    1  CONTINUE
  47.       GOTO 1096
  48. C
  49.  1097 CONTINUE
  50.       READ(IOCAR,74,END=1000,ERR=1000) IQUOI
  51.   74  FORMAT(7X,I5)
  52. C
  53.  1096 CONTINUE
  54.       IF(IQUOI.EQ.5) GOTO 1000
  55. C  *** FIN DES LECTURES ***********
  56. C
  57. C
  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( IONIVE .EQ. 0 ) THEN
  111.       DO 1800 I = 1,NBELEM
  112.  1800 ICOLOR(I)=IDCOUL
  113. C     ELSE
  114. C     SEGINI NOMCL
  115. C     READ (IOCAR,112,END=1000,ERR=1000)(NOMCL(I),I=1,NBELEM)
  116.  112  FORMAT (16(1X,A4))
  117. C     DO 18 I=1,NBELEM
  118. C     IREP=0
  119. C     DO 19 J=1,NBCOUL
  120. C 19  IF (NOMCL(I).EQ.NCOUL(J)) IREP=J
  121. C     IF (IREP.EQ.0) THEN
  122. C      MCOT(1)=NOMCL(I)
  123. C      WRITE (MOT(1:4),FMT='(A4)') MCOT
  124. C      SEGSUP MELEME,ISGTR,NOMCL
  125. C      RETURN
  126. C     ELSE
  127. C      ICOLOR(I)=IREP
  128. C     ENDIF
  129. C18   CONTINUE
  130. C     SEGSUP NOMCL
  131. C     ENDIF
  132.       L=NBELEM*NBNN
  133.       CALL LFCDIE(IOCAR,L,NUM,IRETOU,ITOTO)
  134.       DO 17 IK=1,NBNN
  135.       DO 17 JK=1,NBELEM
  136.       NUM(IK,JK)=NUM(IK,JK)+NBANC
  137.   17  CONTINUE
  138.       SEGDES MELEME
  139.    7  CONTINUE
  140.       GOTO 1098
  141. C     **************************CHPOINT*********************************
  142.  6002 CONTINUE
  143.       NN=0
  144.       NM=0
  145.       SEGINI ITBBE1
  146.       SEGINI ITBBM1
  147.       DO 1101 IEL=1,IMAX1
  148.       READ (IOCAR,1199,END=1000,ERR=1000)NSOUPO,NM
  149.  1199 FORMAT(8X,I5,4X,I5)
  150.       NAT=1
  151.       SEGINI MCHPOI
  152.       ITLAC(**)=MCHPOI
  153.       NN=3*NSOUPO
  154.       SEGADJ ITBBE1
  155.       SEGADJ ITBBM1
  156.       CALL LFCDIE(IOCAR,NN,ITABE1,IRETOU,ITOTO)
  157.       IF(IRETOU.NE.0) GOTO 1000
  158.       CALL LFCDIM(IOCAR,NM,ITABM1,IRETOU,ITOTO)
  159.       IF(IRETOU.NE.0) GOTO 1000
  160.       READ(IOCAR,113,END=1000,ERR=1000) MTYPOI,MOCHDE
  161.  113  FORMAT (A8,A72)
  162.       ICC=0
  163.       DO 1103 ISOU=1,NSOUPO
  164.       NC=ITABE1(3*ISOU)
  165.       SEGINI MSOUPO
  166.       IPCHP(ISOU)=MSOUPO
  167.       IGEOC=ITABE1(3*ISOU -2)
  168.       N=ITABE1(3*ISOU -1)
  169.       DO 1102 IC=1,NC
  170.       ICC=ICC+1
  171.       WRITE (NOCOMP(IC),FMT='(A4)') ITABM1(ICC)
  172.  1102 CONTINUE
  173.       SEGINI MPOVAL
  174.       IPOVAL=MPOVAL
  175.       LMAX=N*NC
  176.       CALL LFCDIR(IOCAR,LMAX,VPOCHA,IRETOU)
  177.   104 FORMAT(E22.15)
  178.       IF(IRETOU.NE.0) GOTO 1000
  179.       SEGDES MPOVAL,MSOUPO
  180.  1103 CONTINUE
  181.       SEGDES MCHPOI
  182.  1101 CONTINUE
  183.       SEGSUP ITBBE1,ITBBM1
  184.       GOTO 1098
  185. C
  186. C     *****FIN DE LECTURE D'UNE PILE : NOM DES OBJETS*******************
  187. C
  188.  1098 CONTINUE
  189. C      KCOLAC(IFILE)=KCOLAC(IFILE)+IMAX1
  190.       IF(NOBJN.EQ.0) GOTO 1095
  191.       DO 1094 I=1,NOBJN
  192.       J=NOM1(I)
  193.       IF(J.GT.ITLAC(/1)) THEN
  194.         WRITE(IOIMP,708) ITYPE,NOM2(2*I-1),NOM2(2*I)
  195.       ELSE
  196.         K=ITLAC(J)
  197.         WRITE(IOIMP,701)ITYPE,NOM2(2*I-1),NOM2(2*I),K
  198.        WRITE(NOMM,FMT='(2A4)') NOM2(2*I-1),NOM2(2*I)
  199.        IF(ITYPE.EQ.'ENTIER  '.OR.ITYPE.EQ.'FLOTTANT'.OR.ITYPE.EQ.
  200.      $ 'LOGIQUE '.OR.ITYPE.EQ.'MOT     ')
  201.      $  CALL QUEVAL(K,ITYPE,IERT,IK,XK,CK,BK,IOK)
  202.         IF(IERT.EQ.1 ) THEN
  203.                 CALL ERREUR(5)
  204.                 RETURN
  205.         ENDIF
  206.          IF(ITYPE.EQ.'ENTIER  ') THEN
  207.                CALL NOMENT(NOMM,IK)
  208.          ELSEIF(ITYPE.EQ.'FLOTTANT') THEN
  209.                CALL NOMREE(NOMM,XK)
  210.          ELSEIF(ITYPE.EQ.'LOGIQUE ') THEN
  211.                CALL NOMLOG(NOMM,BK)
  212.          ELSEIF(ITYPE.EQ.'MOT     ') THEN
  213.                CALL NOMCHA(NOMM,CK)
  214.                                    ELSE
  215.                CALL NOMOBJ(ITYPE,NOMM,K)
  216.          ENDIF
  217.       ENDIF
  218.  1094 CONTINUE
  219.   701 FORMAT(2X,A8,2X,2A4,2X,I5)
  220.   708 FORMAT(2X,A8,'  * ATTENTION ERREUR SUR L''OBJET ',2A4)
  221.  1095 CONTINUE
  222.       GOTO 1097
  223.  1000 CONTINUE
  224. C
  225.       SEGDES ICOLAC
  226.       CALL SORT5(ICOLAC)
  227.       SEGACT ICOLAC
  228.       DO 1001 I=1,NITLAC
  229.       ITLACC=KCOLA(I)
  230.       SEGSUP ITLACC
  231.  1001 CONTINUE
  232.       SEGSUP ICOLAC
  233.       RETURN
  234.       END
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250.  
  251.  

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