Blame view

SRC/GENERAL_MODULES/read_write_subroutines.F90 7.91 KB
886c558b   Steve Greedy   SACAMOS Public Re...
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
!
! This file is part of SACAMOS, State of the Art CAble MOdels in Spice. 
! It was developed by the University of Nottingham and the Netherlands Aerospace 
! Centre (NLR) for ESA under contract number 4000112765/14/NL/HK.
! 
! Copyright (C) 2016-2017 University of Nottingham
! 
! SACAMOS is free software: you can redistribute it and/or modify it under the 
! terms of the GNU General Public License as published by the Free Software 
! Foundation, either version 3 of the License, or (at your option) any later 
! version.
! 
! SACAMOS is distributed in the hope that it will be useful, but 
! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
! or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License 
! for more details.
! 
! A copy of the GNU General Public License version 3 can be found in the 
! file GNU_GPL_v3 in the root or at <http://www.gnu.org/licenses/>.
! 
! SACAMOS uses the EISPACK library (in /SRC/EISPACK). EISPACK is subject to 
! the GNU Lesser General Public License. A copy of the GNU Lesser General Public 
! License version can be found in the file GNU_LGPL in the root of EISPACK 
! (/SRC/EISPACK ) or at <http://www.gnu.org/licenses/>.
! 
! The University of Nottingham can be contacted at: ggiemr@nottingham.ac.uk
!
! File Contents:
!SUBROUTINE write_license
!SUBROUTINE path_format
!FUNCTION path_exists
!SUBROUTINE check_and_make_path
!SUBROUTINE write_long_node_list
!
! NAME
!    write_license
!
! DESCRIPTION
!     writes the license agreement note 
!
! HISTORY
!
!     started 3/05/13 CJS
!
! COMMENTS
!     
SUBROUTINE write_license()

IMPLICIT NONE 

! variables passed to subroutine
  
! local variables
  
! START

  write(*,*)''
  write(*,*)'This software is part of SACAMOS, State of the Art CAble MOdels in Spice.'
  write(*,*)'It was developed by the University of Nottingham and the Netherlands Aerospace' 
  write(*,*)'Centre (NLR) for ESA under contract number 4000112765/14/NL/HK.  '
  write(*,*)'  '
  write(*,*)'Copyright (C) 2016-2017 University of Nottingham  '
  write(*,*)'  '
  write(*,*)'SACAMOS is free software: you can redistribute it and/or modify it under the'
  write(*,*)'terms of the GNU General Public License as published by the Free Software'
  write(*,*)'Foundation, either version 3 of the License, or (at your option) any later'
  write(*,*)'version.  '
  write(*,*)'  '
  write(*,*)'SACAMOS is distributed in the hope that it will be useful, but '
  write(*,*)'WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY'
  write(*,*)'or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License'
  write(*,*)'for more details.  '
  write(*,*)'  '
  write(*,*)'A copy of the GNU General Public License version 3 can be found in the'
  write(*,*)'file GNU_GPL_v3 in the root or at <http://www.gnu.org/licenses/>.  '
  write(*,*)'' 
  
  RETURN
  
END SUBROUTINE write_license
!
! NAME
!    path_format
!
! DESCRIPTION
!     check the specified path format- it should end with a /
!     if not, put one on
!
! HISTORY
!
!     started 29/1/2016 CJS
!
! COMMENTS
!     
SUBROUTINE path_format(path)

USE type_specifications

IMPLICIT NONE 

! variables passed to subroutine

character(len=filename_length),intent(INOUT) :: path
  
! local variables

integer :: length
  
! START

  length=LEN_TRIM(path)
  
! Note the different forms for the directory separator in unix and windows
! The file_separator is defined in general_module.F90 for both operating systems
! and is set appropriately using conditional compilation
  
  if (path(length:length).NE.file_separator) then
    path=trim(path)//file_separator
  end if
  
  RETURN
  
END SUBROUTINE path_format
!
! NAME
!    strip_path
!
! DESCRIPTION
!     strip the path from a name based on finding the last file separator character
!     and splitting the inpput string there
!
! HISTORY
!
!     started 24/2/2017 CJS
!
! COMMENTS
!     
!
SUBROUTINE strip_path(ipstring,path,name)

USE type_specifications

