external/io_grib_share/io_grib_share.F

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