WebSVN – lagranto.um – Diff – /tags/1.0/goodies/newtime.f


      program calcnewdate
C     ===================
 
      implicit none
 
      integer   date1(5),date2(5)
      integer	iargc
      real      diff
      character*(80) arg,yychar,cdat
      character*(2)  cdate(4)
      integer	flag,nc
 
c     check for sufficient requested arguments
      if (iargc().ne.2) then
        print*,'USAGE: newtime date (format (YY)YYMMDD_HH) timestep'
        call exit(1)
      endif
 
c     read and transform input
      call getarg(1,arg)
      call lenchar(arg,nc)
      if (nc.eq.9) then
        yychar=''
        read(arg(1:2),'(i2)',err=120)date1(1)
        read(arg(3:4),'(i2)',err=120)date1(2)
        read(arg(5:6),'(i2)',err=120)date1(3)
        read(arg(8:9),'(i2)',err=120)date1(4)
      else if (nc.eq.11) then
        yychar=arg(1:2)
        read(arg(3:4),'(i2)',err=120)date1(1)
        read(arg(5:6),'(i2)',err=120)date1(2)
        read(arg(7:8),'(i2)',err=120)date1(3)
        read(arg(10:11),'(i2)',err=120)date1(4)
      else
        print*,'USAGE: newtime date (format (YY)YYMMDD_HH) timestep'
        call exit(1)
      endif
 
      call getarg(2,arg)
      call checkchar(arg,".",flag)
      if (flag.eq.0) arg=trim(arg)//"."
      read(arg,'(f10.2)') diff
 
      call newdate(date1,diff,date2)
 
      if ((date2(1).lt.date1(1)).and.
     >    (diff.gt.0.).and.
     >    (yychar.eq.'19')) yychar='20'
 
c      if ((date2(1).lt.date1(1)).and.
c     >    (diff.gt.0.).and.
c     >    (yychar.eq.'20')) yychar='21'
 
      if (date2(1).lt.0) date2(1)=date2(1)+100
 
      if ((date2(1).gt.date1(1)).and.
     >    (diff.lt.0.).and.
     >    (yychar.eq.'20')) yychar='19'
 
c      if ((date2(1).gt.date1(1)).and.
c     >    (diff.lt.0.).and.
c     >    (yychar.eq.'21')) yychar='20'
 
 
      if (date2(1).lt.10) then
        write(cdate(1),'(a,i1)')'0',date2(1)
      else
        write(cdate(1),'(i2)')date2(1)
      endif
      if (date2(2).lt.10) then
        write(cdate(2),'(a,i1)')'0',date2(2)
      else
        write(cdate(2),'(i2)')date2(2)
      endif
      if (date2(3).lt.10) then
        write(cdate(3),'(a,i1)')'0',date2(3)
      else
        write(cdate(3),'(i2)')date2(3)
      endif
      if (date2(4).lt.10) then
        write(cdate(4),'(a,i1)')'0',date2(4)
      else
        write(cdate(4),'(i2)')date2(4)
      endif
 
      cdat=trim(yychar)//cdate(1)//cdate(2)//cdate(3)//'_'//cdate(4)
      write(*,'(a)')trim(cdat)
 
      goto 200
 
 120  write(*,*)"*** error: date must be in format (YY)YYMMDD_HH ***"
 
 200  continue
 
      end
 
      subroutine checkchar(string,char,flag)
C     ======================================
 
      character*(*)	string
      character*(1)	char
      integer	n,flag
 
      flag=0
      do n=1,len(string)
        if (string(n:n).eq.char) then
          flag=n
          return
        endif
      enddo
      end
 
      subroutine lenchar(string,lstr)
C     ===============================
 
      character*(*)     string
      integer   n,lstr
 
      do n=1,len(string)
        if (string(n:n).eq."") then
          lstr=n-1
          goto 100
        endif
      enddo
 100  continue
      end

