Sources Esope | Cast3M

lfcdi2
C LFCDI2    SOURCE    PV090527  24/02/21    21:15:03     11846          
      SUBROUTINE LFCDI2(NBAND,LMAX,R,IRETOU,IFORM)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCFXDR
      DIMENSION R(*)
      dimension rc(lmax+1)
      external long
      ipas=0
10    IRETOU=0
      ios=1
      IF (LMAX.EQ.0) return
      IF(IONIVE.le.19) THEN
        lmaxl=lmax
        IF (IFORM.EQ.1) then
         if (ionive.gt.2) then
          READ(NBAND,8003,END=1001,ERR=1000)(R(I),I=1,LMAX)
         else
          READ(NBAND,8002,END=1001,ERR=1000)(R(I),I=1,LMAX)
         endif
        endif
        IF (IFORM.EQ.0)READ(NBAND,END=1001,ERR=1000)(R(I),I=1,LMAX)
        if (iform.eq.2) then
         ios=ixdrdmat(ixdrr,lmaxl,r(1))
         if (ios.lt.0) goto 1001
        endif
        return
      Else
** niveau >= 20
      IF(IFORM.EQ.1)then
        READ(NBAND,8004,END=1001,ERR=1000)lc
        if(lc.gt.lmax+1) goto 1000
        READ(NBAND,8003,END=1001,ERR=1000)(rc(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) (rc(I),I=1,Lc)
      endif
      if(iform.eq.2) then
       ios=ixdrint(ixdrr,lc)
       if (ios.lt.0) goto 1001
       if (lc.gt.0) then
        if(lc.gt.lmax+1) goto 1000
        lmaxl=lc
        ios=ixdrdmat(ixdrr,lmaxl,rc(1))
**      write (6,*) ' lc ios lmax - 1 ',lc,ios,lmax
        if (ios.lt.0) goto 1001
       else
        nc=-lc
        do is=0,nc-1
         ios=ixdrint(ixdrr,lc)
**       write (6,*) ' lecture de ',lc,' en ',is*500000000+1
         ios=ixdrdmat(ixdrr,lc,rc(is*500000000+1))
         if (ios.lt.0) goto 1001
        enddo
 
       endif 
      endif
*  decompression
       i=0
       ic=0
       icp=0
 1954  continue
       if (ic.ge.lc) goto 1955
       icp=ic+1
       if (rc(icp).gt.0.) then
*  comprime 
        ic=icp+1
        do j=1,int(rc(icp))
         i=i+1
         r(i)=rc(ic)
        enddo
        ic=icp+1
        goto 1954
       else
*  non comprime
        ic=icp
        do j=1,int(-rc(icp))
         i=i+1
         ic=ic+1
         r(i)=rc(ic)
        enddo
       endif
       goto 1954
 1955  continue
       if (i.ne.lmax) write (6,*) ' pb dans la decompression lfcdi2'
       goto 1
      endif
 1000 IRETOU=1
      write (6,*) ' erreur lfcdi2 '
    1 RETURN
 1001 ll=long (nomres)
      ificle=ificle+1
*        write(6,*)' 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.)
*      write(6,*) ' fermeture et ouverture de ',nomres(1:ll)
      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
C --------------------
 8004 FORMAT(i15)
 8002 FORMAT(1P,6E13.6)
 8003 FORMAT(1P,3E22.14)
 2000  MOTERR=NOMRES(1:ll)
      INTERR(1)=IOS
      CALL ERREUR(424)
      RETURN
      END