스크립트 만들기 [fortran] by 바죠

스크립트 만들기 [포트란]


포트란  컴퓨터 언어로 스크립트 만들 수 있다. 이렇게 시도하는 사람들은 많지 않다. 쉘, 펄, 파이썬 등으로 스크립트를 만들어 사용하는 것이 일반적이다.  하지만, 몇 가지 기본적인 문자열(스트링) 처리 기법만 익히면 포트란 언어가 제공하는 기본 기능으로도 충분히 스크립트를 만들어  낼수 있다. 컴퓨터 언어 포트란의 능력을 생각하면 이것은 당연한 결론이다. 핵심 문제는 효율성이다. 얼마나 간결하게 만들 수 있는가의 문제이다.  다시 말해서, 포트란에서 가장 번거로운 부분이 있다는 것이다.  포트란 스크립트를 만드는 과정에서 가장 번거로운 부분은 바로 문자열(스트링) 처리 부분이다.  결론적으로 이 부분에서 발생하는 번거로움만 어떻게 해결되면 포트란 언어 기반 스크립트 별로 나쁘지 않다.  충분히 경쟁력이 있다는 것이다.


그 누구도 포트란 언어로 스크립트를 만들어 사용하라고 가르치지 않는다. 사실은 그렇지 않다. 충분히 가능한 것이다.  사실, 몇 가지 단계들만 극복하면 훌륭한 스크립트 프로그램을 만들 수 있다.  실제 포트란에서 많이 사용하지 않지만, 스크립트 작성에서 꼭 필요한 항목들을 나열하면 다음과 같다.  다시 말해서, 포트란 언어로 스크립트를 만드는데는 약간의 진입 장벽이 있다는 것이다. 이 문제만 해결하면 모든 것이 일사천리로 진행될 수 있다. 진입장벽을 집어 본다.

시스템 부르기 : 리눅스/유닉스 명령어를 직접 사용하기 위해서 잠시 시스템으로 나간다.  리눅스/유닉스 작업들을 수행하고 다시 돌아온다. 파일 복사, 지우기 같은 명령을 시스템 명령어를 통해서 수행할 수 있다. 가장 중요한 기능으로 외부 프로그램을 실행시킨다. 프로그램 실행에 필요한 데이터, 입력데이터를 만들고 복사한다.  문자열(스트링) 형식으로 유닉스/리눅스 명령어를 만들어 낸다음, 이를 인수로 해서, call system(cmd)처럼 부르면 해당 명령어가 실행된다. 그 다음 다시 포트란으로 돌아 오게 된다. 다시 말해서, 문자열(스트링)을 잘 다룰 수 있어야 한다.
http://incredible.egloos.com/3474225
http://incredible.egloos.com/4842832

디렉토리 만들고, 계산 시작: 독립적인 작업들을 분리해서 실행한다. 가능하면 병렬처리가 가능하게 한다. 배치 PBS 시스템을 활용하여 동시 다발적으로 계산들을 많은 독립적인 디렉토리들에서 동시에 수행할 수 있다. 숫자를 문자열로 표현하여 디렉토리 이름으로 사용하면 편리하다. 예를 들어, 1,2,3,...,10을 문자열 0000, 0001, 0002, 0003, ... , 0010처럼 표현하고 문자열(스트링)로 바꾸어서 디렉토리 이름으로 사용하면 편리하다. 
http://incredible.egloos.com/4842832

파일 확인, 지우기, 디렉토리 : 실제 파일이 생성되었는지를 확인함으로써 특정 계산이 종료되었는지를 확인한다. PBS 스크립트 종료직전에 작업 완료을 의미하는 파일을 적게 할 수 있다. 예를 들어, touch STOP처럼 할 수 있다. 이럴 경우, 특정 디렉토리에서 PBS를 활용한 계산이 종료 되었다는 신호로 사용될 수 있다. STOP이라는 파일이 존재하면 작업 종료 사인으로 확인할 수 있다. 명령어 echo를 사용할 수도 있다.

echo "DONE" >> STATUS
포트란 언어에서 파일 존재 여부 확인은 inquire()문을 활용한다.
http://incredible.egloos.com/4906274

디렉토리 속에 있는 특정 파일로 부터 특정 데이터 추출: 특정 디렉토리, 특정 파일에서 정보를 추출한다. 이 때, 문자열 처리 기법이 요구된다. 아래에 표시된 유틸러티를 활용하면 아주 간단하게 원하는 데이터를 추출할 수 있다. 라이버러리를 활용하면 일이 쉬워진다. 아주 일반적으로 숫자들을 얻어낼 수 있다. 정수, 실수 등을 자연스럽게 얻어낼 수 있다. 편리하게 설계되어 있다.  
http://incredible.egloos.com/4836430

문자열(스트링) 처리 하기(유틸러티 활용하기):
http://www.gbenthien.net/strings/index.html
http://www.gbenthien.net/strings/Strings.pdf
strings.txt

sleep 기능: 파일 I/O 관련하여 리눅스/유닉스 시스템에게 특정한 이완시간을 주어야 한다. 그렇지 않으면 파일 시스템을 정확하게 다룰 수 없다. 조금씩 쉬어가면서 작업을 처리한다.  I/O 이완 시간이 필요하다. PBS 시스템도 유사한 이완 시간이 필요하다.
http://incredible.egloos.com/4917339


포트란을 스크립트로 사용한다는 것은 아마도 계산 속도가 문제가 아닐 수 있다. 그렇다면, 컴파일 할 때, -O2 , -fast
대신에 보다 더 다양한 체크를 해 주는 옵션을 늘 사용할 수 있다. 아래 참조, ifort 컴파일러의 경우 아래와 같은 옵션을 사용할 수 있다. 보다 더 많은 실행 시간 체크를 해준다. 물론 실행 이전 단계, 컴파일 단계에서도 많은 체크를 해준다.
 -CB -check all -warn interface -assume realloc_lhs
