Sources Esope | Cast3M

lfcdie
C LFCDIE    SOURCE    PV090527  24/02/21    21:15:03     11846          
      SUBROUTINE LFCDIE(NBAND,LMAX,ITAB,IRETOU,IFORM)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCFXDR
      DIMENSION ITAB(1)
      dimension itabc(lmax+1)
      external LONG
 10   IRETOU=0
      ios=1
      IF (LMAX.EQ.0) RETURN
      if (ionive.le.19) then
      lmaxl=lmax
      IF (IFORM.EQ.1) then
       if (ionive.lt.4) then
      READ(NBAND,101,END=1001,ERR=1000)(ITAB(I),I=1,LMAX)
       else
      READ(NBAND,100,END=1001,ERR=1000)(ITAB(I),I=1,LMAX)
       endif
      endif
      IF (IFORM.EQ.0)READ(NBAND,END=1001,ERR=1000) (ITAB(I),I=1,LMAX)
      if(iform.eq.2) ios=IXDRIMAT( ixdrr, lmaxl,itab(1))
       if(ios.lt.0) go to 1001
  100  FORMAT(10I8)
  101  FORMAT(16I5)
       RETURN
      else
      IF(IFORM.EQ.1)then
        READ(NBAND,100,END=1001,ERR=1000)lc
        if (lc.gt.lmax+1) goto 1000
        READ(NBAND,100,END=1001,ERR=1000)(ITABc(I),I=1,Lc)
      endif
      IF(IFORM.EQ.0)then
        READ(NBAND,END=1001,ERR=1000) lc
        if (lc.gt.lmax+1) goto 1000
        READ(NBAND,END=1001,ERR=1000) (ITABc(I),I=1,Lc)
      endif
      if(iform.eq.2) then
       ios=ixdrint(ixdrr,lc)
       if (ios.lt.0) goto 1001
        if (lc.gt.lmax+1) goto 1000
       lmaxl=lc
       ios=ixdrimat(ixdrr,lmaxl,itabc(1))
       if (ios.lt.0) goto 1001
      endif
*  decompression
       i=0
       ic=0
       icp=0
 1954  continue
       if (ic.ge.lc) goto 1955
       icp=ic+1
       if (itabc(icp).gt.0) then
*  comprime 
        ic=icp+1
        do j=1,int(itabc(icp))
         i=i+1
         itab(i)=itabc(ic)
        enddo
        ic=icp+1
        goto 1954
       else
*  non comprime
        ic=icp
        do j=1,int(-itabc(icp))
         i=i+1
         ic=ic+1
         itab(i)=itabc(ic)
        enddo
       endif
       goto 1954
 1955  continue
       if (i.ne.lmax) write (6,*) ' pb dans la decompression lfcdie '
       return
      endif
 
 
 1001 CONTINUE
* on bascule sur le fichier suivant
      ll = long (nomres)
      ificle=ificle+1
*       write(6,*)' lfcdie  ificle ' , ificle
      if(ificle.eq.10000)then
        call erreur (945)
        iretou=1
        return
      endif
      if(ificle.eq.1) then
        nomres(ll+1:ll+2)='_1'
        ll=ll+2
      elseif ( ificle.lt.10) then
        write(nomres(ll:ll),fmt='(I1)')ificle
      elseif ( ificle.lt.100) then
        if(ificle.eq.10)ll = ll + 1
        write(nomres(ll-1:ll),fmt='(I2)')ificle
      elseif  ( ificle.lt.1000) then
        if(ificle.eq.100)ll = ll + 1
        write(nomres(ll-2:ll),fmt='(I3)')ificle
      elseif  ( ificle.lt.10000) then
        if(ificle.eq.1000)ll = ll + 1
        write(nomres(ll-3:ll),fmt='(I4)')ificle
      endif
      if (iform.ne.2) close (unit=nband)
      if (iform.eq.2) ios=IXDRCLOSE( ixdrr,.true.)
      if(iform.eq.1) then
           OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMRES(1:ll),
     #    IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
        ELSEif (iform.eq.0) then
          OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMRES(1:ll),
     #    IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
        else
          ios=INITXDR( NOMRES(1:ll),'r',.true.)
          if (ios.lt.0) goto 2000
        ENDIF
        write (6,*) 'Ouverture du fichier : ',nomres(1:ll)
      go to 10
 
 1000 IRETOU=1
      write (6,*) ' erreur lfcdie '
      RETURN
 2000 continue
      MOTERR=NOMRES(1:ll)
      INTERR(1)=IOS
      CALL ERREUR(424)
      RETURN
      END