IMPLICIT NONE 

! variables passed to subroutine

character(len=filename_length),intent(IN) :: ipstring
character(len=filename_length),intent(OUT) :: path
character(len=filename_length),intent(OUT) :: name
 
! local variables

integer :: length
integer :: path_length
integer :: i
  
! START

  length=LEN_TRIM(ipstring)
  
! Note the different forms for the directory separator in unix and windows
! The file_separator is defined in general_module.F90 for both operating systems
! and is set appropriately using conditional compilation

  path_length=0
  do i=length,1,-1
   
    if (ipstring(i:i).EQ.file_separator) then
      path_length=i
      EXIT
    end if
   
  end do
  
  if (path_length.NE.0) then
    path=ipstring(1:path_length)
    name=ipstring(path_length+1:length)
  else
    path=""
    name=ipstring
  end if 
    
  RETURN
  
END SUBROUTINE strip_path
!
! NAME
!    path_exists
!
! DESCRIPTION
!     check that a given path exists
!     if not, exit with an error
!
! HISTORY
!
!     started 15/1/2016 CJS
!
! COMMENTS
!     
FUNCTION path_exists(path)

USE type_specifications

IMPLICIT NONE 

logical :: path_exists

! variables passed to subroutine

character(len=filename_length),intent(IN)  :: path
  
! local variables

integer :: ierr
  
! START

! Try to create a file in the directory. If it works then assume that the directory exists
  OPEN(unit=temp_file_unit,file=trim(path)//'temp',iostat=ierr)

! Test for success
  path_exists = (ierr == 0)

! Close and delete the temporary file
  if (ierr .EQ. 0) CLOSE(unit=temp_file_unit,status='delete')
  
  RETURN
  
END FUNCTION path_exists
!
! NAME
!    check_and_make_path
!
! DESCRIPTION
!     check that a given path exists
!     if not, make the appropriate directories
!
! HISTORY
!
!     started 15/1/2016 CJS
!
! COMMENTS
! Uses mkdir -p which can build the whole path as opposed to mkdir which can only build the bottom level directory
! mkdir -p works in ubuntu 14.04 - not sure that this is a portable solution though...
! 
SUBROUTINE check_and_make_path(path)

USE type_specifications

IMPLICIT NONE 

! variables passed to subroutine

character(len=filename_length),intent(IN)  :: path
  
! local variables

character(len=line_length)      :: command
  
! START

! check whether the path already exists, if so all is OK and we can return
  if (path_exists(path)) RETURN
  
! the path doesn't exist so we must create it
! Note there are different forms for the system command on unix and windows
! The mkdir_command is defined in general_module.F90 for both operating systems

  command=mkdir_command//trim(path)

  CALL EXECUTE_COMMAND_LINE(command)
 
  RETURN
  
END SUBROUTINE check_and_make_path
!
! NAME
!    write_long_node_list
!
! DESCRIPTION
!      write a long list of nodes such that each line doesn't exceed the specified length
!      This is used so that the maximum number of characters in a spice input file is not exceeded
!
! HISTORY
!
!     started 10/10/2016 CJS
!
! COMMENTS
! 
! 
SUBROUTINE write_long_node_list(n_nodes,node_list,max_length,unit)

USE type_specifications

IMPLICIT NONE 

! variables passed to subroutine

integer,intent(IN) :: n_nodes
integer,intent(IN) :: node_list(n_nodes)
integer,intent(IN) :: max_length
integer,intent(IN) :: unit
  
! local variables

integer :: first_node,last_node,numbers_per_line,number_width
integer :: i
  
! START

  number_width=6                                  ! unmber of characters to write an integer. Must be consistent with format in write below
  numbers_per_line=(max_length-1)/number_width    ! -1 for continuation character
  
! work out the first and last node for the first line    
  first_node=1
  last_node=min(n_nodes,numbers_per_line)
  
  do while (last_node.GE.first_node)
  
! write the line of the number list
    write(unit,'(A)',ADVANCE='NO')'+'
    write(unit,'(1000I6)')(node_list(i),i=first_node,last_node)

! work out the first and last node for the next line    
    first_node=last_node+1
    last_node=min(n_nodes,first_node+numbers_per_line-1)

  end do

  RETURN
  
END SUBROUTINE write_long_node_list