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

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