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

Subversion Repositories lagranto.wrf

(root)/trunk/goodies/newtime.f – Rev 2 → 11