------------------------------------------------------------------------
스트링 합치기:
          str1='abc'
          str2='def'
          int1= 25

          str3=str1//str2


스트링 좌로 정렬하기

adjustl(str3)
그 다음 곧바로 빈 공간을 없애기

str3=trim(adjustl(str3))


------------------------------------------------------------------------
정수를 스트링으로 변환하기:
         integer --> string
         write(str4,'(i5)') int1
         str3=str1//str4

       integer :: a,b,c
       character(len=99) :: char_a,char_b,char_c

       a = 999
       b = 1111

       write(unit=char_a,fmt=*)a
       write(unit=char_b,fmt=*)b

       char_c = trim(adjustl(char_a))//trim(adjustl(char_b))

       read(unit=char_c,fmt=*)c

       print*,c

       end

스트링을 정수로:
 Converting a string to integer
------------------------------------------------------------------------

      INTEGER*4         INTVAR
      CHARACTER         STRING*80
      ......................................
      READ(UNIT=STRING, FMT='(I5)') INTVAR


Converting an integer to string

------------------------------------------------------------------------

      INTEGER*4         INTVAR
      CHARACTER         STRING*80
      ......................................
      WRITE(UNIT=STRING, FMT='(I5)') INTVAR


http://www.ibiblio.org/pub/languages/fortran/ch2-11.html
------------------------------------------------------------------------
스트링을 좌측으로 정렬하고 빈공간 부분을 잘라 내기, 필요하면 /를 포함하는 절대 경로 표현하기:
     cwd=adjustl(cwd) ; i=len_trim(cwd) ; if(cwd(i:i) /= '/') cwd=trim(cwd)//'/' ; cwd=trim(cwd)
http://www.ibiblio.org/pub/languages/fortran/ch2-13.html

------------------------------------------------------------------------
          program test_adjustl
            character(len=20) :: str = '   gfortran'
            str = adjustl(str)
            print *, str
          end program test_adjustl
https://www.nsc.liu.se/~boein/f77to90/a5.html#section21

------------------------------------------------------------------------
          PROGRAM test_trim
            CHARACTER(len=10), PARAMETER :: s = "GFORTRAN  "
            WRITE(*,*) LEN(s), LEN(TRIM(s))  ! "10 8", with/without trailing blanks
          END PROGRAM
https://gcc.gnu.org/onlinedocs/gfortran/index.html#Top

------------------------------------------------------------------------
특정 파일이 존재하는지 안 하는지 테스트 하기:
상대 패스, 절대 패스 모두 사용가능하다.


       logical lexist

       inquire(file='fort.1',exist=lexist)
       if(lexist)then
                   else
                   endif

------------------------------------------------------------------------
파일 지우기:
물론, system()을 이용해서 지울 수 있다.
       inquire(file='fort.1',exist=lexist)
       if(lexist)then
       open(1,file='fort.1',form='formatted')
       close(1,status='delete')
       write(6,*) 'fort.1 is deleted.'
                 endif

       cmd='rm -f '//trim(cwd)//trim(file_names(10)) ; cmd=trim(cmd)
       call system(cmd)

      CLOSE(27,STATUS='DELETE')

The file associated with unit number 27 is deleted after being closed.
------------------------------------------------------------------------
디렉토리 만들기, 지우기:

!      Written by In-Ho Lee, KRISS, September 11, 2013.
       subroutine gen_directories(ndir)
       implicit none
       integer ndir
       character*80 string
       character*280 cmd
       integer isize,i

       isize=4
       if(ndir > 0)then
       do i=1,ndir
       call xnumeral(i,string,isize) ; string=trim(string)
       cmd='mkdir '//trim(string)                     ; cmd=trim(cmd) ; call system(cmd)
       cmd='cp ./CSA_SOLDIER.pbs '//trim(string)//'/' ; cmd=trim(cmd) ; call system(cmd)
       cmd='cp INCAR_rlx '//trim(string)//'/'         ; cmd=trim(cmd) ; call system(cmd)
       cmd='cp INCAR_rlxall '//trim(string)//'/'      ; cmd=trim(cmd) ; call system(cmd)
       cmd='cp INCAR_bs '//trim(string)//'/'          ; cmd=trim(cmd) ; call system(cmd)
       cmd='cp POTCAR  '//trim(string)//'/'           ; cmd=trim(cmd) ; call system(cmd)
       enddo
                   endif
       if(ndir < 0)then
       ndir=iabs(ndir)
       do i=1,ndir
       call xnumeral(i,string,isize) ; string=trim(string)
       cmd='rm -rf '//trim(string)//'/' ; cmd=trim(cmd)
       call system(cmd)
       call sleep(1)
       enddo
                   endif
       call sleep(1)
       return
       end


------------------------------------------------------------------------
LOGICAL :: file_exists
INQUIRE(FILE="input.txt", EXIST=file_exists)   ! file_exists will be TRUE if the file

특정 파일이 디렉토리에 있을 때와 없을 때를 구분할 수 있어야 한다.
이것을 포트란에서 지원한다.



------------------------------------------------------------------------
파일 읽기에서 매우 중요한 항목이 있다. 바로 에러처리 항목이다. 파일을 읽을 때, 파일이 제대로 준비가 안 되어 있을 수 있다.
이렇게 되면 프로그램은 그 자리에서 실행이 중단되게 된다. 이러한 문제점을 처리하기 위해서 몇 가지 장치를 마련해 두었다.
err, end 등이 있을 수 있다.

매우 유용한 장치이다. 특정 양식을 만족하지 못할 경우 에러 발생한다. 읽기 도중에 에러가 발생할 수 있다. 또는 파일 끝에 도달했는데 계속해서 데이터를 읽을 수는 없는 것이다. 모두 에러 상황이다. 이러한 경우에 에러를 감지하고 다른 처리를 할 수 있도록 도와주는 장치가 필요하다.