Rev 3	Rev 4
1	`program calcnewdate`	1	`program calcnewdate`
2	`C ===================`	2	`C ===================`
3		3
4	`implicit none`	4	`implicit none`
5		5
6	`integer date1(5),date2(5)`	6	`integer date1(5),date2(5)`
7	`integer iargc`	7	`integer iargc`
8	`real diff`	8	`real diff`
9	`character*(80) arg,yychar,cdat`	9	`character*(80) arg,yychar,cdat`
10	`character*(2) cdate(4)`	10	`character*(2) cdate(4)`
11	`integer flag,nc`	11	`integer flag,nc`
12		12
13	`c check for sufficient requested arguments`	13	`c check for sufficient requested arguments`
14	`if (iargc().ne.2) then`	14	`if (iargc().ne.2) then`
15	`print*,'USAGE: newtime date (format (YY)YYMMDD_HH) timestep'`	15	`print*,'USAGE: newtime date (format (YY)YYMMDD_HH) timestep'`
16	`call exit(1)`	16	`call exit(1)`
17	`endif`	17	`endif`
18		18
19	`c read and transform input`	19	`c read and transform input`
20	`call getarg(1,arg)`	20	`call getarg(1,arg)`
21	`call lenchar(arg,nc)`	21	`call lenchar(arg,nc)`
22	`if (nc.eq.9) then`	22	`if (nc.eq.9) then`
23	`yychar=''`	23	`yychar=''`
24	`read(arg(1:2),'(i2)',err=120)date1(1)`	24	`read(arg(1:2),'(i2)',err=120)date1(1)`
25	`read(arg(3:4),'(i2)',err=120)date1(2)`	25	`read(arg(3:4),'(i2)',err=120)date1(2)`
26	`read(arg(5:6),'(i2)',err=120)date1(3)`	26	`read(arg(5:6),'(i2)',err=120)date1(3)`
27	`read(arg(8:9),'(i2)',err=120)date1(4)`	27	`read(arg(8:9),'(i2)',err=120)date1(4)`
28	`else if (nc.eq.11) then`	28	`else if (nc.eq.11) then`
29	`yychar=arg(1:2)`	29	`yychar=arg(1:2)`
30	`read(arg(3:4),'(i2)',err=120)date1(1)`	30	`read(arg(3:4),'(i2)',err=120)date1(1)`
31	`read(arg(5:6),'(i2)',err=120)date1(2)`	31	`read(arg(5:6),'(i2)',err=120)date1(2)`
32	`read(arg(7:8),'(i2)',err=120)date1(3)`	32	`read(arg(7:8),'(i2)',err=120)date1(3)`
33	`read(arg(10:11),'(i2)',err=120)date1(4)`	33	`read(arg(10:11),'(i2)',err=120)date1(4)`
34	`else`	34	`else`
35	`print*,'USAGE: newtime date (format (YY)YYMMDD_HH) timestep'`	35	`print*,'USAGE: newtime date (format (YY)YYMMDD_HH) timestep'`
36	`call exit(1)`	36	`call exit(1)`
37	`endif`	37	`endif`
38		38
39	`call getarg(2,arg)`	39	`call getarg(2,arg)`
40	`call checkchar(arg,".",flag)`	40	`call checkchar(arg,".",flag)`
41	`if (flag.eq.0) arg=trim(arg)//"."`	41	`if (flag.eq.0) arg=trim(arg)//"."`
42	`read(arg,'(f10.2)') diff`	42	`read(arg,'(f10.2)') diff`
43		43
44	`call newdate(date1,diff,date2)`	44	`call newdate(date1,diff,date2)`
45		45
46	`if ((date2(1).lt.date1(1)).and.`	46	`if ((date2(1).lt.date1(1)).and.`
47	`> (diff.gt.0.).and.`	47	`> (diff.gt.0.).and.`
48	`> (yychar.eq.'19')) yychar='20'`	48	`> (yychar.eq.'19')) yychar='20'`
49		49
50	`c if ((date2(1).lt.date1(1)).and.`	50	`c if ((date2(1).lt.date1(1)).and.`
51	`c > (diff.gt.0.).and.`	51	`c > (diff.gt.0.).and.`
52	`c > (yychar.eq.'20')) yychar='21'`	52	`c > (yychar.eq.'20')) yychar='21'`
53		53
54	`if (date2(1).lt.0) date2(1)=date2(1)+100`	54	`if (date2(1).lt.0) date2(1)=date2(1)+100`
55		55
56	`if ((date2(1).gt.date1(1)).and.`	56	`if ((date2(1).gt.date1(1)).and.`
57	`> (diff.lt.0.).and.`	57	`> (diff.lt.0.).and.`
58	`> (yychar.eq.'20')) yychar='19'`	58	`> (yychar.eq.'20')) yychar='19'`
59		59
60	`c if ((date2(1).gt.date1(1)).and.`	60	`c if ((date2(1).gt.date1(1)).and.`
61	`c > (diff.lt.0.).and.`	61	`c > (diff.lt.0.).and.`
62	`c > (yychar.eq.'21')) yychar='20'`	62	`c > (yychar.eq.'21')) yychar='20'`
63		63
64		64
65	`if (date2(1).lt.10) then`	65	`if (date2(1).lt.10) then`
66	`write(cdate(1),'(a,i1)')'0',date2(1)`	66	`write(cdate(1),'(a,i1)')'0',date2(1)`
67	`else`	67	`else`
68	`write(cdate(1),'(i2)')date2(1)`	68	`write(cdate(1),'(i2)')date2(1)`
69	`endif`	69	`endif`
70	`if (date2(2).lt.10) then`	70	`if (date2(2).lt.10) then`
71	`write(cdate(2),'(a,i1)')'0',date2(2)`	71	`write(cdate(2),'(a,i1)')'0',date2(2)`
72	`else`	72	`else`
73	`write(cdate(2),'(i2)')date2(2)`	73	`write(cdate(2),'(i2)')date2(2)`
74	`endif`	74	`endif`
75	`if (date2(3).lt.10) then`	75	`if (date2(3).lt.10) then`
76	`write(cdate(3),'(a,i1)')'0',date2(3)`	76	`write(cdate(3),'(a,i1)')'0',date2(3)`
77	`else`	77	`else`
78	`write(cdate(3),'(i2)')date2(3)`	78	`write(cdate(3),'(i2)')date2(3)`
79	`endif`	79	`endif`
80	`if (date2(4).lt.10) then`	80	`if (date2(4).lt.10) then`
81	`write(cdate(4),'(a,i1)')'0',date2(4)`	81	`write(cdate(4),'(a,i1)')'0',date2(4)`
82	`else`	82	`else`
83	`write(cdate(4),'(i2)')date2(4)`	83	`write(cdate(4),'(i2)')date2(4)`
84	`endif`	84	`endif`
85		85
86	`cdat=trim(yychar)//cdate(1)//cdate(2)//cdate(3)//'_'//cdate(4)`	86	`cdat=trim(yychar)//cdate(1)//cdate(2)//cdate(3)//'_'//cdate(4)`
87	`write(*,'(a)')trim(cdat)`	87	`write(*,'(a)')trim(cdat)`
88		88
89	`goto 200`	89	`goto 200`
90		90
91	`120 write(,)"* error: date must be in format (YY)YYMMDD_HH *"`	91	`120 write(,)"* error: date must be in format (YY)YYMMDD_HH *"`
92		92
93	`200 continue`	93	`200 continue`
94		94
95	`end`	95	`end`
96		96
97	`subroutine checkchar(string,char,flag)`	97	`subroutine checkchar(string,char,flag)`
98	`C ======================================`	98	`C ======================================`
99		99
100	`character() string`	100	`character() string`
101	`character*(1) char`	101	`character*(1) char`
102	`integer n,flag`	102	`integer n,flag`
103		103
104	`flag=0`	104	`flag=0`
105	`do n=1,len(string)`	105	`do n=1,len(string)`
106	`if (string(n:n).eq.char) then`	106	`if (string(n:n).eq.char) then`
107	`flag=n`	107	`flag=n`
108	`return`	108	`return`
109	`endif`	109	`endif`
110	`enddo`	110	`enddo`
111	`end`	111	`end`
112		112
113	`subroutine lenchar(string,lstr)`	113	`subroutine lenchar(string,lstr)`
114	`C ===============================`	114	`C ===============================`
115		115
116	`character() string`	116	`character() string`
117	`integer n,lstr`	117	`integer n,lstr`
118		118
119	`do n=1,len(string)`	119	`do n=1,len(string)`
120	`if (string(n:n).eq."") then`	120	`if (string(n:n).eq."") then`
121	`lstr=n-1`	121	`lstr=n-1`
122	`goto 100`	122	`goto 100`
123	`endif`	123	`endif`
124	`enddo`	124	`enddo`
125	`100 continue`	125	`100 continue`
126	`end`	126	`end`

Subversion Repositories lagranto.um

(root)/tags/1.0/goodies/newtime.f – Rev 3 → 4