Sources Esope | Cast3M

C PROCPN    SOURCE    CHAT      11/05/04    21:17:53     6963
      SUBROUTINE PROCPN(IAREA,IRET)
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
      SAVE LINDEX,ISTAT,IULEPR,ISTAT2
      CHARACTER*(*) IAREA,IRET
      DIMENSION INDEX (6)
      DIMENSION NAME(2)
      CHARACTER*8 INDIX (6)
      SEGMENT MUTIL
           CHARACTER*8 MNOM(LLON),MDOUB(LLON)
      ENDSEGMENT
      MUTIL=0
      IJKL=0
      IDEJA=0
      ISTAT=1
      READ(34,REC=1,FMT=100,IOSTAT=IOSTAT)IND1,IND2
      if (iostat.ne.0) goto 1000
      LLON=(IND2-IND1+1 )*5
      SEGINI MUTIL
      ISTAT=0
      DO 1 I=IND1,IND2
      READ(34,REC=I,FMT=101,IOSTAT=IOSTAT)(INDIX(K),INDEX(K),K=1,5)
      if (iostat.ne.0) goto 9998
      DO 2 K=1,5
      IJKL=IJKL+1
      MNOM(IJKL)=INDIX(K)
      if(indix(k).ne.'        ')then
         CALL NOMOBJ('PROCEDUR',INDIX(K),-INDEX(K))
*         write(6,*) ' nomobj 1 de la procedur ' , indix(k)
      endif
   2  CONTINUE
   1  CONTINUE
      ISTAT2=1
      READ(36,REC=1,FMT=100,IOSTAT=IOSTAT)IND1,IND2
      if (iostat.ne.0) goto 9998
      ISTAT2=0
      DO 3 I=IND1,IND2
      READ(36,REC=I,FMT=101,IOSTAT=IOSTAT)(INDIX(K),INDEX(K),K=1,5)
      if (iostat.ne.0) goto 9998
      DO 4 K=1,5
      IF(INDIX(K).EQ.' ' ) GO TO 4
      DO 40 LIOP=1,IJKL
      IF(MNOM(LIOP).EQ.INDIX(K)) THEN
          IDEJA=IDEJA+1
          MDOUB(IDEJA)=INDIX(K)
          GO TO 41
      ENDIF
   40 CONTINUE
   41 CONTINUE
      IQQ = -(INDEX(K)+1000000)
      if( indix(k).ne.' ') then
*         write(6,*) ' nomobj 2 de la procedur ' , indix(k)
         CALL NOMOBJ('PROCEDUR',INDIX(K),IQQ)
      endif
   4  CONTINUE
   3  CONTINUE
      IF(IDEJA.NE.0) THEN
         CALL ERREUR (-302)
         DO 42 IKL = 1,IDEJA,4
         MOTERR=' '
         IFI=MIN(IKL+3,IDEJA)-IKL +1
         DO 43 ILK=1,IFI
         MOTERR((ILK-1)*9+2:ILK*9)=MDOUB(IKL-1+ILK)
   43    CONTINUE
         WRITE(IOIMP,*) MOTERR(1:40)
   42    CONTINUE
      ENDIF
      IRET='9999'
 9998 CONTINUE
      IF(MUTIL.NE.0) SEGSUP MUTIL
 1000 RETURN
      ENTRY PROCPO(JINDEX,IRET)
      IRET='0'
      IF (ISTAT*ISTAT2.EQ.1) RETURN
      IULEPR=34
      LINDEX=JINDEX+1
      IF(JINDEX.GT.1000000) THEN
        IULEPR=36
        LINDEX=JINDEX+1 -1000000
      ENDIF
      IRET='9999'
      RETURN
      ENTRY PROCLI(IAREA,IRET)
      IRET='9999'
      IF (ISTAT*ISTAT2.EQ.1) RETURN
      IRET='0'
      READ(IULEPR,REC=LINDEX,FMT=102,IOSTAT=IOSTAT)IAREA
      if (iostat.ne.0) goto 1000
      IF(IAREA(1:4).EQ.'$$$$')IRET='9999'
      LINDEX=LINDEX+1
      RETURN
      ENTRY PROCL2(IAREA,IRET)
      IRET='0'
      IF(ISTAT2.NE.0) go to 12
      READ(36,REC=1,FMT=100,IOSTAT=IOSTAT)IND1,IND2
      if (iostat.ne.0) goto 1000
      DO 110 I=IND1,IND2
      READ(36,REC=I,FMT=101,IOSTAT=IOSTAT)(INDIX(K),INDEX(K),K=1,5)
      if (iostat.ne.0) goto 1000
      DO 220 K=1,5
      IF(INDIX(K).EQ.IAREA(1:8)) THEN
      IRET='9998'
      LINDEX=INDEX(K)+1
      IULEPR=36
      GO TO 10
      ENDIF
  220 CONTINUE
  110 CONTINUE
  12  CONTINUE
      IF (ISTAT.NE.0) return
      READ(34,REC=1,FMT=100,IOSTAT=IOSTAT)IND1,IND2
      if (iostat.ne.0) goto 1000
      DO 11 I=IND1,IND2
      READ(34,REC=I,FMT=101,IOSTAT=IOSTAT)(INDIX(K),INDEX(K),K=1,5)
      if (iostat.ne.0) goto 1000
      DO 22 K=1,5
      IF(INDIX(K).EQ.IAREA(1:8)) THEN
      IRET='9999'
      LINDEX=INDEX(K)+1
      IULEPR=34
      GO TO 10
      ENDIF
  22  CONTINUE
  11  CONTINUE
  10  RETURN
  100 FORMAT (2I6)
  101 FORMAT(5(A8,I6))
  102 FORMAT(A72)
      END