io_grib_share.F
References to this file elsewhere.
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(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(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
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