PageRenderTime 48ms CodeModel.GetById 18ms RepoModel.GetById 0ms app.codeStats 0ms

/wrfv2_fire/external/io_grib_share/io_grib_share.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 682 lines | 423 code | 120 blank | 139 comment | 53 complexity | 827c1d688513a2cab525031814e9c009 MD5 | raw file
Possible License(s): AGPL-1.0
  1. !
  2. ! Todd Hutchinson
  3. ! WSI
  4. ! August 17, 2005
  5. !
  6. ! Routines in this file are shared by io_grib1 and io_grib2
  7. !
  8. !*****************************************************************************
  9. SUBROUTINE get_dims(MemoryOrder, Start, End, ndim, x_start, x_end, y_start, &
  10. y_end, z_start, z_end)
  11. IMPLICIT NONE
  12. CHARACTER (LEN=*) ,INTENT(IN) :: MemoryOrder
  13. INTEGER ,INTENT(OUT) :: ndim,x_start,x_end,y_start
  14. INTEGER ,INTENT(OUT) :: y_end,z_start,z_end
  15. integer ,dimension(*),intent(in) :: Start, End
  16. CHARACTER (LEN=1) :: char
  17. INTEGER :: idx
  18. CHARACTER (LEN=3) :: MemoryOrderLcl
  19. x_start = 1
  20. x_end = 1
  21. y_start = 1
  22. y_end = 1
  23. z_start = 1
  24. z_end = 1
  25. !
  26. ! Note: Need to add "char == 'S'" for boundary conditions
  27. !
  28. ndim = 0
  29. ! Fix for out-of-bounds references
  30. MemoryOrderLcl = ' '
  31. do idx=1,len_trim(MemoryOrder)
  32. MemoryOrderLcl(idx:idx) = MemoryOrder(idx:idx)
  33. enddo
  34. !
  35. ! First, do the special boundary cases. These do not seem to
  36. !
  37. if ((MemoryOrderLcl(1:3) .eq. 'XSZ') &
  38. .or. (MemoryOrderLcl(1:3) .eq. 'XEZ')) then
  39. x_start = Start(3)
  40. x_end = End(3)
  41. y_start = Start(1)
  42. y_end = End(1)
  43. z_start = Start(2)
  44. z_end = End(2)
  45. ndim = 3
  46. else if ((MemoryOrderLcl(1:3) .eq. 'YSZ') .or. &
  47. (MemoryOrderLcl(1:3) .eq. 'YEZ')) then
  48. x_start = Start(1)
  49. x_end = End(1)
  50. y_start = Start(3)
  51. y_end = End(3)
  52. z_start = Start(2)
  53. z_end = End(2)
  54. ndim = 3
  55. else if ((MemoryOrderLcl(1:2) .eq. 'YS') .or. &
  56. (MemoryOrderLcl(1:2) .eq. 'YE')) then
  57. x_start = Start(1)
  58. x_end = End(1)
  59. y_start = Start(2)
  60. y_end = End(2)
  61. ndim = 2
  62. else if ((MemoryOrderLcl(1:2) .eq. 'XS') .or. &
  63. (MemoryOrderLcl(1:2) .eq. 'XE')) then
  64. x_start = Start(2)
  65. x_end = End(2)
  66. y_start = Start(1)
  67. y_end = End(1)
  68. ndim = 2
  69. else if ((MemoryOrderLcl(1:1) .eq. 'C') .or. (MemoryOrderLcl(1:1) .eq. 'c')) then
  70. ! This is for "non-decomposed" fields
  71. x_start = Start(1)
  72. x_end = End(1)
  73. ! y_start = Start(2)
  74. ! y_end = End(2)
  75. ! z_start = Start(3)
  76. ! z_end = End(3)
  77. ndim = 3
  78. else
  79. do idx=1,len_trim(MemoryOrderLcl)
  80. char = MemoryOrderLcl(idx:idx)
  81. if ((char == 'X') .or. (char == 'x')) then
  82. x_start = Start(idx)
  83. x_end = End(idx)
  84. ndim = ndim + 1
  85. else if ((char == 'Y') .or. (char == 'y')) then
  86. y_start = Start(idx)
  87. y_end = End(idx)
  88. ndim = ndim + 1
  89. else if ((char == 'Z') .or. (char == 'z')) then
  90. z_start = Start(idx)
  91. z_end = End(idx)
  92. ndim = ndim + 1
  93. else if (char == '0') then
  94. ! Do nothing, this indicates field is a scalar.
  95. ndim = 0
  96. else
  97. call wrf_message('Invalid Dimension in get_dims: '//char)
  98. endif
  99. enddo
  100. endif
  101. END SUBROUTINE get_dims
  102. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  103. SUBROUTINE geth_idts (ndate, odate, idts)
  104. IMPLICIT NONE
  105. ! From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'),
  106. ! compute the time difference.
  107. ! on entry - ndate - the new hdate.
  108. ! odate - the old hdate.
  109. ! on exit - idts - the change in time in seconds.
  110. CHARACTER (LEN=*) , INTENT(INOUT) :: ndate, odate
  111. REAL , INTENT(OUT) :: idts
  112. ! Local Variables
  113. ! yrnew - indicates the year associated with "ndate"
  114. ! yrold - indicates the year associated with "odate"
  115. ! monew - indicates the month associated with "ndate"
  116. ! moold - indicates the month associated with "odate"
  117. ! dynew - indicates the day associated with "ndate"
  118. ! dyold - indicates the day associated with "odate"
  119. ! hrnew - indicates the hour associated with "ndate"
  120. ! hrold - indicates the hour associated with "odate"
  121. ! minew - indicates the minute associated with "ndate"
  122. ! miold - indicates the minute associated with "odate"
  123. ! scnew - indicates the second associated with "ndate"
  124. ! scold - indicates the second associated with "odate"
  125. ! i - loop counter
  126. ! mday - a list assigning the number of days in each month
  127. CHARACTER (LEN=24) :: tdate
  128. INTEGER :: olen, nlen
  129. INTEGER :: yrnew, monew, dynew, hrnew, minew, scnew
  130. INTEGER :: yrold, moold, dyold, hrold, miold, scold
  131. INTEGER :: mday(12), i, newdys, olddys
  132. LOGICAL :: npass, opass
  133. INTEGER :: isign
  134. CHARACTER (LEN=300) :: wrf_err_message
  135. INTEGER :: ndfeb
  136. IF (odate.GT.ndate) THEN
  137. isign = -1
  138. tdate=ndate
  139. ndate=odate
  140. odate=tdate
  141. ELSE
  142. isign = 1
  143. END IF
  144. ! Assign the number of days in a months
  145. mday( 1) = 31
  146. mday( 2) = 28
  147. mday( 3) = 31
  148. mday( 4) = 30
  149. mday( 5) = 31
  150. mday( 6) = 30
  151. mday( 7) = 31
  152. mday( 8) = 31
  153. mday( 9) = 30
  154. mday(10) = 31
  155. mday(11) = 30
  156. mday(12) = 31
  157. ! Break down old hdate into parts
  158. hrold = 0
  159. miold = 0
  160. scold = 0
  161. olen = LEN(odate)
  162. READ(odate(1:4), '(I4)') yrold
  163. READ(odate(6:7), '(I2)') moold
  164. READ(odate(9:10), '(I2)') dyold
  165. IF (olen.GE.13) THEN
  166. READ(odate(12:13),'(I2)') hrold
  167. IF (olen.GE.16) THEN
  168. READ(odate(15:16),'(I2)') miold
  169. IF (olen.GE.19) THEN
  170. READ(odate(18:19),'(I2)') scold
  171. END IF
  172. END IF
  173. END IF
  174. ! Break down new hdate into parts
  175. hrnew = 0
  176. minew = 0
  177. scnew = 0
  178. nlen = LEN(ndate)
  179. READ(ndate(1:4), '(I4)') yrnew
  180. READ(ndate(6:7), '(I2)') monew
  181. READ(ndate(9:10), '(I2)') dynew
  182. IF (nlen.GE.13) THEN
  183. READ(ndate(12:13),'(I2)') hrnew
  184. IF (nlen.GE.16) THEN
  185. READ(ndate(15:16),'(I2)') minew
  186. IF (nlen.GE.19) THEN
  187. READ(ndate(18:19),'(I2)') scnew
  188. END IF
  189. END IF
  190. END IF
  191. ! Check that the dates make sense.
  192. npass = .true.
  193. opass = .true.
  194. ! Check that the month of NDATE makes sense.
  195. IF ((monew.GT.12).or.(monew.LT.1)) THEN
  196. PRINT*, 'GETH_IDTS: Month of NDATE = ', monew
  197. npass = .false.
  198. END IF
  199. ! Check that the month of ODATE makes sense.
  200. IF ((moold.GT.12).or.(moold.LT.1)) THEN
  201. PRINT*, 'GETH_IDTS: Month of ODATE = ', moold
  202. opass = .false.
  203. END IF
  204. ! Check that the day of NDATE makes sense.
  205. IF (monew.ne.2) THEN
  206. ! ...... For all months but February
  207. IF ((dynew.GT.mday(monew)).or.(dynew.LT.1)) THEN
  208. PRINT*, 'GETH_IDTS: Day of NDATE = ', dynew
  209. npass = .false.
  210. END IF
  211. ELSE IF (monew.eq.2) THEN
  212. ! ...... For February
  213. IF ((dynew.GT.ndfeb(yrnew)).OR.(dynew.LT.1)) THEN
  214. PRINT*, 'GETH_IDTS: Day of NDATE = ', dynew
  215. npass = .false.
  216. END IF
  217. END IF
  218. ! Check that the day of ODATE makes sense.
  219. IF (moold.ne.2) THEN
  220. ! ...... For all months but February
  221. IF ((dyold.GT.mday(moold)).or.(dyold.LT.1)) THEN
  222. PRINT*, 'GETH_IDTS: Day of ODATE = ', dyold
  223. opass = .false.
  224. END IF
  225. ELSE IF (moold.eq.2) THEN
  226. ! ....... For February
  227. IF ((dyold.GT.ndfeb(yrold)).or.(dyold.LT.1)) THEN
  228. PRINT*, 'GETH_IDTS: Day of ODATE = ', dyold
  229. opass = .false.
  230. END IF
  231. END IF
  232. ! Check that the hour of NDATE makes sense.
  233. IF ((hrnew.GT.23).or.(hrnew.LT.0)) THEN
  234. PRINT*, 'GETH_IDTS: Hour of NDATE = ', hrnew
  235. npass = .false.
  236. END IF
  237. ! Check that the hour of ODATE makes sense.
  238. IF ((hrold.GT.23).or.(hrold.LT.0)) THEN
  239. PRINT*, 'GETH_IDTS: Hour of ODATE = ', hrold
  240. opass = .false.
  241. END IF
  242. ! Check that the minute of NDATE makes sense.
  243. IF ((minew.GT.59).or.(minew.LT.0)) THEN
  244. PRINT*, 'GETH_IDTS: Minute of NDATE = ', minew
  245. npass = .false.
  246. END IF
  247. ! Check that the minute of ODATE makes sense.
  248. IF ((miold.GT.59).or.(miold.LT.0)) THEN
  249. PRINT*, 'GETH_IDTS: Minute of ODATE = ', miold
  250. opass = .false.
  251. END IF
  252. ! Check that the second of NDATE makes sense.
  253. IF ((scnew.GT.59).or.(scnew.LT.0)) THEN
  254. PRINT*, 'GETH_IDTS: SECOND of NDATE = ', scnew
  255. npass = .false.
  256. END IF
  257. ! Check that the second of ODATE makes sense.
  258. IF ((scold.GT.59).or.(scold.LT.0)) THEN
  259. PRINT*, 'GETH_IDTS: Second of ODATE = ', scold
  260. opass = .false.
  261. END IF
  262. IF (.not. npass) THEN
  263. WRITE( wrf_err_message , * ) &
  264. 'module_date_time: geth_idts: Bad NDATE: ', ndate(1:nlen)
  265. CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
  266. END IF
  267. IF (.not. opass) THEN
  268. WRITE( wrf_err_message , * ) &
  269. 'module_date_time: geth_idts: Bad ODATE: ', odate(1:olen)
  270. CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
  271. END IF
  272. ! Date Checks are completed. Continue.
  273. ! Compute number of days from 1 January ODATE, 00:00:00 until ndate
  274. ! Compute number of hours from 1 January ODATE, 00:00:00 until ndate
  275. ! Compute number of minutes from 1 January ODATE, 00:00:00 until ndate
  276. newdys = 0
  277. DO i = yrold, yrnew - 1
  278. newdys = newdys + (365 + (ndfeb(i)-28))
  279. END DO
  280. IF (monew .GT. 1) THEN
  281. mday(2) = ndfeb(yrnew)
  282. DO i = 1, monew - 1
  283. newdys = newdys + mday(i)
  284. END DO
  285. mday(2) = 28
  286. END IF
  287. newdys = newdys + dynew-1
  288. ! Compute number of hours from 1 January ODATE, 00:00:00 until odate
  289. ! Compute number of minutes from 1 January ODATE, 00:00:00 until odate
  290. olddys = 0
  291. IF (moold .GT. 1) THEN
  292. mday(2) = ndfeb(yrold)
  293. DO i = 1, moold - 1
  294. olddys = olddys + mday(i)
  295. END DO
  296. mday(2) = 28
  297. END IF
  298. olddys = olddys + dyold-1
  299. ! Determine the time difference in seconds
  300. idts = (newdys - olddys) * 86400
  301. idts = idts + (hrnew - hrold) * 3600
  302. idts = idts + (minew - miold) * 60
  303. idts = idts + (scnew - scold)
  304. IF (isign .eq. -1) THEN
  305. tdate=ndate
  306. ndate=odate
  307. odate=tdate
  308. idts = idts * isign
  309. END IF
  310. END SUBROUTINE geth_idts
  311. !*****************************************************************************
  312. SUBROUTINE get_vert_stag(VarName,Stagger,vert_stag)
  313. character (LEN=*) :: VarName
  314. character (LEN=*) :: Stagger
  315. logical :: vert_stag
  316. if ((index(Stagger,'Z') > 0) .or. (VarName .eq. 'DNW') &
  317. .or.(VarName .eq. 'RDNW')) then
  318. vert_stag = .true.
  319. else
  320. vert_stag = .false.
  321. endif
  322. end SUBROUTINE
  323. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  324. FUNCTION ndfeb ( year ) RESULT (num_days)
  325. ! Compute the number of days in February for the given year
  326. IMPLICIT NONE
  327. INTEGER :: year
  328. INTEGER :: num_days
  329. num_days = 28 ! By default, February has 28 days ...
  330. IF (MOD(year,4).eq.0) THEN
  331. num_days = 29 ! But every four years, it has 29 days ...
  332. IF (MOD(year,100).eq.0) THEN
  333. num_days = 28 ! Except every 100 years, when it has 28 days ...
  334. IF (MOD(year,400).eq.0) THEN
  335. num_days = 29 ! Except every 400 years, when it has 29 days.
  336. END IF
  337. END IF
  338. END IF
  339. END FUNCTION ndfeb
  340. !*****************************************************************************
  341. SUBROUTINE get_dimvals(MemoryOrder,x,y,z,dims)
  342. IMPLICIT NONE
  343. CHARACTER (LEN=*) ,INTENT(IN) :: MemoryOrder
  344. INTEGER ,INTENT(IN) :: x,y,z
  345. INTEGER, DIMENSION(*),INTENT(OUT) :: dims
  346. INTEGER :: idx
  347. CHARACTER (LEN=1) :: char
  348. CHARACTER (LEN=3) :: MemoryOrderLcl
  349. dims(1) = 1
  350. dims(2) = 1
  351. dims(3) = 1
  352. ! Fix for out-of-bounds references
  353. MemoryOrderLcl = ' '
  354. do idx=1,len_trim(MemoryOrder)
  355. MemoryOrderLcl(idx:idx) = MemoryOrder(idx:idx)
  356. enddo
  357. !
  358. ! Note: Need to add "char == 'S'" for boundary conditions
  359. !
  360. if ((MemoryOrderLcl(1:3) .eq. 'XSZ') &
  361. .or. (MemoryOrderLcl(1:3) .eq. 'XEZ')) then
  362. dims(1) = y
  363. dims(2) = z
  364. dims(3) = x
  365. else if ((MemoryOrderLcl(1:3) .eq. 'YSZ') .or. &
  366. (MemoryOrderLcl(1:3) .eq. 'YEZ')) then
  367. dims(1) = x
  368. dims(2) = z
  369. dims(3) = y
  370. else if ((MemoryOrderLcl(1:2) .eq. 'YS') .or. &
  371. (MemoryOrderLcl(1:2) .eq. 'YE')) then
  372. dims(1) = x
  373. dims(2) = y
  374. dims(3) = z
  375. else if ((MemoryOrderLcl(1:2) .eq. 'XS') .or. &
  376. (MemoryOrderLcl(1:2) .eq. 'XE')) then
  377. dims(1) = y
  378. dims(2) = x
  379. dims(3) = z
  380. else if ((MemoryOrderLcl(1:1) .eq. 'C') .or. &
  381. (MemoryOrderLcl(1:1) .eq. 'c')) then
  382. ! Non-decomposed field
  383. dims(1) = x
  384. dims(2) = y
  385. dims(3) = z
  386. else
  387. do idx=1,len_trim(MemoryOrderLcl)
  388. char = MemoryOrderLcl(idx:idx)
  389. if ((char == 'X') .or. (char == 'x')) then
  390. dims(idx) = x
  391. else if ((char == 'Y') .or. (char == 'y')) then
  392. dims(idx) = y
  393. else if ((char == 'Z') .or. (char == 'z')) then
  394. dims(idx) = z
  395. else if (char == '0') then
  396. ! This is a scalar, do nothing.
  397. else
  398. call wrf_message ('Invalid Dimension in get_dimvals: '//char)
  399. endif
  400. enddo
  401. endif
  402. END SUBROUTINE get_dimvals
  403. !*****************************************************************************
  404. SUBROUTINE get_soil_layers(VarName,soil_layers)
  405. character (LEN=*) :: VarName
  406. logical :: soil_layers
  407. if ((VarName .eq. 'ZS') .or. (VarName .eq. 'DZS') &
  408. .or.(VarName .eq. 'TSLB') .or. (VarName .eq. 'SMOIS') &
  409. .or. (VarName .eq. 'SH2O') .or. (VarName .eq. 'KEEPFR3DFLAG') &
  410. .or. (VarName .eq. 'SMFR3D')) then
  411. soil_layers = .true.
  412. else
  413. soil_layers = .false.
  414. endif
  415. end SUBROUTINE
  416. !*****************************************************************************
  417. SUBROUTINE Transpose_grib(MemoryOrder, di, FieldType, Field, &
  418. Start1, End1, Start2, End2, Start3, End3, data, zidx, numrows, numcols)
  419. IMPLICIT NONE
  420. #include "wrf_io_flags.h"
  421. CHARACTER (LEN=*),INTENT(IN) :: MemoryOrder
  422. INTEGER ,INTENT(IN) :: Start1,End1,Start2,End2,Start3,End3
  423. INTEGER ,INTENT(IN) :: di
  424. integer ,intent(inout) :: &
  425. Field(di,Start1:End1,Start2:End2,Start3:End3)
  426. INTEGER ,intent(in) :: FieldType
  427. real ,intent(in) :: data(*)
  428. INTEGER ,INTENT(IN) :: zidx, numcols, numrows
  429. INTEGER, DIMENSION(3) :: dims
  430. INTEGER :: col, row
  431. LOGICAL :: logicaltype
  432. CHARACTER (LEN=1000) :: msg
  433. if ((FieldType == WRF_REAL) .or. (FieldType == WRF_DOUBLE)) then
  434. do col=1,numcols
  435. do row=1,numrows
  436. call get_dimvals(MemoryOrder,col,row,zidx,dims)
  437. Field(1:di,dims(1),dims(2),dims(3)) = &
  438. TRANSFER(data((row-1)*numcols+col),Field,1)
  439. enddo
  440. enddo
  441. else if (FieldType == WRF_INTEGER) then
  442. do col=1,numcols
  443. do row=1,numrows
  444. call get_dimvals(MemoryOrder,col,row,zidx,dims)
  445. Field(1:di,dims(1),dims(2),dims(3)) = data((row-1)*numcols+col)
  446. enddo
  447. enddo
  448. else
  449. write (msg,*)'Reading of type ',FieldType,'from grib data not supported'
  450. call wrf_message(msg)
  451. endif
  452. !
  453. ! This following seciton is for the logical type. This caused some problems
  454. ! on certain platforms.
  455. !
  456. ! else if (FieldType == WRF_LOGICAL) then
  457. ! do col=1,numcols
  458. ! do row=1,numrows
  459. ! call get_dimvals(MemoryOrder,col,row,zidx,dims)
  460. ! Field(1:di,dims(1),dims(2),dims(3)) = &
  461. ! TRANSFER(data((row-1)*numcols+col),logicaltype,1)
  462. ! enddo
  463. ! enddo
  464. end SUBROUTINE
  465. !*****************************************************************************
  466. SUBROUTINE Transpose1D_grib(MemoryOrder, di, FieldType, Field, &
  467. Start1, End1, Start2, End2, Start3, End3, data, nelems)
  468. IMPLICIT NONE
  469. #include "wrf_io_flags.h"
  470. CHARACTER (LEN=*),INTENT(IN) :: MemoryOrder
  471. INTEGER ,INTENT(IN) :: Start1,End1,Start2,End2,Start3,End3
  472. INTEGER ,INTENT(IN) :: di
  473. integer ,intent(inout) :: &
  474. Field(di,Start1:End1,Start2:End2,Start3:End3)
  475. INTEGER ,intent(in) :: FieldType
  476. real ,intent(in) :: data(*)
  477. LOGICAL :: logicaltype
  478. CHARACTER (LEN=1000) :: msg
  479. integer :: elemnum,nelems
  480. if ((FieldType == WRF_REAL) .or. (FieldType == WRF_DOUBLE)) then
  481. do elemnum=1,nelems
  482. Field(1:di,elemnum,1,1) = TRANSFER(data(elemnum),Field,1)
  483. enddo
  484. else if (FieldType == WRF_INTEGER) then
  485. do elemnum=1,nelems
  486. Field(1:di,elemnum,1,1) = TRANSFER(data(elemnum),Field,1)
  487. enddo
  488. else
  489. write (msg,*)'Reading of type ',FieldType,'from grib1 data not supported'
  490. call wrf_message(msg)
  491. endif
  492. !
  493. ! This following seciton is for the logical type. This caused some problems
  494. ! on certain platforms.
  495. !
  496. ! else if (FieldType == WRF_LOGICAL) then
  497. ! do col=1,numcols
  498. ! do row=1,numrows
  499. ! call get_dimvals(MemoryOrder,col,row,zidx,dims)
  500. ! Field(1:di,dims(1),dims(2),dims(3)) = &
  501. ! TRANSFER(data((row-1)*numcols+col),logicaltype,1)
  502. ! enddo
  503. ! enddo
  504. end SUBROUTINE Transpose1D_grib
  505. !*****************************************************************************
  506. !
  507. ! Takes a starting date (startTime) in WRF format (yyyy-mm-dd_hh:mm:ss),
  508. ! adds an input number of seconds to the time, and outputs a new date
  509. ! (endTime) in WRF format.
  510. !
  511. !*****************************************************************************
  512. subroutine advance_wrf_time(startTime, addsecs, endTime)
  513. implicit none
  514. integer , intent(in) :: addsecs
  515. character (len=*), intent(in) :: startTime
  516. character (len=*), intent(out) :: endTime
  517. integer :: syear,smonth,sday,shour,smin,ssec
  518. integer :: days_in_month(12)
  519. read(startTime,'(I4.4,1X,I2.2,1X,I2.2,1X,I2.2,1X,I2.2,1X,I2.2)') &
  520. syear,smonth,sday,shour,smin,ssec
  521. ssec = ssec + addsecs
  522. do while (ssec .ge. 60)
  523. smin = smin + 1
  524. ssec = ssec - 60
  525. enddo
  526. do while (smin .ge. 60)
  527. shour = shour + 1
  528. smin = smin - 60
  529. enddo
  530. do while (shour .ge. 24)
  531. sday = sday + 1
  532. shour = shour - 24
  533. enddo
  534. days_in_month(1) = 31
  535. if (((mod(syear,4) .eq. 0) .and. (mod(syear,100) .ne. 0)) &
  536. .or. (mod(syear,400) .eq. 0)) then
  537. days_in_month(2) = 29
  538. else
  539. days_in_month(2) = 28
  540. endif
  541. days_in_month(3) = 31
  542. days_in_month(4) = 30
  543. days_in_month(5) = 31
  544. days_in_month(6) = 30
  545. days_in_month(7) = 31
  546. days_in_month(8) = 31
  547. days_in_month(9) = 30
  548. days_in_month(10) = 31
  549. days_in_month(11) = 30
  550. days_in_month(12) = 31
  551. do while (sday .gt. days_in_month(smonth))
  552. sday = sday - days_in_month(smonth)
  553. smonth = smonth + 1
  554. if (smonth .gt. 12) then
  555. smonth = 1
  556. syear = syear + 1
  557. endif
  558. enddo
  559. write(endTime,'(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') &
  560. syear,'-',smonth,'-',sday,'_',shour,':',smin,':',ssec
  561. return
  562. end subroutine