Télécharger la plaquette Cast3M


fr en

Télécharger lfcdie.eso

Retour à la liste

Numérotation des lignes : 

lfcdie

  1. C LFCDIE    SOURCE    OF166741  24/12/18    21:15:16     12091          
  2.       SUBROUTINE LFCDIE(NBAND,LMAX,ITAB,IRETOU,IFORM)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8. -INC CCFXDR
  9.       DIMENSION ITAB(1)
  10.       dimension itabc(lmax+1)
  11.       external LONG
  12.  
  13.  10   CONTINUE
  14.       IRETOU=0
  15.       ios=1
  16.       IF (LMAX.EQ.0) RETURN
  17.  
  18.       IF (IONIVE.GT.19) THEN
  19.         IF (IFORM.EQ.1) then
  20.           IF (IONIVE .GE. 26) THEN
  21.             READ(NBAND,200,END=1001,ERR=1000) lc
  22.  200        FORMAT(10(1X,I12))
  23.           ELSE
  24.             READ(NBAND,201,END=1001,ERR=1000) lc
  25.  201        FORMAT(10I8)
  26.           ENDIF
  27.           if (lc.gt.lmax+1) goto 1000
  28.           IF (IONIVE .GE. 26) THEN
  29.             READ(NBAND,200,END=1001,ERR=1000) (ITABc(i),i=1,lc)
  30.           ELSE
  31.             READ(NBAND,201,END=1001,ERR=1000) (ITABC(i),i=1,lc)
  32.           ENDIF
  33.         ENDIF
  34.         IF (IFORM.EQ.0) then
  35.           READ(NBAND,END=1001,ERR=1000) lc
  36.           if (lc.gt.lmax+1) goto 1000
  37.           READ(NBAND,END=1001,ERR=1000) (ITABc(I),I=1,Lc)
  38.         endif
  39.         if (iform.eq.2) then
  40.           ios=ixdrint(ixdrr,lc)
  41.           if (ios.lt.0) goto 1001
  42.           if (lc.gt.lmax+1) goto 1000
  43.           lmaxl=lc
  44.           ios=ixdrimat(ixdrr,lmaxl,itabc(1))
  45.           if (ios.lt.0) goto 1001
  46.         endif
  47. *  decompression
  48.         i=0
  49.         ic=0
  50.         icp=0
  51.  1954   continue
  52.         if (ic.ge.lc) goto 1955
  53.         icp=ic+1
  54.         if (itabc(icp).gt.0) then
  55. *  comprime 
  56.           ic=icp+1
  57.           do j=1,int(itabc(icp))
  58.             i=i+1
  59.             itab(i)=itabc(ic)
  60.           enddo
  61.           ic=icp+1
  62.           goto 1954
  63.         else
  64. *  non comprime
  65.           ic=icp
  66.           do j=1,int(-itabc(icp))
  67.             i=i+1
  68.             ic=ic+1
  69.             itab(i)=itabc(ic)
  70.           enddo
  71.         endif
  72.         goto 1954
  73.  1955   continue
  74.         if (i.ne.lmax) write (ioimp,*) 'Pb dans la decompression lfcdie'
  75.         return
  76.  
  77. C*      ELSE IF (IONIVE.LE.19) THEN
  78.       ELSE 
  79.         lmaxl = lmax
  80.         IF (IFORM.EQ.1) then
  81.           if (ionive.lt.4) then
  82.             READ(NBAND,101,END=1001,ERR=1000)(ITAB(i),i=1,lmaxl)
  83.  101        FORMAT(16I5)
  84.           else
  85.             READ(NBAND,100,END=1001,ERR=1000)(ITAB(i),i=1,lmaxl)
  86.  100        FORMAT(10I8)
  87.           endif
  88.         endif
  89.         IF (IFORM.EQ.0)READ(NBAND,END=1001,ERR=1000) (ITAB(i),i=1,lmaxl)
  90.         if (iform.eq.2) ios=IXDRIMAT( ixdrr, lmaxl,itab(1))
  91.         if (ios.lt.0) GOTO 1001
  92.         RETURN
  93.  
  94.       ENDIF
  95.  
  96.  1001 CONTINUE
  97. * on bascule sur le fichier suivant
  98.       ll = long (nomres)
  99.       ificle=ificle+1
  100. *       write(ioimp,*)' lfcdie  ificle ',ificle
  101.       if(ificle.eq.10000)then
  102.         call erreur (945)
  103.         iretou=1
  104.         return
  105.       endif
  106.       if(ificle.eq.1) then
  107.         nomres(ll+1:ll+2)='_1'
  108.         ll=ll+2
  109.       elseif ( ificle.lt.10) then
  110.         write(nomres(ll:ll),fmt='(I1)')ificle
  111.       elseif ( ificle.lt.100) then
  112.         if(ificle.eq.10)ll = ll + 1
  113.         write(nomres(ll-1:ll),fmt='(I2)')ificle
  114.       elseif  ( ificle.lt.1000) then
  115.         if(ificle.eq.100)ll = ll + 1
  116.         write(nomres(ll-2:ll),fmt='(I3)')ificle
  117.       elseif  ( ificle.lt.10000) then
  118.         if(ificle.eq.1000)ll = ll + 1
  119.         write(nomres(ll-3:ll),fmt='(I4)')ificle
  120.       endif
  121.       if (iform.ne.2) close (unit=nband)
  122.       if (iform.eq.2) ios=IXDRCLOSE( ixdrr,.true.)
  123.       if(iform.eq.1) then
  124.            OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMRES(1:ll),
  125.      #    IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  126.         ELSEif (iform.eq.0) then
  127.           OPEN (UNIT=NBAND,STATUS='UNKNOWN',FILE=NOMRES(1:ll),
  128.      #    IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  129.         else
  130.           ios=INITXDR( NOMRES(1:ll),'r',.true.)
  131.           if (ios.lt.0) goto 2000
  132.         ENDIF
  133.         write(ioimp,*) 'Ouverture du fichier : ',nomres(1:ll)
  134.  
  135.       GOTO 10
  136.  
  137.  1000 CONTINUE
  138.       IRETOU=1
  139.       write (6,*) ' erreur lfcdie '
  140.       RETURN
  141.  
  142.  2000 CONTINUE
  143.       IRETOU=1
  144.       MOTERR=NOMRES(1:ll)
  145.       INTERR(1)=IOS
  146.       CALL ERREUR(424)
  147.       RETURN
  148.  
  149.       END
  150.  
  151.  
  152.  

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