read(11,err=911,end=999)  에서 처럼 err, end 활용하기:

http://www.oc.nps.edu/~bird/oc3030_online/fortran/io/io.html
7.  Read Statement

-    There are three OPTIONS which are useful when READing data from a
     file, using the READ command.  They are:

          END = label    Specifies a label to branch (jump) to if an
                         END-OF-FILE (EOF) is reached (READing past
                         the end of file).
         
          Example:  read(10,130,end=300) a,b,c
             130    format(3(f7.2,1x))

                    When the end-of-file, EOF, is encountered, control
                    of the program jumps to line 300.  Typically, this
                    is used in a "read data loop", which continues
                    reading one new line at a time until EOF is found.
                    The jump to line 300 is your only way out of the
                    loop.

          ERR = label    Specifies a label to branch to if some ERRor
                         is encountered in the I/O.

          Example:  READ(10,140,err=225) a, b, c
             140    format(f7.2,2x,f10.5,3x,e12.7)

                    When a read error is encountered, the program
                    jumps to line 225 and continues executing the
                    program from there.  Typically, you jump to a
                    section of your program that will notify you, the
                    user, that an error has occurred.  This does not
                    tell you WHICH type of error occurred.

          IOSTAT =  integer variable    Variable is assigned an
                    integer value to describe the success or error of
                    your READ statement.

                    Integer values:

                    - Zero, means the input data was read without
                    error.

                    - Negative value, means the end-of-file (EOF) mark
                    was read, which signifies the end of the input
                    data file.

                    - Positive value, means there was an error during
                    the read execution.  The positive value indicates
                    the type of error, as defined by the computer
                    operating system.

          Example:  read(10,150,iostat=k) a, b, c
             150    format(f7.2,2x,f10.5,3x,e12.7)

              k = 0 means there was no error, nor was EOF encountered.
              k = -1 means EOF was encountered.
              k = 2  refers to the operating system read error
                     "type"=2. 8.  Write Statement  p. 528


      DO 10, I = 1,100
         READ(3,*,END=20,ERR=900)COUNT(I),A(I),NAME(I)
         FILENO = I
   10 CONTINUE
   20 WRITE(*,*)'Input complete. Number of records: ',FILENO
… 
  900 STOP 'Error in input file'
      END

사실, err=911, end=999 방법보다 iostat=ios처럼 IOSTAT를 사용하는 것이 더 일반적인 방법이다.
왜냐하면, 읽을 때, 파일이 제대로 된, 예상된 숫자를 주지 못할 수 있다. 이러한 부분까지 모두 고려해서 프로그램을 만들어야 한다.

if(ios /= 0) 처럼, ios가 0아니면 읽을 때, 문제가 있음을 의미한다. 프로그램에서 이를 활용하여 다른 처리를 할 수 있게 해 주어야 한다. 이것이 보다 일반적인 상황이다.


------------------------------------------------------------------------

유닉스/리눅스 명령어 touch :
touch STOP
이러한 명령어는 STOP이라는 파일을 만들어 주게 된다.
파일 크기는 0이다.
기존에 STOP이라는 파일이 있었다면, 생성 시간이 갱신된다.

------------------------------------------------------------------------
!234567890
       implicit none
       integer i,j,k
       character*32 subcommand
       character*32 subcommand2
       character*4 fn
       character*9 fm
       integer nsize

       nsize=4

       do j=0,3
      call numeral (j,fn,nsize)
      write(6,*) fn
      fm=' admd'//fn
      subcommand=fm//'.pdb'
      write(6,*) subcommand
