tools/OAD_support/OAD_cp.F90

module OAD_cp

  implicit none

  private :: cp_file_number, cp_open

  public :: cp_io_unit,  cp_init, cp_write_open, cp_read_open, cp_close

  integer :: cp_file_number, cp_io_unit

  interface cp_init
     module procedure init_i
  end interface

  interface cp_open
     module procedure open_i
  end interface

  interface cp_write_open
     module procedure write_open_i
  end interface

  interface cp_read_open
     module procedure read_open_i
  end interface

  interface cp_close
     module procedure close_i
  end interface

  interface cp_findunit
     module procedure findunit_i
  end interface

contains

  subroutine init_i
    implicit none
    cp_file_number=1
  end subroutine

  subroutine write_open_i()
    implicit none
    call cp_open()
    cp_file_number=cp_file_number+1
  end subroutine 

  subroutine read_open_i()
    implicit none
    cp_file_number=cp_file_number-1
    call cp_open()
  end subroutine 

  subroutine open_i()
    implicit none
#ifdef ALLOW_USE_MPI
include "mpif.h" 
#endif
    integer rank, mpirc
    character*128 fname ! file name
    ! get unit
    rank=0
    call cp_findunit()
!    print *, 'OAD: opening CP file ', cp_file_number
    ! construct the file name
#ifdef ALLOW_USE_MPI
    call mpi_comm_rank(MPI_COMM_WORLD,rank, mpirc)
#endif
    write(fname,'(A,I3.3,A,I5.5)') 'oad_cp.',rank,'.',cp_file_number
    open( UNIT=cp_io_unit,FILE=TRIM(fname),FORM='unformatted',STATUS='UNKNOWN' )
  end subroutine 

  subroutine close_i()
    implicit none
    close( UNIT=cp_io_unit)
  end subroutine

  subroutine findunit_i()
    ! returns a valid, unused unit number for Fortran I/O
    ! the routine stops the program if an error occurs in the process
    ! of searching the I/O channels.
    implicit none
    ! Local
    integer ii
    logical op
    integer ios
    character*(1024) msgbuf
    ! Sweep through a valid range of unit numbers
    cp_io_unit=-1
    do ii=9,999
       if (cp_io_unit.eq.-1) then
          inquire(unit=ii,iostat=ios,opened=op)
          if (ios.ne.0) then
             write(msgbuf,'(a,i2.2)')  'OAD_cp:findunit_i: inquiring unit number = ',ii
             print *, msgBuf
             write(msgbuf,'(a)') 'OAD_cp:findunit_i: inquire statement failed!'
             print *, msgBuf
             stop 'ABNORMAL END: S/R OAD_cp:findunit_i'
          endif
          if (.NOT. op) then
             cp_io_unit=ii
          end if
       end if
    end do
    ! Was there an available unit number
    if (cp_io_unit.eq.-1) then
       write(msgbuf,'(a)')  'OAD_cp:findunit_i: could not find an available unit number!'
       print *, msgBuf
       stop 'ABNORMAL END: S/R OAD_cp:findunit_i'
    endif
  end subroutine

end module 
1	heimbach	1.1	module OAD_cp
2
3			implicit none
4
5			private :: cp_file_number, cp_open
6
7			public :: cp_io_unit, cp_init, cp_write_open, cp_read_open, cp_close
8
9			integer :: cp_file_number, cp_io_unit
10
11			interface cp_init
12			module procedure init_i
13			end interface
14
15			interface cp_open
16			module procedure open_i
17			end interface
18
19			interface cp_write_open
20			module procedure write_open_i
21			end interface
22
23			interface cp_read_open
24			module procedure read_open_i
25			end interface
26
27			interface cp_close
28			module procedure close_i
29			end interface
30
31			interface cp_findunit
32			module procedure findunit_i
33			end interface
34
35			contains
36
37			subroutine init_i
38			implicit none
39			cp_file_number=1
40			end subroutine
41
42			subroutine write_open_i()
43			implicit none
44			call cp_open()
45			cp_file_number=cp_file_number+1
46			end subroutine
47
48			subroutine read_open_i()
49			implicit none
50			cp_file_number=cp_file_number-1
51			call cp_open()
52			end subroutine
53
54			subroutine open_i()
55			implicit none
56			#ifdef ALLOW_USE_MPI
57			include "mpif.h"
58			#endif
59			integer rank, mpirc
60			character*128 fname ! file name
61			! get unit
62			rank=0
63			call cp_findunit()
64			! print *, 'OAD: opening CP file ', cp_file_number
65			! construct the file name
66			#ifdef ALLOW_USE_MPI
67			call mpi_comm_rank(MPI_COMM_WORLD,rank, mpirc)
68			#endif
69			write(fname,'(A,I3.3,A,I5.5)') 'oad_cp.',rank,'.',cp_file_number
70			open( UNIT=cp_io_unit,FILE=TRIM(fname),FORM='unformatted',STATUS='UNKNOWN' )
71			end subroutine
72
73			subroutine close_i()
74			implicit none
75			close( UNIT=cp_io_unit)
76			end subroutine
77
78			subroutine findunit_i()
79			! returns a valid, unused unit number for Fortran I/O
80			! the routine stops the program if an error occurs in the process
81			! of searching the I/O channels.
82			implicit none
83			! Local
84			integer ii
85			logical op
86			integer ios
87			character*(1024) msgbuf
88			! Sweep through a valid range of unit numbers
89			cp_io_unit=-1
90			do ii=9,999
91			if (cp_io_unit.eq.-1) then
92			inquire(unit=ii,iostat=ios,opened=op)
93			if (ios.ne.0) then
94			write(msgbuf,'(a,i2.2)') 'OAD_cp:findunit_i: inquiring unit number = ',ii
95			print *, msgBuf
96			write(msgbuf,'(a)') 'OAD_cp:findunit_i: inquire statement failed!'
97			print *, msgBuf
98			stop 'ABNORMAL END: S/R OAD_cp:findunit_i'
99			endif
100			if (.NOT. op) then
101			cp_io_unit=ii
102			end if
103			end if
104			end do
105			! Was there an available unit number
106			if (cp_io_unit.eq.-1) then
107			write(msgbuf,'(a)') 'OAD_cp:findunit_i: could not find an available unit number!'
108			print *, msgBuf
109			stop 'ABNORMAL END: S/R OAD_cp:findunit_i'
110			endif
111			end subroutine
112
113			end module