Choral
basic_tools.F90
Go to the documentation of this file.
1 
7 
8 module basic_tools
9 
10  implicit none
11  private
12 
13  public :: inttostring ! tested
14  public :: quit, warning
15 
16 
17  external clockget
18  double precision :: clockget
19  public :: clock
20 
21  public :: allocmem, freemem
22 
24  interface allocmem
25  module procedure alloc_ia1d, alloc_ia2d
26  module procedure alloc_la1d
27  end interface allocmem
28 
30  interface freemem
31  module procedure free_ia1d, free_ia2d
32  module procedure free_la1d
33  end interface freemem
34 
35 
36 
37 contains
38 
39 
41  subroutine inttostring(str, ii)
42  character(len=*), intent(out) :: str
43  integer , intent(in) :: ii
44 
45  !! positive integers
46  !!
47  if ( ii >= 0 ) then
48 
49  if ( ii < 10) then
50  write (str,'(I1)') ii
51 
52  else if ( ii < 100) then
53  write (str,'(I2)') ii
54 
55  else if ( ii < 1000) then
56  write (str,'(I3)') ii
57 
58  else if ( ii < 10000) then
59  write (str,'(I4)') ii
60 
61  else
62  call quit("basic_tools: intToString: n >= 10000")
63  end if
64 
65  end if
66 
67  !! negative integers
68  !!
69  if ( ii < 0 ) then
70 
71  if ( ii > -10) then
72  write (str,'(I2)') ii
73 
74  else if ( ii > -100) then
75  write (str,'(I3)') ii
76 
77  else
78  call quit("basic_tools: intToString: n < -100")
79  end if
80 
81  end if
82 
83  str = trim(str)
84 
85  end subroutine inttostring
86 
87 
93  function clock() result(time)
94  double precision :: time
95 
96  time = clockget()
97 
98  end function clock
99 
100 
105  subroutine quit(message)
106  character(len=*), intent(in) :: message
107 
108  write(*,*)
109  write(*,*) "basic_tools : quit"
110  write(*,*) "ERROR = ", trim(message)
111  stop -1
112 
113  end subroutine quit
114 
124  subroutine warning(message, verb)
125  character(len=*), intent(in) :: message
126  integer , intent(in) :: verb
127 
128 #ifdef NOWARN
129  write(*,*) "basic_tools : "
130  write(*,*) "WARNING: ", trim(message)
131  stop -1
132 
133 #else
134  if (verb>0) then
135  write(*,*) "basic_tools : "
136  write(*,*) "WARNING: ", trim(message)
137  end if
138 #endif
139 
140  end subroutine warning
141 
142 
144  subroutine alloc_ia1d(p,n)
145  integer, dimension(:), allocatable :: p
146  integer, intent(in) :: n
147 
148  integer :: stat
149  character(len=100) :: errmsg
150 
151  call freemem(p)
152  allocate(p(n), stat=stat, errmsg=errmsg)
153  if (stat > 0) then
154  errmsg="alloc_LI: alloc_IA1D: "// trim(errmsg)
155  call quit(errmsg)
156  end if
157 
158  end subroutine alloc_ia1d
159 
161  subroutine alloc_la1d(p,n)
162  logical, dimension(:), allocatable :: p
163  integer, intent(in) :: n
164 
165  integer :: stat
166  character(len=100) :: errmsg
167 
168  call freemem(p)
169  allocate(p(n), stat=stat, errmsg=errmsg)
170  if (stat > 0) then
171  errmsg="alloc_LI: alloc_LA1D: "// trim(errmsg)
172  call quit(errmsg)
173  end if
174 
175  end subroutine alloc_la1d
176 
178  subroutine alloc_ia2d(p,n1,n2)
179  integer, dimension(:,:), allocatable :: p
180  integer, intent(in) :: n1, n2
181 
182  integer :: stat
183  character(len=100) :: errmsg
184 
185  call freemem(p)
186  allocate(p(n1,n2), stat=stat, errmsg=errmsg)
187  if (stat > 0) then
188  errmsg="alloc_LI: alloc_IA2D: "// trim(errmsg)
189  call quit(errmsg)
190  end if
191 
192  end subroutine alloc_ia2d
193 
194 
196  subroutine free_ia1d(p)
197  integer, dimension(:), allocatable :: p
198 
199  integer :: stat
200  character(len=100) :: errmsg
201 
202  if (allocated(p)) then
203  deallocate(p, stat=stat, errmsg=errmsg)
204  if (stat > 0) call quit("alloc_LI: free_IA1D: "//trim(errmsg) )
205  end if
206 
207  end subroutine free_ia1d
208 
210  subroutine free_ia2d(p)
211  integer, dimension(:,:), allocatable :: p
212 
213  integer :: stat
214  character(len=100) :: errmsg
215 
216  if (allocated(p)) then
217  deallocate(p, stat=stat, errmsg=errmsg)
218  if (stat > 0) call quit("alloc_LI: free_IA2D: "//trim(errmsg) )
219  end if
220 
221  end subroutine free_ia2d
222 
223 
224 
226  subroutine free_la1d(p)
227  logical, dimension(:), allocatable :: p
228 
229  integer :: stat
230  character(len=100) :: errmsg
231 
232  if (allocated(p)) then
233  deallocate(p, stat=stat, errmsg=errmsg)
234  if (stat > 0) call quit("alloc_LI: free_LA1D: "//trim(errmsg) )
235  end if
236 
237  end subroutine free_la1d
238 
239 
240 end module basic_tools
allocate memory for allocatable arrays
Definition: basic_tools.F90:24
subroutine free_ia2d(p)
de-allocate a 2-dimensional integer allocatable array
subroutine free_ia1d(p)
de-allocate a one-dimensional integer allocatable array
BASIC TOOLS
Definition: basic_tools.F90:8
double precision function, public clock()
Returns the internal clock time
Definition: basic_tools.F90:94
subroutine, public quit(message)
Stop program execution, display an error messahe.
subroutine alloc_ia2d(p, n1, n2)
allocate a 2-dimensional integer allocatable array
deallocate memory fo allocatable arrays
Definition: basic_tools.F90:30
external clockget
Definition: basic_tools.F90:17
subroutine free_la1d(p)
de-allocate a one-dimensional logical allocatable array
subroutine alloc_ia1d(p, n)
allocate a one-dimensional integer allocatable array
subroutine alloc_la1d(p, n)
allocate a one-dimensional logical allocatable array
subroutine, public inttostring(str, ii)
convert an integer to a string
Definition: basic_tools.F90:42
subroutine, public warning(message, verb)
Warning message.