!      call system("cp admd.pdb"//subcommand)
      subcommand2=fm//'.dssp'
      subcommand2=trim(subcommand)//fm//'.dssp'

      write(6,*) subcommand2
!      call system("~/dssp/dsspcmbi "//subcommand2)
       end do

       stop
       end

------------------------------------------------------------------------

배치 스크립트에서 아래와 같은 기능을 활용할 수 있다.

생성된 시각 기준으로 파일 이름 부여하기

특정 파일 생성하기

잠깐 대기하기

간단한 정보를 파일에 추가하기



STAMP=$(date +%Y%m%d_%H%M%S)_$RANDOM
echo $STAMP
cp CONTCAR   ../deposit/CONTCAR_$STAMP
sleep 0.5
touch STOP
echo "DONE" >> STATUS

------------------------------------------------------------------------

------------------------------------------------------------------------

!234567890
       implicit none
       integer nspecies,iseed10,iseed20
       character*280 cwd
       logical lnewjob
       character*2 symbl(10)
       integer i,j

       do i=1,10
       if(i ==2 )then
       read(5,*) symbl(1)
!      read(5,*) symbl(1), symbl(2)
       symbl(1)=adjustl(symbl(1))
!      symbl(2)=adjustl(symbl(2))
       write(6,*) symbl(1)
!      write(6,*) symbl(2)
                 else
       read(5,*)
                 endif
       enddo
       read(5,'(a280)') cwd
       cwd=adjustl(cwd)
       do i=1,280
       if(cwd(i:i) == ' ')then
       j=i
                          exit
                          endif
       enddo
       do i=j,280
       cwd(i:i)=' '
       enddo
       cwd=trim(cwd)
       i=len_trim(cwd) ; if(cwd(i:i) /= '/') cwd=trim(cwd)//'/' ; cwd=trim(cwd)
       write(6,*) trim(cwd)
       read(5,*) i,j
       write(6,*) i,j
       stop
       end



------------------------------------------------------------------------

실제 예제:

cat gendir.f90
!234567890
!      Written by In-Ho Lee, KRISS, September 11, 2013.
       implicit none
       integer isize
       integer i,nd
       character*200 string1,string
       character*200 cmd
       character*200000 string9

       nd=28
!
       isize=3
!      goto 999
       do i=1,nd
       call xnumeral (i,string,isize)
       string='disp-'//trim(string)
       cmd='mkdir '//string
       cmd=trim(cmd)
       call system(cmd)
       enddo
       do i=1,nd
       call xnumeral (i,string,isize)
       string1='disp-'//trim(string)
       string='POSCAR-'//trim(string)//' '//trim(string1)//'/POSCAR'
       cmd='cp '//string
       call system(cmd)
       string='POTCAR'//' '//trim(string1)//'/'
       cmd='cp '//string
       call system(cmd)
       string='KPOINTS'//' '//trim(string1)//'/'
       cmd='cp '//string
       call system(cmd)
       string='INCAR_phonopy'//' '//trim(string1)//'/INCAR'
       cmd='cp '//string
       call system(cmd)
       string='TEST_force.pbs'//' '//trim(string1)//'/'
       cmd='cp '//string
       call system(cmd)
       enddo
!
       do i=1,nd
       call xnumeral (i,string,isize)
       string='disp-'//trim(string)
       cmd='cd '//string
       cmd=trim(cmd)//' ; qsub TEST_force.pbs'
       cmd=trim(cmd)
       call system(cmd)
       enddo

 999   continue
!      isize=3
!      string9=' '
!      do i=1,nd
!      call xnumeral (i,string,isize)
!      string='disp-'//trim(string)//'/vasprun.xml'
!      string9=trim(string9)//' '//trim(string)
!      string9=trim(string9)
!      enddo
!      string9='phonopy -f '//trim(string9)
!      print*, trim(string9)
!
!      phonopy -f disp-*/vasprun.xml
!      phonopy -p band.conf
!      phonopy -p mesh.conf
!
       stop
       end


------------------------------------------------------------------------
      subroutine xnumeral (number,string,size)
      implicit none
      integer i,number,size,multi,pos
      integer length,minsize,len
      integer million,hunthou,tenthou
      integer thousand,hundred,tens,ones
      character*1 digit(0:9)
      character*(*) string
      logical right,negative
      data digit / '0','1','2','3','4','5','6','7','8','9' /

      if (size .eq. 0) then
         right = .true.
         size = 1
      else
         right = .false.
      end if
      minsize = size
      length = len(string)

      if (number .ge. 0) then
         negative = .false.
      else
         negative = .true.
         number = -number
      end if

      million = number / 1000000
      multi = 1000000 * million
      hunthou = (number-multi) / 100000
      multi = multi + 100000*hunthou
      tenthou = (number-multi) / 10000
      multi = multi + 10000*tenthou
      thousand = (number-multi) / 1000
      multi = multi + 1000*thousand
      hundred = (number-multi) / 100
      multi = multi + 100*hundred
      tens = (number-multi) / 10
      multi = multi + 10*tens
      ones = number - multi

      if (million .ne. 0) then
         size = 7
      else if (hunthou .ne. 0) then
         size = 6
      else if (tenthou .ne. 0) then
         size = 5
      else if (thousand .ne. 0) then
         size = 4
      else if (hundred .ne. 0) then
         size = 3
      else if (tens .ne. 0) then
         size = 2
      else
         size = 1
      end if
      size = min(size,length)
      size = max(size,minsize)

      if (size .eq. 7) then
         string(1:1) = digit(million)
         string(2:2) = digit(hunthou)
         string(3:3) = digit(tenthou)
         string(4:4) = digit(thousand)
         string(5:5) = digit(hundred)
         string(6:6) = digit(tens)
         string(7:7) = digit(ones)
      else if (size .eq. 6) then
         string(1:1) = digit(hunthou)
         string(2:2) = digit(tenthou)
         string(3:3) = digit(thousand)
         string(4:4) = digit(hundred)
         string(5:5) = digit(tens)
         string(6:6) = digit(ones)
      else if (size .eq. 5) then
         string(1:1) = digit(tenthou)
         string(2:2) = digit(thousand)
         string(3:3) = digit(hundred)
         string(4:4) = digit(tens)
         string(5:5) = digit(ones)
      else if (size .eq. 4) then
         string(1:1) = digit(thousand)
         string(2:2) = digit(hundred)
         string(3:3) = digit(tens)
         string(4:4) = digit(ones)
      else if (size .eq. 3) then
         string(1:1) = digit(hundred)
         string(2:2) = digit(tens)
         string(3:3) = digit(ones)
      else if (size .eq. 2) then
         string(1:1) = digit(tens)
         string(2:2) = digit(ones)
      else
         string(1:1) = digit(ones)
      end if

      if (right) then
         do i = size, 1, -1
            pos = length - size + i
            string(pos:pos) = string(i:i)
         end do
         do i = 1, length-size
            string(i:i) = ' '
         end do
      else
         do i = size+1, length
            string(i:i) = ' '
         end do
      end if
      return
      end

------------------------------------------------------------------------

!      Written by In-Ho Lee, KRISS, September 11, 2013.
       subroutine onedprint10(xxx,npt)
       implicit none
       integer npt
       real*8 xxx(npt)
       integer i,j,k,irem

       do i=1,npt/10
       j=(i-1)*10
       write(6,112) (xxx(j+k),k=1,10)
       enddo
       irem=npt-(npt/10)*10
       j=(npt/10)*10
       write(6,112) (xxx(j+k),k=1,irem)
!112   format(10e11.4)
 112   format(10e12.4)

       return
       end

------------------------------------------------------------------------
!
!      Written by In-Ho Lee, KRISS, September 11, 2013.
       subroutine init_seed()
       implicit none
       integer n,ival(8),jv(3),i
       integer, allocatable :: kseed(:)

       call date_and_time(values=ival)
       jv(1) = ival(8) + 2048*ival(7)
       jv(2) = ival(6) + 64*ival(5) ! value(4) isn't really random
       jv(3) = ival(3) + 32*ival(2) + 32*8*ival(1)
       call random_seed(size=n)
       allocate(kseed(n))
       call random_seed()          ! Give the seed an implementation-dependent kick
       call random_seed(get=kseed)
       do i=1, n
       kseed(i) = kseed(i) + jv(mod(i-1, 3) + 1)
       enddo
       call random_seed(put=kseed)
       deallocate(kseed)
       end

------------------------------------------------------------------------
!
!      Written by In-Ho Lee, KRISS, September 11, 2013.
       subroutine f90sleep(dtinsec)
       implicit none
       real*8 :: dtinsec         ! desired sleep interval [s]
       integer,dimension(8) :: t ! arguments for date_and_time
       integer :: s1,s2,ms1,ms2  ! start and end times [ms]
       real*8 :: dt              ! desired sleep interval [ms]

       dt=dtinsec*1.d3
       call date_and_time(values=t)
       ms1=(t(5)*3600+t(6)*60+t(7))*1000+t(8)

       do
         call date_and_time(values=t)
         ms2=(t(5)*3600+t(6)*60+t(7))*1000+t(8)
         if(ms2-ms1>=dt)exit
       enddo
       end

------------------------------------------------------------------------
      subroutine sortnr(n,arrin,indx)
!     sorts an array by the heapsort method
!     w. h. preuss et al. numerical recipes
      implicit real*8 (a-h,o-z)
      dimension arrin(n),indx(n)
      do 11 j=1,n
        indx(j)=j
 11   continue
      l=n/2+1
      ir=n
 10   continue
        if(l.gt.1)then
          l=l-1
          indxt=indx(l)
          q=arrin(indxt)
        else
          indxt=indx(ir)
          q=arrin(indxt)
          indx(ir)=indx(1)
          ir=ir-1
          if(ir.eq.1)then
            indx(1)=indxt
            return
          endif
        endif
        i=l
        j=l+l
 20     if(j.le.ir)then
          if(j.lt.ir)then
            if(arrin(indx(j)).lt.arrin(indx(j+1)))j=j+1
          endif
          if(q.lt.arrin(indx(j)))then
            indx(i)=indx(j)
            i=j
            j=j+j
          else
            j=ir+1
          endif
        go to 20
        endif
        indx(i)=indxt
      go to 10
      end

------------------------------------------------------------------------
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    May 31 2001   9:45:54.872 AM
!
!  Modified:
!
!    31 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer d
  character ( len = 8 ) date
  integer h
  integer m
  integer mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer n
  integer s
  character ( len = 10 )  time
  integer values(8)
  integer y
  character ( len = 5 ) zone

  call date_and_time ( date, time, zone, values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end

------------------------------------------------------------------------
       character*8 fnnd ; character*10 fnnt

       call date_and_time(date=fnnd,time=fnnt)
       write(6,'(a10,2x,a8,2x,a10)') 'date,time ', fnnd,fnnt


------------------------------------------------------------------------
http://flibs.sourceforge.net/examples_modern_fortran.html
FLIBS
http://www.dmoz.org/Computers/Programming/Languages/Fortran/Libraries/
SCILIB
------------------------------------------------------------------------
C   delim - parse a string and store tokens into an array
C
C SYNOPSIS/USAGE
C       SUBROUTINE DELIM(LINE,ARRAY,N,ICOUNT,IBEGIN,ITERM,ILEN,DLIM)
C       CHARACTER*(*) STRING
C       CHARACTER DLIM*(*)
C       CHARACTER*(n) ARRAY(N)
C
C DESCRIPTION
C
C      Given a LINE of structure " par1 par2 par3 ... par(n) "
C      store each par(n) into a separate variable in ARRAY (UNLESS
C      ARRAY(1).eq.'#NULL#')
C
C      Also set ICOUNT to number of elements of array initialized, and
C      return beginning and ending positions for each element in IBEGIN(N)
C      and ITERM(N).
C      Return position of last non-blank character (even if more
C      than n elements were found) in ILEN
C      No quoting or escaping of delimiter is allowed, so the delimiter
C      character can not be placed in a token.
C      No checking for more than N parameters; If any more they are ignored.
C
C       o  LINE      - input string to parse into tokens
C       o  ARRAY(N)  - array that receives tokens. Elements should be up to
C                      size of LINE to avoid truncation (eg. LINE may contain
C                      only on token).
C       o  N         - size of arrays ARRAY, IBEGIN, ITERM
C       o  ICOUNT    - number of tokens found
C       o  IBEGIN(N) - starting columns of tokens found
C       o  ITERM(N)  - ending columns of tokens found
C       o  ILEN      -  position of last non-blank character in input string LINE
C       o  DLIM      - delimiter character(s)
C
C   NOTES
C
C     Still F77-compatible, except for F90 intrinsic use of LEN_TRIM(). Common
C     variants store only token end points, treat blank tokens at end of line
C     or null tokens differently, or store only tokens and no end points, or
C     allow delimiters in tokens when in quotes or "escaped" with a backslash
C     character.

C       o  Legal Restrictions: none
C       o  Dependencies: LEN_TRIM()
C       o  Authors: John S. Urban
C       o  Circa:   1981, 2010

      PROGRAM DEMO
      CHARACTER *80 LINE
      PARAMETER (N=10)
      CHARACTER*20 ARRAY(N)

C     a nice idea in case full of garbage
      ARRAY(1)=' '
      LINE=' first second 10.3 words_of_stuff '
      CALL TESTIT(LINE,' ',ARRAY)
      CALL TESTIT('abc : def: ::hijk:',':',ARRAY)
C     note space is first in delimiter list
      CALL TESTIT(LINE,' aeiou',ARRAY)
      ARRAY(1)='#NULL#'
      CALL TESTIT(LINE,'aeiou',ARRAY)
      LINE='AAAaBBBBBBbIIIIIi J K L'
      CALL TESTIT(LINE,'aeiou',ARRAY)
      END

      SUBROUTINE TESTIT(LINE,DLM,ARRAY)
      CHARACTER *(*) LINE
      character*(*) DLM
      PARAMETER (N=10)
      CHARACTER*20 ARRAY(N)

      INTEGER IBEGIN(N),ITERM(N)
      WRITE(*,'(80(''=''))')
      WRITE(*,'(''PARSING=['',a,'']'')')LINE
      WRITE(*,'(a,a,a)')'DELIMITERS==[',DLM,']'
      CALL DELIM(LINE,ARRAY,N,ICOUNT,IBEGIN,ITERM,ILEN,DLM)
      WRITE(*,*)'number of tokens found=',ICOUNT
      WRITE(*,*)'last character in column ',ILEN
      IF(ICOUNT.GT.0)THEN
         IF(ILEN.NE.ITERM(ICOUNT))THEN
            WRITE(*,*)'ignored from column ',ITERM(ICOUNT)+1,' to ',ILEN
         ENDIF
         DO 10 I10=1,ICOUNT
         if(array(1).ne.'#NULL#')then
            WRITE(*,*)'[',ARRAY(I10)(:ITERM(I10)-IBEGIN(I10)+1),']'   ! from array
         else
            WRITE(*,*)'[',LINE(IBEGIN(I10):ITERM(I10)),']'            ! from original line
         endif
10       CONTINUE
      ENDIF
      write(*,*)'Press "Enter" to continue ....'
      read(*,*)
      END

C=======================================================================--------
      SUBROUTINE DELIM(LINE0,ARRAY,N,ICOUNT,IBEGIN,ITERM,ILEN,DLIM)
C     @(#) parse a string and store tokens into an array
C
C     given a line of structure " par1 par2 par3 ... parn "
C     store each par(n) into a separate variable in array.
C
C     IF ARRAY(1).eq.'#NULL#' do not store into string array  (KLUDGE))
C
C     also count number of elements of array initialized, and
C     return beginning and ending positions for each element.
C     also return position of last non-blank character (even if more
C     than n elements were found).
C
C     no quoting of delimiter is allowed
C     no checking for more than n parameters, if any more they are ignored
C
C     input line limited to 1024 characters
C
      CHARACTER*(*)     LINE0, DLIM*(*)
      PARAMETER (MAXLEN=1024)
      CHARACTER*(MAXLEN) LINE
      CHARACTER ARRAY(N)*(*)
      INTEGER ICOUNT, IBEGIN(N),ITERM(N),ILEN
      LOGICAL LSTORE
      ICOUNT=0
      ILEN=LEN_TRIM(LINE0)
      IF(ILEN.GT.MAXLEN)THEN
         write(*,*)'*delim* input line too long'
      ENDIF
      LINE=LINE0

      IDLIM=LEN(DLIM)
      IF(IDLIM.GT.5)THEN
C        dlim a lot of blanks on some machines if dlim is a big string
         IDLIM=LEN_TRIM(DLIM)
C        blank string
         IF(IDLIM.EQ.0)IDLIM=1
      ENDIF

C     command was totally blank
      IF(ILEN.EQ.0)RETURN
C
C     there is at least one non-blank character in the command
C     ilen is the column position of the last non-blank character
C     find next non-delimiter
      icol=1

C     special flag to not store into character array
      IF(ARRAY(1).EQ.'#NULL#')THEN
         LSTORE=.FALSE.
      ELSE
         LSTORE=.TRUE.
      ENDIF

C     store into each array element until done or too many words
      DO 100 IARRAY=1,N,1
200      CONTINUE
C        if current character is not a delimiter
         IF(INDEX(DLIM(1:IDLIM),LINE(ICOL:ICOL)).EQ.0)THEN
C          start new token on the non-delimiter character
           ISTART=ICOL
           IBEGIN(IARRAY)=ICOL
C          assume no delimiters so put past end of line
           IEND=ILEN-ISTART+1+1

           DO 10 I10=1,IDLIM
              IFOUND=INDEX(LINE(ISTART:ILEN),DLIM(I10:I10))
              IF(IFOUND.GT.0)THEN
                IEND=MIN(IEND,IFOUND)
              ENDIF
10         CONTINUE

C          no remaining delimiters
           IF(IEND.LE.0)THEN
             ITERM(IARRAY)=ILEN
             IF(LSTORE)ARRAY(IARRAY)=LINE(ISTART:ILEN)
             ICOUNT=IARRAY
             RETURN
           ELSE
             IEND=IEND+ISTART-2
             ITERM(IARRAY)=IEND
             IF(LSTORE)ARRAY(IARRAY)=LINE(ISTART:IEND)
           ENDIF
           ICOL=IEND+2
         ELSE
           ICOL=ICOL+1
           GOTO 200
         ENDIF
C        last character in line was a delimiter, so no text left
C        (should not happen where blank=delimiter)
         IF(ICOL.GT.ILEN)THEN
           ICOUNT=IARRAY
           RETURN
         ENDIF
100   CONTINUE
C     more than n elements
      ICOUNT=N
      RETURN
      END
------------------------------------------------------------------------
! -----------------------------------------------
MODULE String_Functions  ! by David Frank dave_frank@hotmail.com
IMPLICIT NONE            ! http://home.earthlink.net/~dave_gemini/strings.f90

! Copy (generic) char array to string or string to char array
! Clen returns same as LEN unless last non-blank char = null
! Clen_trim returns same as LEN_TRIM " "
! Ctrim returns same as TRIM " "
! Count_Items in string that are blank or comma separated
! Reduce_Blanks in string to 1 blank between items, last char not blank
! Replace_Text in all occurances in string with replacement string
! Spack pack string's chars == extract string's chars
! Tally occurances in string of text arg
! Translate text arg via indexed code table
! Upper/Lower case the text arg

INTERFACE Copy    ! generic
   MODULE PROCEDURE copy_a2s, copy_s2a
END INTERFACE Copy

CONTAINS
! ------------------------
PURE FUNCTION Copy_a2s(a)  RESULT (s)    ! copy char array to string
CHARACTER,INTENT(IN) :: a(:)
CHARACTER(SIZE(a)) :: s
INTEGER :: i
DO i = 1,SIZE(a)
   s(i:i) = a(i)
END DO
END FUNCTION Copy_a2s

! ------------------------
PURE FUNCTION Copy_s2a(s)  RESULT (a)   ! copy s(1:Clen(s)) to char array
CHARACTER(*),INTENT(IN) :: s
CHARACTER :: a(LEN(s))
INTEGER :: i
DO i = 1,LEN(s)
   a(i) = s(i:i)
END DO
END FUNCTION Copy_s2a

! ------------------------
PURE INTEGER FUNCTION Clen(s)      ! returns same result as LEN unless:
CHARACTER(*),INTENT(IN) :: s       ! last non-blank char is null
INTEGER :: i
Clen = LEN(s)
i = LEN_TRIM(s)
IF (s(i:i) == CHAR(0)) Clen = i-1  ! len of C string
END FUNCTION Clen

! ------------------------
PURE INTEGER FUNCTION Clen_trim(s) ! returns same result as LEN_TRIM unless:
CHARACTER(*),INTENT(IN) :: s       ! last char non-blank is null, if true:
INTEGER :: i                       ! then len of C string is returned, note:
                                   ! Ctrim is only user of this function
i = LEN_TRIM(s) ; Clen_trim = i
IF (s(i:i) == CHAR(0)) Clen_trim = Clen(s)   ! len of C string
END FUNCTION Clen_trim

! ----------------
FUNCTION Ctrim(s1)  RESULT(s2)     ! returns same result as TRIM unless:
CHARACTER(*),INTENT(IN)  :: s1     ! last non-blank char is null in which
CHARACTER(Clen_trim(s1)) :: s2     ! case trailing blanks prior to null
s2 = s1                            ! are output
END FUNCTION Ctrim

! --------------------
INTEGER FUNCTION Count_Items(s1)  ! in string or C string that are blank or comma separated
CHARACTER(*) :: s1
CHARACTER(Clen(s1)) :: s
INTEGER :: i, k

s = s1                            ! remove possible last char null
k = 0  ; IF (s /= ' ') k = 1      ! string has at least 1 item
DO i = 1,LEN_TRIM(s)-1
   IF (s(i:i) /= ' '.AND.s(i:i) /= ',' &
                    .AND.s(i+1:i+1) == ' '.OR.s(i+1:i+1) == ',') k = k+1
END DO
Count_Items = k
END FUNCTION Count_Items

! --------------------
FUNCTION Reduce_Blanks(s)  RESULT (outs)
CHARACTER(*)      :: s
CHARACTER(LEN_TRIM(s)) :: outs
INTEGER           :: i, k, n

n = 0  ; k = LEN_TRIM(s)          ! k=index last non-blank (may be null)
DO i = 1,k-1                      ! dont process last char yet
   n = n+1 ; outs(n:n) = s(i:i)
   IF (s(i:i+1) == ' ') n = n-1  ! backup/discard consecutive output blank
END DO
n = n+1  ; outs(n:n)  = s(k:k)    ! last non-blank char output (may be null)
IF (n < k) outs(n+1:) = ' '       ! pad trailing blanks
END FUNCTION Reduce_Blanks

! ------------------
FUNCTION Replace_Text (s,text,rep)  RESULT(outs)
CHARACTER(*)        :: s,text,rep
CHARACTER(LEN(s)+100) :: outs     ! provide outs with extra 100 char len
INTEGER             :: i, nt, nr

outs = s ; nt = LEN_TRIM(text) ; nr = LEN_TRIM(rep)
DO
   i = INDEX(outs,text(:nt)) ; IF (i == 0) EXIT
   outs = outs(:i-1) // rep(:nr) // outs(i+nt:)
END DO
END FUNCTION Replace_Text

! ---------------------------------
FUNCTION Spack (s,ex)  RESULT (outs)
CHARACTER(*) :: s,ex
CHARACTER(LEN(s)) :: outs
CHARACTER :: aex(LEN(ex))   ! array of ex chars to extract
INTEGER   :: i, n

n = 0  ;  aex = Copy(ex)
DO i = 1,LEN(s)
   IF (.NOT.ANY(s(i:i) == aex)) CYCLE   ! dont pack char
   n = n+1 ; outs(n:n) = s(i:i)
END DO
outs(n+1:) = ' '     ! pad with trailing blanks
END FUNCTION Spack

! --------------------
INTEGER FUNCTION Tally (s,text)
CHARACTER(*) :: s, text
INTEGER :: i, nt

Tally = 0 ; nt = LEN_TRIM(text)
DO i = 1,LEN(s)-nt+1
   IF (s(i:i+nt-1) == text(:nt)) Tally = Tally+1
END DO
END FUNCTION Tally

! ---------------------------------
FUNCTION Translate(s1,codes)  RESULT (s2)
CHARACTER(*)       :: s1, codes(2)
CHARACTER(LEN(s1)) :: s2
CHARACTER          :: ch
INTEGER            :: i, j

DO i = 1,LEN(s1)
   ch = s1(i:i)
   j = INDEX(codes(1),ch) ; IF (j > 0) ch = codes(2)(j:j)
   s2(i:i) = ch
END DO
END FUNCTION Translate

! ---------------------------------
FUNCTION Upper(s1)  RESULT (s2)
CHARACTER(*)       :: s1
CHARACTER(LEN(s1)) :: s2
CHARACTER          :: ch
INTEGER,PARAMETER  :: DUC = ICHAR('A') - ICHAR('a')
INTEGER            :: i

DO i = 1,LEN(s1)
   ch = s1(i:i)
   IF (ch >= 'a'.AND.ch <= 'z') ch = CHAR(ICHAR(ch)+DUC)
   s2(i:i) = ch
END DO
END FUNCTION Upper

! ---------------------------------
FUNCTION Lower(s1)  RESULT (s2)
CHARACTER(*)       :: s1
CHARACTER(LEN(s1)) :: s2
CHARACTER          :: ch
INTEGER,PARAMETER  :: DUC = ICHAR('A') - ICHAR('a')
INTEGER            :: i

DO i = 1,LEN(s1)
   ch = s1(i:i)
   IF (ch >= 'A'.AND.ch <= 'Z') ch = CHAR(ICHAR(ch)-DUC)
   s2(i:i) = ch
END DO
END FUNCTION Lower

END MODULE String_Functions
------------------------------------------------------------------------

       character(len=20) function str(k)
!      "Convert an integer to string."
       integer, intent(in) :: k
       write (str, *) k
       str = adjustl(str)
       end function str
!     And here is a test code:
       program x
       integer :: i
       character(len=20) :: str

       do i=1,100
           open(11, file='Output'//trim(str(i))//'.txt')
           write (11, *) i
           close (11)
       end do
       end program x


------------------------------------------------------------------------

   logical :: fexists

    inquire(file=trim(adjustl(file)), exist=fexists)
    if (fexists) then
       write(0,*) 'Error: file already exists: ', trim(adjustl(file))
       stop
    end if

------------------------------------------------------------------------

Pure Function to_upper (str) Result (string)

! ==============================
! Changes a string to upper case
! ==============================

Implicit None
Character(*), Intent(In) :: str
Character(LEN(str)) :: string

Integer :: ic, i

Character(26), Parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
Character(26), Parameter :: low = 'abcdefghijklmnopqrstuvwxyz'

! Capitalize each letter if it is lowecase
string = str
do i = 1, LEN_TRIM(str)
ic = INDEX(low, str(i:i))
if (ic > 0) string(i:i) = cap(ic:ic)
end do

End Function to_upper

------------------------------------------------------------------------
--------------------------------------------------------------------------------------------------------------------

       character*200 str1
       integer ios,nargs
       character*200 args(40)
       character*20 delims


       open(81,file=trim(otname),form='formatted')
       do
       read(81,'(a200)',err=921,end=909) str1
       delims=' '
       call parse(str1,delims,args,nargs)
       if(nargs == 7)then
       if(args(1) == 'energy'  )then
       if(args(2) == 'without' )then
       if(args(3) == 'entropy=')then
       call value(args(4),etot,ios)
!      print*, str1
!      print*, etot
                                endif
                                endif
                                endif
                     endif


--------------------------------------------------------------------------------------------------------------------

------------------------------------------------------------------------


덧글

  • 2016/04/12 07:29 # 답글 비공개

    비공개 덧글입니다.
  • 바죠 2016/04/23 08:56 # 답글

    character (len=8) :: test_name

    do i=1, 3
    do j=1, 3
    write (test_name, '( "test_", I1, "_", I1 )' ) i, j
    call system ( "mkdir " // test_name )
    end do
    end do
  • 바죠 2016/05/17 10:29 # 답글

    Pure Function to_upper (str) Result (string)

    ! ==============================
    ! Changes a string to upper case
    ! ==============================

    Implicit None
    Character(*), Intent(In) :: str
    Character(LEN(str)) :: string

    Integer :: ic, i

    Character(26), Parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
    Character(26), Parameter :: low = 'abcdefghijklmnopqrstuvwxyz'

    ! Capitalize each letter if it is lowecase
    string = str
    do i = 1, LEN_TRIM(str)
    ic = INDEX(low, str(i:i))
    if (ic > 0) string(i:i) = cap(ic:ic)
    end do

    End Function to_upper
  • 바죠 2017/02/16 20:11 # 답글

    program foo

    character(len=1024) :: filename
    character(len=1024) :: format_string
    integer :: i

    do i=1, 10
    if (i < 10) then
    format_string = "(A5,I1)"
    else
    format_string = "(A5,I2)"
    endif

    write (filename,format_string) "hello", i
    print *, trim(filename)
    enddo

    end program
  • 바죠 2017/02/16 20:13 # 답글

    subroutine nume_fisier (i,filename_tot)

    implicit none
    integer :: i

    integer :: integer_zeci,rest_zeci,integer_sute,rest_sute,integer_mii,rest_mii
    character(1) :: filename1,filename2,filename3,filename4
    character(4) :: filename_tot

    ! Subrutina ce transforma un INTEGER de la 0 la 9999 in o serie de CARACTERE cu acelasi numar

    ! pentru a fi folosite in numerotarea si denumirea fisierelor de rezultate.

    if(i<=9) then

    filename1=char(48+0)
    filename2=char(48+0)
    filename3=char(48+0)
    filename4=char(48+i)

    elseif(i>=10.and.i<=99) then

    integer_zeci=int(i/10)
    rest_zeci=mod(i,10)
    filename1=char(48+0)
    filename2=char(48+0)
    filename3=char(48+integer_zeci)
    filename4=char(48+rest_zeci)

    elseif(i>=100.and.i<=999) then

    integer_sute=int(i/100)
    rest_sute=mod(i,100)
    integer_zeci=int(rest_sute/10)
    rest_zeci=mod(rest_sute,10)
    filename1=char(48+0)
    filename2=char(48+integer_sute)
    filename3=char(48+integer_zeci)
    filename4=char(48+rest_zeci)

    elseif(i>=1000.and.i<=9999) then

    integer_mii=int(i/1000)
    rest_mii=mod(i,1000)
    integer_sute=int(rest_mii/100)
    rest_sute=mod(rest_mii,100)
    integer_zeci=int(rest_sute/10)
    rest_zeci=mod(rest_sute,10)
    filename1=char(48+integer_mii)
    filename2=char(48+integer_sute)
    filename3=char(48+integer_zeci)
    filename4=char(48+rest_zeci)

    endif

    filename_tot=''//filename1//''//filename2//''//filename3//''//filename4//''
    return
    end subroutine nume_fisier
댓글 입력 영역