My Project
ocpids.f90
Go to the documentation of this file.
1 
2 
3 
4 
5 
6 
7 
8 
9 
10 
11 
12 ! Last change: NB 04 Jan 2001 12:00 pm
13 !
14 ! OCEAN PACK - Installation dependent subroutines
15 !
16 !*****************************************************************
17 ! *
18  SUBROUTINE ocpini (INIFIL, LREAD, INERR)
19 ! *
20 !*****************************************************************
21 !
22  USE ocpcomm1
23  USE ocpcomm2
24  USE ocpcomm3
25  USE ocpcomm4
26  USE m_parall
27 
28 !
29 !
30 ! --|-----------------------------------------------------------|--
31 ! | Delft University of Technology |
32 ! | Faculty of Civil Engineering |
33 ! | Environmental Fluid Mechanics Section |
34 ! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
35 ! | |
36 ! | Programmers: R.C. Ris, N. Booij, |
37 ! | IJ.G. Haagsma, A.T.M.M. Kieftenburg, |
38 ! | M. Zijlema, E.E. Kriezi, |
39 ! | R. Padilla-Hernandez, L.H. Holthuijsen |
40 ! --|-----------------------------------------------------------|--
41 !
42 !
43 ! SWAN (Simulating WAves Nearshore); a third generation wave model
44 ! Copyright (C) 2004-2005 Delft University of Technology
45 !
46 ! This program is free software; you can redistribute it and/or
47 ! modify it under the terms of the GNU General Public License as
48 ! published by the Free Software Foundation; either version 2 of
49 ! the License, or (at your option) any later version.
50 !
51 ! This program is distributed in the hope that it will be useful,
52 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
53 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
54 ! GNU General Public License for more details.
55 !
56 ! A copy of the GNU General Public License is available at
57 ! http://www.gnu.org/copyleft/gpl.html#SEC3
58 ! or by writing to the Free Software Foundation, Inc.,
59 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
60 !
61 !
62 ! 0. Authors
63 !
64 ! 30.74: IJsbrand Haagsma (Include version)
65 ! 30.82: IJsbrand Haagsma
66 ! 34.01: IJsbrand Haagsma
67 ! 40.00, 40.03: Nico Booij
68 ! 40.30: Marcel Zijlema
69 ! 40.31: Marcel Zijlema
70 ! 40.41: Marcel Zijlema
71 !
72 ! 1. Updates
73 !
74 ! 10.02, July 94: New argument INIFIL
75 ! Check on validity period now uses OCDTIM
76 ! 30.74, Nov. 97: Prepared for version with INCLUDE statements
77 ! 30.82, Nov. 98: Introduced recordlength of 1000 for file PRINT to
78 ! avoid error-messages on the Cray-J90 and SGI Origin 200
79 ! 34.01, Feb. 99: Changed STOP statements for MSGERR(4,'message')
80 ! calls
81 ! 34.01, Feb. 99: Opens a file 'screen' when unitnr in swaninit<>6
82 ! 40.00, Feb. 99: Directory separation characters included in init file
83 ! these characters are used in subr FOR
84 ! 40.03, May 00: backslash replaced by CHAR(92) because of problems on Linux
85 ! 40.30, Jan. 03: introduction distributed-memory approach using MPI
86 ! 40.31, Nov. 03: removing HPGL-functionality
87 ! 40.41, Sep. 04: includes speed processors in initialisation file
88 ! 40.41, Oct. 04: common blocks replaced by modules, include files removed
89 !
90 ! 2. Purpose
91 !
92 ! subroutine initialises a number of common variables
93 ! opens standard input and output files, if necessary
94 !
95 ! 4. Argument variables
96 !
97 ! INERR : output Number of the initialisation error
98 !
99  INTEGER INERR
100 !
101 ! INIFIL inp char name of initialisation file
102 ! LREAD inp log if True: command input file must be opened
103 ! and command reading must be initialised
104 !
105  LOGICAL LREAD, FILEXI
106  CHARACTER INPFIL *40, OUTFIL *40, INIFIL *(*), TSTFIL *40, &
107  PLTOPT *4, TIMSTR *24, &
108  OUTFO *40, TSTFO *40, TXT*120
109  INTEGER PRCTIM(6), INIVER, INIVEF
110  INTEGER PFROPT
111  REAL PLPARM(10)
112  INTEGER NUMM(10)
113  LOGICAL STPNOW
114  DATA prctim /0,0,0,0,0,0/
115 !
116 ! version of initialisation file
117  iniver = 4
118  inivef = -1
119  inerr = 0
120 !
121 ! see whether initialisation file exists
122 !
123  INQUIRE (file=inifil, exist=filexi)
124  IF(filexi)THEN
125 !
126 ! read initialisation file
127 !
128  OPEN (11, file=inifil, status='OLD', &
129 !CVIS SHARED, &
130  err=950)
131  READ (11, *, err=930, end=930) inivef
132  IF(inivef > iniver .OR. inivef <= 0) GOTO 935
133  READ (11, 120, err=930, end=930) inst
134  READ (11, *, err=930, end=930) inputf
135  READ (11, 120, err=930, end=930) inpfil
136  READ (11, *, err=930, end=930) printf
137  READ (11, 120, err=930, end=930) outfil
138  READ (11, *, err=930, end=930) prtest
139  READ (11, 120, err=930, end=930) tstfil
140  READ (11, *, err=930, end=930) screen
141  READ (11, *, err=930, end=930) iunmax
142  READ (11, 130, err=930, end=930) comid
143  READ (11, 130, err=930, end=930) tabc
144  IF(inivef >= 2)THEN
145  READ (11, 130, err=930, end=930) dirch1
146  READ (11, 130, err=930, end=930) dirch2
147  ELSE
148 !DOS DIRCH1 = CHAR(47)
149 !DOS DIRCH2 = CHAR(92)
150 !UNIX DIRCH1 = CHAR(92)
151 !UNIX DIRCH2 = CHAR(47)
152  dirch1 = char(92)
153  dirch2 = char(47)
154  ENDIF
155  IF(inivef < 3)THEN
156  READ (11, 140, err=930, end=930) pltopt
157  READ (11, *, err=930, end=930) nplp
158  READ (11, *, err=930, end=930) (plparm(ii),ii=1,nplp)
159  READ (11, *, err=930, end=930) pfropt
160  END IF
161  READ (11, *, err=930, end=930) itmopt
162 !JQI IF(INIVEF > 3)THEN
163 !JQI IF(PARLL)THEN
164 !JQI DO JJ = 1, NPROC
165 !JQI READ (11, 145, ERR=150, END=150) IW, TXT
166 !JQI CALL TXPBLA(TXT,IF,IL)
167 !JQI IPOS = 0
168 !JQI DO II = IF, IL
169 !JQI K = ICHAR(TXT(II:II))
170 !JQI IF(K >= 48 .AND. K <= 57)THEN
171 !JQI IPOS = IPOS + 1
172 !JQI NUMM(IPOS) = K - 48
173 !JQI END IF
174 !JQI END DO
175 !JQI J = 0
176 !JQI DO II = 1, IPOS
177 !JQI J = J + NUMM(II)*10**(IPOS-II)
178 !JQI END DO
179 !JQI IWEIG(J) = IW
180 !JQI END DO
181 !JQI END IF
182 !JQI END IF
183 120 FORMAT (a40)
184 130 FORMAT (a1)
185 140 FORMAT (a4)
186 145 FORMAT (i5,a)
187 150 CLOSE (11)
188  ELSE
189 !
190 ! REFERENCE NUMBERS AND NAMES OF STANDARD FILES
191 !
192  inputf = 3
193  inpfil = 'INPUT'
194  printf = 4
195  outfil = 'PRINT'
196 ! unit ref. numbers for output to screen and to separate
197 ! test print file:
198  prtest = printf
199  tstfil = ' '
200  screen = 6
201  iunmax = 99
202 ! TABC is the Tab character (interpreted as blank in command reading)
203 !DOS TABC = ' '
204 !UNIX TABC = ' '
205 ! COMID is the comment identifier (usually $)
206  comid = '$'
207 ! DIRCH1 is directory separation character as appears in input file
208 ! DIRCH2 is directory separation character replacing DIRCH1
209 !DOS DIRCH1 = CHAR(47)
210 !DOS DIRCH2 = CHAR(92)
211 !UNIX DIRCH1 = CHAR(92)
212 !UNIX DIRCH2 = CHAR(47)
213 ! INST = name of institute, max. 40 characters
214  inst = 'Delft University of Technology'
215  itmopt = 1
216 !
217  ENDIF
218  outfo = outfil
219  tstfo = tstfil
220 
221 ! --- append node number to OUTFIL and TSTFIL
222 ! in case of parallel computing
223 
224 !JQI IF(PARLL)THEN
225 !JQI ILPOS = INDEX ( OUTFIL, ' ' )-1
226 !JQI IF(ILPOS > 0)THEN
227 !JQI WRITE(OUTFIL(ILPOS+1:ILPOS+4),180) INODE
228 !JQI ELSE
229 !JQI GOTO 920
230 !JQI END IF
231 !JQI ILPOS = INDEX ( TSTFIL, ' ' )-1
232 !JQI IF(ILPOS > 0)THEN
233 !JQI WRITE(TSTFIL(ILPOS+1:ILPOS+4),180) INODE
234 !JQI END IF
235 !JQI180 FORMAT('-',I3.3)
236 !JQI CALL SWSYNC
237 !JQI IF(STPNOW()) RETURN
238 !JQI END IF
239 
240  IF(inivef < iniver)THEN
241 !
242 ! write initialisation file
243 !
244  OPEN (12, file=inifil, status='UNKNOWN', form='FORMATTED', err=950)
245  WRITE (12, 210) iniver, 'version of initialisation file'
246  WRITE (12, 220) inst, 'name of institute'
247  WRITE (12, 210) inputf, 'command file ref. number'
248  WRITE (12, 220) inpfil, 'command file name'
249  WRITE (12, 210) printf, 'print file ref. number'
250  WRITE (12, 220) outfo, 'print file name'
251  WRITE (12, 210) prtest, 'test file ref. number'
252  WRITE (12, 220) tstfo, 'test file name'
253  WRITE (12, 210) screen, 'screen ref. number'
254  WRITE (12, 210) iunmax, 'highest file ref. number'
255  WRITE (12, 230) comid, 'comment identifier'
256  WRITE (12, 230) tabc, 'TAB character'
257  WRITE (12, 230) dirch1, 'dir sep char in input file'
258  WRITE (12, 230) dirch2, 'dir sep char replacing previous one'
259  WRITE (12, 210) itmopt, 'default time coding option'
260 !JQI IF(PARLL)THEN
261 !JQI DO II = 1, NPROC
262 !JQI WRITE (12, 240) IWEIG(II), 'speed of processor ',II
263 !JQI END DO
264 !JQI END IF
265  CLOSE (12)
266 210 FORMAT (i5, t41, a)
267 220 FORMAT (a40, a)
268 230 FORMAT (a1, t41, a)
269 240 FORMAT (i5, t41, a19, i3)
270  ENDIF
271 !
272  iunmin = 0
273  funlo = 21
274  funhi = iunmax
275 !
276  CALL ocdtim (prctim)
277 !
278 ! initialise command reader
279 !
280  IF(outfil /= ' ')THEN
281 ! WRITE (*,*) ' Open print file ', PRINTF, OUTFIL
282  OPEN (unit=printf, file=outfil, status='UNKNOWN', form='FORMATTED', &
283 !/Cray RECL=2000, &
284 !/SGI RECL=2000, &
285  err=920)
286 ! WRITE (*,*) ' Print file opened ', PRINTF, OUTFIL
287  CALL dttist (itmopt, timstr, prctim)
288  WRITE (printf, 12) timstr
289 12 FORMAT ('1',//,20x, 'Execution started at ',a, //)
290  ENDIF
291  IF(prtest /= printf) OPEN (unit=prtest, file=tstfil, err=922)
292  IF(screen /= 6) OPEN(unit=screen, file='screen',err=960)
293  IF(lread)THEN
294  IF (inpfil /= ' ') OPEN (unit=inputf, file=inpfil, status='OLD', &
295 !CVIS SHARED, &
296  err=910)
297  CALL rdinit
298  IF (inpfil /= ' ') CLOSE (unit=inputf) !conflict with open statement in function SCAN_FILE2, so close it.
299  ENDIF
300 !
301  RETURN
302 !
303 910 CALL msgerr(4,'Input file missing')
304  RETURN
305 !
306 920 inerr=920
307  IF (inode == master ) WRITE(*,*) 'Cannot open PRINT file '
308  RETURN
309 !
310 922 CALL msgerr(4,'Cannot open test file: '//tstfil)
311  RETURN
312 !
313 930 inerr=930
314  IF(inode == master) WRITE(*,*) 'Error reading initialisation file '
315  RETURN
316 !
317 935 inerr=935
318  IF(inode == master ) WRITE(*,*) 'Incorrect version of initialisation file '
319  RETURN
320 !
321 950 inerr=950
322  IF(inode == master) WRITE(*,*) 'Error opening initialisation file '
323  RETURN
324 !
325 960 CALL msgerr(4,'Error opening output file: screen')
326  RETURN
327 !
328  END SUBROUTINE ocpini
329 
330 !*****************************************************************
331 ! *
332  SUBROUTINE ocdtim (PRCTIM)
333 ! *
334 !*****************************************************************
335 !
336 ! --|-----------------------------------------------------------|--
337 ! | Delft University of Technology |
338 ! | Faculty of Civil Engineering |
339 ! | Environmental Fluid Mechanics Section |
340 ! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
341 ! | |
342 ! | Programmers: R.C. Ris, N. Booij, |
343 ! | IJ.G. Haagsma, A.T.M.M. Kieftenburg, |
344 ! | M. Zijlema, E.E. Kriezi, |
345 ! | R. Padilla-Hernandez, L.H. Holthuijsen |
346 ! --|-----------------------------------------------------------|--
347 !
348 !
349 ! SWAN (Simulating WAves Nearshore); a third generation wave model
350 ! Copyright (C) 2004-2005 Delft University of Technology
351 !
352 ! This program is free software; you can redistribute it and/or
353 ! modify it under the terms of the GNU General Public License as
354 ! published by the Free Software Foundation; either version 2 of
355 ! the License, or (at your option) any later version.
356 !
357 ! This program is distributed in the hope that it will be useful,
358 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
359 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
360 ! GNU General Public License for more details.
361 !
362 ! A copy of the GNU General Public License is available at
363 ! http://www.gnu.org/copyleft/gpl.html#SEC3
364 ! or by writing to the Free Software Foundation, Inc.,
365 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
366 !
367 !
368 ! 0. Authors
369 !
370 ! 30.07
371 ! 30.70: Nico Booij
372 ! 30.82: IJsbrand Haagsma
373 ! 40.02: IJsbrand Haagsma
374 !
375 ! 1. Updates
376 !
377 ! 30.07, Oct. 95: option DEC added
378 ! 30.70, Sep. 97: adaptation in view of year 2000
379 ! 30.82, Mar. 99: Adapted to Fortran 90 standard
380 ! 40.02, Sep. 00: Removed all platform dependent Fortran 77 statements
381 !
382 ! 2. PURPOSE
383 !
384 ! get time of processing, using processor dependent routines
385 !
386 ! 3. PARAMETER LIST
387 !
388 ! PRCTIM outp int time array: elements: year, month, day,
389 ! hour, minute, second
390 !
391 ! 4. SUBROUTINES USED
392 !
393 ! GETDAT, GETTIM or other
394 !
395 ! 5. ERROR MESSAGES
396 !
397 ! ----
398 !
399 ! 6. REMARKS
400 !
401 ! This function uses a processor dependent subroutines (GETDAT,
402 ! GETTIM), therefore adaptations are necessary when compiled
403 ! at a different computer system environment.
404 !
405 ! 7. STRUCTURE
406 !
407 ! ---------------------------------------------------------
408 ! Call DATE and TIME routines (system dependent)
409 ! decode YEAR, MONTH and DAY
410 ! assemble DATE string
411 ! decode HOUR, MINUTE, SECOND
412 ! assemble TIME string
413 ! ---------------------------------------------------------
414 !
415 ! 8. SOURCE TEXT
416 !
417  INTEGER PRCTIM(6)
418 !
419 ! Call DATE and TIME routines
420 !
421 ! --------Fortran 90 date-time routines --------
422 !
423  CHARACTER TIMSTR *24, CDUMMY *5
424  INTEGER IDUMMY(8)
425 !
426  CALL date_and_time (timstr(1:8), timstr(10:20), cdummy, idummy)
427  CALL dtstti (1, timstr, prctim)
428 
429  RETURN
430 
431  END SUBROUTINE ocdtim
432 
433 !*****************************************************************
434 ! *
435  SUBROUTINE dtstti (IOPT, TIMSTR, DTTIME)
436 ! *
437 !*****************************************************************
438 !
439 ! --|-----------------------------------------------------------|--
440 ! | Delft University of Technology |
441 ! | Faculty of Civil Engineering |
442 ! | Environmental Fluid Mechanics Section |
443 ! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
444 ! | |
445 ! | Programmers: R.C. Ris, N. Booij, |
446 ! | IJ.G. Haagsma, A.T.M.M. Kieftenburg, |
447 ! | M. Zijlema, E.E. Kriezi, |
448 ! | R. Padilla-Hernandez, L.H. Holthuijsen |
449 ! --|-----------------------------------------------------------|--
450 !
451 !
452 ! SWAN (Simulating WAves Nearshore); a third generation wave model
453 ! Copyright (C) 2004-2005 Delft University of Technology
454 !
455 ! This program is free software; you can redistribute it and/or
456 ! modify it under the terms of the GNU General Public License as
457 ! published by the Free Software Foundation; either version 2 of
458 ! the License, or (at your option) any later version.
459 !
460 ! This program is distributed in the hope that it will be useful,
461 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
462 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
463 ! GNU General Public License for more details.
464 !
465 ! A copy of the GNU General Public License is available at
466 ! http://www.gnu.org/copyleft/gpl.html#SEC3
467 ! or by writing to the Free Software Foundation, Inc.,
468 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
469 !
470 !
471 ! Updates
472 !
473 ! ver 30.70, Sep 1997 by N.Booij: adaptation in view year 2000
474 !
475 ! Function:
476 !
477 ! transform time string into integer time array
478 !
479 ! Argument list:
480 !
481 ! IOPT input int option number
482 ! 1: ISO notation 19870530.153000
483 ! 2: (HP compiler): 30-May-87 15:30:00
484 ! 3: (old Lahey) 05/30/87 15:30:00
485 ! 4: 15:30:00
486 ! 5: 87/05/30 15:30:00
487 ! 6: WAM 8705301530
488 !
489 ! TIMSTR input char time string
490 ! DTTIME outp int time array: elements: year, month, day,
491 ! hour, minute, second
492 !
493 ! Remarks:
494 ! Options can be added by the user
495 ! existing options should not be changed
496 !
497 ! Source:
498 !
499  INTEGER IOPT, DTTIME(6)
500  CHARACTER TIMSTR *24, MONC(12) *3, MONCI *3
501  DATA monc /'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN', 'JUL', &
502  'AUG', 'SEP', 'OCT', 'NOV', 'DEC'/
503 !
504  IF(iopt == 1)THEN
505  READ (timstr, '(I4,I2,I2,1X,3I2)', err=98) (dttime(ii), ii=1,6)
506 
507  print*,timstr,dttime,'ppppppppppppppppppppppp'
508 
509  ELSE IF(iopt == 2)THEN
510  READ (timstr, '(I2,1X,A3,1X,I2,3(1X,I2))', err=98) &
511  dttime(3), monci, dttime(1), (dttime(ii), ii=4,6)
512  IF(dttime(1) < 10)THEN
513  dttime(1) = 2000 + dttime(1)
514  ELSE
515  dttime(1) = 1900 + dttime(1)
516  ENDIF
517  dttime(2) = 0
518  DO 20 imm = 1, 12
519  CALL upcase (monci)
520  IF (monci.NE.monc(imm)) GOTO 20
521  dttime(2) = imm
522  GOTO 90
523 20 CONTINUE
524  CALL msgerr (2, 'incorrect month string: '//monci)
525  ELSE IF(iopt == 3)THEN
526  READ (timstr, '(I2,5(1X,I2))', err=98) &
527  dttime(2), dttime(3), dttime(1), (dttime(ii), ii=4,6)
528  IF(dttime(1) < 10)THEN
529  dttime(1) = 2000 + dttime(1)
530  ELSE
531  dttime(1) = 1900 + dttime(1)
532  ENDIF
533  ELSE IF(iopt == 4)THEN
534  READ (timstr, '(I2,2(1X,I2))', err=98) (dttime(ii), ii=4,6)
535  DO ii = 1, 3
536  dttime(ii) = 0
537  END DO
538  ELSE IF(iopt == 5)THEN
539  READ (timstr, '(I2,5(1X,I2))', err=98) (dttime(ii), ii=1,6)
540  IF(dttime(1) < 10)THEN
541  dttime(1) = 2000 + dttime(1)
542  ELSE
543  dttime(1) = 1900 + dttime(1)
544  ENDIF
545  ELSE IF(iopt == 6)THEN
546  READ (timstr, '(5I2)', err=98) (dttime(ii), ii=1,5)
547  dttime(6) = 0.
548  IF(dttime(1) < 10)THEN
549  dttime(1) = 2000 + dttime(1)
550  ELSE
551  dttime(1) = 1900 + dttime(1)
552  ENDIF
553  ELSE
554  CALL msgerr (2, 'wrong time coding option in subroutine DTSTTI')
555  ENDIF
556 90 RETURN
557 98 CALL msgerr (2, 'time string unreadable: '//timstr)
558  RETURN
559  END SUBROUTINE dtstti
560 
561 !*****************************************************************
562 ! *
563  SUBROUTINE dttist (IOPT, TIMSTR, DTTIME)
564 ! *
565 !*****************************************************************
566 !
567 ! --|-----------------------------------------------------------|--
568 ! | Delft University of Technology |
569 ! | Faculty of Civil Engineering |
570 ! | Environmental Fluid Mechanics Section |
571 ! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
572 ! | |
573 ! | Programmers: R.C. Ris, N. Booij, |
574 ! | IJ.G. Haagsma, A.T.M.M. Kieftenburg, |
575 ! | M. Zijlema, E.E. Kriezi, |
576 ! | R. Padilla-Hernandez, L.H. Holthuijsen |
577 ! --|-----------------------------------------------------------|--
578 !
579 !
580 ! SWAN (Simulating WAves Nearshore); a third generation wave model
581 ! Copyright (C) 2004-2005 Delft University of Technology
582 !
583 ! This program is free software; you can redistribute it and/or
584 ! modify it under the terms of the GNU General Public License as
585 ! published by the Free Software Foundation; either version 2 of
586 ! the License, or (at your option) any later version.
587 !
588 ! This program is distributed in the hope that it will be useful,
589 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
590 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
591 ! GNU General Public License for more details.
592 !
593 ! A copy of the GNU General Public License is available at
594 ! http://www.gnu.org/copyleft/gpl.html#SEC3
595 ! or by writing to the Free Software Foundation, Inc.,
596 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
597 !
598 !
599 ! Updates
600 !
601 ! ver 30.70, Sep 1997 by N.Booij: adaptation in view year 2000
602 !
603 ! Function:
604 !
605 ! transform integer time array into time string
606 !
607 ! Argument list:
608 !
609 ! IOPT input int option number (see subr. DTSTTI)
610 ! TIMSTR outp char time string
611 ! DTTIME input int time array: elements: year, month, day,
612 ! hour, minute, second
613 !
614 ! Source:
615 !
616  INTEGER IOPT, DTTIME(6)
617  CHARACTER TIMSTR *24, MONC(12) *3
618  DATA monc /'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', &
619  'Aug', 'Sep', 'Oct', 'Nov', 'Dec'/
620 !
621  timstr = ' '
622  IF(iopt == 1)THEN
623  WRITE (timstr, 12) (dttime(ii), ii=1,6)
624 12 FORMAT (i4,i2,i2,'.',3i2)
625  lts = 15
626  ELSE IF(iopt == 2)THEN
627  IF(dttime(1) >= 2000)THEN
628  dttime(1) = dttime(1) - 2000
629  ELSE
630  dttime(1) = dttime(1) - 1900
631  ENDIF
632  WRITE (timstr, 22) dttime(3), monc(dttime(2)), dttime(1), &
633  (dttime(ii), ii=4,6)
634 22 FORMAT (i2,'-',a3,'-',i2,'.',i2,':',i2,':',i2)
635  lts = 18
636  ELSE IF(iopt == 3)THEN
637  IF(dttime(1) >= 2000)THEN
638  dttime(1) = dttime(1) - 2000
639  ELSE
640  dttime(1) = dttime(1) - 1900
641  ENDIF
642  WRITE (timstr, 32) dttime(2), dttime(3), dttime(1), (dttime(ii), ii=4,6)
643 32 FORMAT (i2,'/',i2,'/',i2,'.',i2,':',i2,':',i2)
644  lts = 17
645  ELSE IF(iopt == 4)THEN
646  WRITE (timstr, 42) (dttime(ii), ii=4,6)
647 42 FORMAT (i2,':',i2,':',i2)
648  lts = 8
649  ELSE IF(iopt == 5)THEN
650  IF(dttime(1) >= 2000)THEN
651  dttime(1) = dttime(1) - 2000
652  ELSE
653  dttime(1) = dttime(1) - 1900
654  ENDIF
655  WRITE (timstr, 52) (dttime(ii), ii= 1,6)
656 52 FORMAT (i2,'/',i2,'/',i2,'.',i2,':',i2,':',i2)
657  lts = 17
658  ELSE IF(iopt == 6)THEN
659  IF(dttime(1) >= 2000)THEN
660  dttime(1) = dttime(1) - 2000
661  ELSE
662  dttime(1) = dttime(1) - 1900
663  ENDIF
664  WRITE (timstr, 62) (dttime(ii), ii=1,5)
665 62 FORMAT (5i2)
666  lts = 10
667  ELSE
668  CALL msgerr (2, 'wrong time coding option in subroutine DTTIST')
669  ENDIF
670 !
671  DO ic = 1, lts
672  IF (timstr(ic:ic).EQ.' ') timstr(ic:ic) = '0'
673  END DO
674 !
675  RETURN
676  END SUBROUTINE dttist
677 
ocpcomm4::funhi
integer funhi
Definition: swmod1.f90:515
ocpcomm4::prtest
integer prtest
Definition: swmod1.f90:517
ocpcomm4::funlo
integer funlo
Definition: swmod1.f90:515
m_parall::inode
integer inode
Definition: swmod2.f90:881
ocpcomm4::itmopt
integer itmopt
Definition: swmod1.f90:516
ocpini
subroutine ocpini(INIFIL, LREAD, INERR)
Definition: ocpids.f90:19
ocpcomm4::screen
integer screen
Definition: swmod1.f90:517
ocpcomm4::inputf
integer inputf
Definition: swmod1.f90:516
ocpcomm4::printf
integer printf
Definition: swmod1.f90:517
rdinit
subroutine rdinit
Definition: ocpcre.f90:36
upcase
subroutine upcase(CHARST)
Definition: ocpcre.f90:1863
msgerr
subroutine msgerr(LEV, STRING)
Definition: ocpmix.f90:582
ocpcomm4::iunmin
integer iunmin
Definition: swmod1.f90:517
dtstti
subroutine dtstti(IOPT, TIMSTR, DTTIME)
Definition: ocpids.f90:436
ocdtim
subroutine ocdtim(PRCTIM)
Definition: ocpids.f90:333
ocpcomm1::tabc
character tabc
Definition: swmod1.f90:138
ocpcomm4::iunmax
integer iunmax
Definition: swmod1.f90:516
ocpcomm2::inst
character(len=40) inst
Definition: swmod1.f90:281
ocpcomm2::dirch1
character(len=1) dirch1
Definition: swmod1.f90:279
ocpcomm2::dirch2
character(len=1) dirch2
Definition: swmod1.f90:279
dttist
subroutine dttist(IOPT, TIMSTR, DTTIME)
Definition: ocpids.f90:564
ocpcomm1::comid
character comid
Definition: swmod1.f90:132
m_parall
Definition: swmod2.f90:797
m_parall::master
integer master
Definition: swmod2.f90:864
Generated by   doxygen 1.8.15