My Project
mod_force.f90
Go to the documentation of this file.
1 
2 
3 
4 
5 
6 
7 
8 
9 
10 
11 
12 !/===========================================================================/
13 ! Copyright (c) 2007, The University of Massachusetts Dartmouth
14 ! Produced at the School of Marine Science & Technology
15 ! Marine Ecosystem Dynamics Modeling group
16 ! All rights reserved.
17 !
18 ! FVCOM has been developed by the joint UMASSD-WHOI research team. For
19 ! details of authorship and attribution of credit please see the FVCOM
20 ! technical manual or contact the MEDM group.
21 !
22 !
23 ! This file is part of FVCOM. For details, see http://fvcom.smast.umassd.edu
24 ! The full copyright notice is contained in the file COPYRIGHT located in the
25 ! root directory of the FVCOM code. This original header must be maintained
26 ! in all distributed versions.
27 !
28 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
29 ! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
30 ! THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
31 ! PURPOSE ARE DISCLAIMED.
32 !
33 !/---------------------------------------------------------------------------/
34 ! CVS VERSION INFORMATION
35 ! $Id$
36 ! $Name$
37 ! $Revision$
38 !/===========================================================================/
39 
40 MODULE mod_force
41  USE all_vars
42  USE mod_interp
43  USE bcs
44  USE mod_time
45  USE mod_nctools
46  USE mod_ncll
47  USE mod_utils
48  USE mod_spherical
49  USE mod_par
50  USE mod_input
51 
52  IMPLICIT NONE
53 
54  SAVE
55  PRIVATE
56 
57  ! COMMON FILE TYPE SHARED BY SEVERAL TYPES OF FORCING
58 ! CHARACTER(LEN=80),PUBLIC, PARAMETER :: WRF2FVCOM_SOURCE = &
59 ! & "wrf2fvcom version 0.14 (2007-07-19) (Bulk method: COARE 2.6Z)"
60 
61  CHARACTER(LEN=80),PUBLIC, PARAMETER :: wrf2fvcom_source = &
62  & "wrf2fvcom version"
63 
64  CHARACTER(LEN=80),PUBLIC, PARAMETER :: fvcom_grid_source = &
65  & "fvcom grid (unstructured) surface forcing"
66 
67  CHARACTER(LEN=80),PUBLIC, PARAMETER :: fvcom_cap_grid_source = &
68  & "FVCOM grid (unstructured) surface forcing"
69 
70  CHARACTER(LEN=80),PUBLIC, PARAMETER :: wrf_grid_source = &
71  & "wrf grid (structured) surface forcing"
72 
73  CHARACTER(LEN=80),PUBLIC, PARAMETER :: surf_forcing_pt_source = &
74  & "single-point time-dependent surface forcing"
75 
76 
77  ! TIDAL FORCING VARIABLES FOR UPDATE AND SETUP
78  INTEGER, PUBLIC :: tide_forcing_type
79  INTEGER, PARAMETER, PUBLIC :: tide_forcing_spectral = 1
80  INTEGER, PARAMETER, PUBLIC :: tide_forcing_timeseries = 2
81  TYPE(ncfile), POINTER :: tide_file
82  TYPE(ncvar), POINTER :: tide_elv_n, tide_elv_p
83  CHARACTER(LEN=Char_max_attlen), PUBLIC,ALLOCATABLE :: tide_forcing_comments(:)
84 
85 
86  ! RIVER FORCING VARIABLES FOR UPDATE AND SETUP
87  ! NOTE RIVERS ARE A PAIN - EACH PROCESSOR HAS TO FETCH ITS OWN DATA!
88  CHARACTER(LEN=Char_max_attlen), PUBLIC,ALLOCATABLE :: river_forcing_comments(:)
89  TYPE a_river_file
90  TYPE(ncfile), POINTER :: ncf
91  INTEGER rivers_in_file
92 
93  TYPE(time) :: river_period
94  INTEGER, ALLOCATABLE :: riv_file2loc(:)
95  ! USAGE : DO I = 1, RIVERS_IN_FILE
96  ! J = RIV_FILE2LOC(I)
97  ! IF (J/=0) QDIS(J) = FILE_DIS(I)
98  TYPE(ncvar), POINTER :: flux_n, flux_p
99  TYPE(ncvar), POINTER :: temp_n, temp_p
100  TYPE(ncvar), POINTER :: salt_n, salt_p
101  ! ADD MORE HERE!
102  END TYPE a_river_file
103  TYPE(a_river_file), ALLOCATABLE :: river_forcing(:)
104 
105 
106 
107  ! =================================================================
108  ! GROUND WATER FORCING VARIABLES FOR UPDATE AND SETUP
109  TYPE(ncfile), POINTER :: gwater_file
110 
111  INTEGER :: gwater_forcing_type
112  INTEGER,PARAMETER :: gwater_is_xxx = 0
113  INTEGER,PARAMETER :: gwater_is_fvcomgrid = 1
114 
115  INTEGER :: gwater_units
116  INTEGER, PARAMETER :: gwater_m3s_1=1
117  INTEGER, PARAMETER :: gwater_ms_1=2
118 
119  TYPE(time) :: gwater_period
120 
121  CHARACTER(LEN=Char_max_attlen), PUBLIC, ALLOCATABLE :: gwater_forcing_comments(:)
122  TYPE(interp_weights),POINTER :: gwater_intp_n
123  TYPE(interp_weights),POINTER :: gwater_intp_c
124  TYPE(ncvar), POINTER :: gwater_flux_n, gwater_flux_p ! Discharge
125  TYPE(ncvar), POINTER :: gwater_temp_n, gwater_temp_p ! Temperature
126  TYPE(ncvar), POINTER :: gwater_salt_n, gwater_salt_p ! Salinity
127 
128  ! =================================================================
129  ! OPEN BOUNDARY CONDITION SALINITY VARIABLES FOR UPDATE AND SETUP
130  TYPE(ncfile), POINTER :: obc_s_file
131  CHARACTER(LEN=Char_max_attlen), PUBLIC :: obc_s_comments
132  INTEGER :: obc_s_type
133  INTEGER,PARAMETER :: obc_s_sigma = 1
134  TYPE(ncvar), POINTER :: obc_s_n, obc_s_p
135 
136  ! =================================================================
137  ! OPEN BOUNDARY CONDITION TEMPERATURE VARIABLES FOR UPDATE AND SETUP
138  TYPE(ncfile), POINTER :: obc_t_file
139  CHARACTER(LEN=Char_max_attlen), PUBLIC :: obc_t_comments
140  INTEGER :: obc_t_type
141  INTEGER,PARAMETER :: obc_t_sigma = 1
142  TYPE(ncvar), POINTER :: obc_t_n, obc_t_p
143 
144  ! =================================================================
145 
146  ! =================================================================
147  ! =================================================================
148 
149  ! =================================================================
150  ! SURFACE HEAT FORCING FILE DATA
151  INTEGER :: heat_forcing_type
152 
153  INTEGER,PARAMETER :: heat_is_wrfgrid = 0
154  INTEGER,PARAMETER :: heat_is_fvcomgrid = 1
155 
156  TYPE(time) :: heat_period
157 
158  TYPE(ncfile), POINTER :: heat_file
159  CHARACTER(LEN=Char_max_attlen), PUBLIC, ALLOCATABLE :: heat_forcing_comments(:)
160  CHARACTER(LEN=Char_max_attlen), PUBLIC, ALLOCATABLE :: heat_calculate_comments(:)
161  CHARACTER(LEN=Char_max_attlen), PUBLIC, ALLOCATABLE :: heat_solar_comments(:)
162  TYPE(interp_weights),POINTER :: heat_intp_n
163  TYPE(interp_weights),POINTER :: heat_intp_c
164  TYPE(ncvar), POINTER :: heat_swv_n, heat_swv_p ! SHORT WAVE
165  ! TYPE(NCVAR), POINTER :: HEAT_LWV_N, HEAT_LWV_P ! LONG WAVE
166  ! TYPE(NCVAR), POINTER :: HEAT_LTNT_N, HEAT_LTNT_P ! LATENT
167  ! TYPE(NCVAR), POINTER :: HEAT_SNS_N, HEAT_SNS_P ! SENSIBLE
168  TYPE(ncvar), POINTER :: heat_net_n, heat_net_p ! NET HEAT FLUX
169  ! =================================================================
170  ! SURFACE WIND STRESS FILE DATA
171  INTEGER :: winds_forcing_type
172 
173  INTEGER, PARAMETER :: winds_are_wrfgrid = 0
174  INTEGER, PARAMETER :: winds_are_fvcomgrid = 1
175  INTEGER, PARAMETER :: winds_are_pt_source = 2
176 
177 
178  TYPE(time) :: winds_period
179 
180  TYPE(ncfile), POINTER :: winds_file
181  CHARACTER(LEN=Char_max_attlen), PUBLIC, ALLOCATABLE :: winds_forcing_comments(:)
182  TYPE(interp_weights),POINTER :: winds_intp_n
183  TYPE(interp_weights),POINTER :: winds_intp_c
184  TYPE(ncvar), POINTER :: winds_strx_n, winds_strx_p ! STRESS IN THE X DIRECTION
185  TYPE(ncvar), POINTER :: winds_stry_n, winds_stry_p ! STRESS IN THE Y DIRECTION
186 
187 
188 
189 
190 
191 
192 !Jadon
193  ! =================================================================
194  ! SURFACE WAVE STRESS FILE DATA
195  INTEGER :: waves_forcing_type
196 
197  INTEGER, PARAMETER :: waves_are_wrfgrid = 0
198  INTEGER, PARAMETER :: waves_are_fvcomgrid = 1
199 
200  TYPE(time) :: waves_period
201 
202  TYPE(ncfile), POINTER :: waves_file
203  CHARACTER(LEN=Char_max_attlen), PUBLIC, ALLOCATABLE :: waves_forcing_comments(:)
204  TYPE(interp_weights),POINTER :: waves_intp_n
205  TYPE(interp_weights),POINTER :: waves_intp_c
206  TYPE(ncvar), POINTER :: waves_height_n, waves_height_p ! WAVE HEIGHT
207  TYPE(ncvar), POINTER :: waves_length_n, waves_length_p ! WAVE LENGTH
208  TYPE(ncvar), POINTER :: waves_direction_n, waves_direction_p ! WAVE DIRECTION
209  TYPE(ncvar), POINTER :: waves_period_n, waves_period_p ! WAVE PERIOD
210  TYPE(ncvar), POINTER :: waves_per_bot_n, waves_per_bot_p ! BOTTOM PERIOD
211  TYPE(ncvar), POINTER :: waves_ub_bot_n, waves_ub_bot_p ! BOTTOM VELOCITY
212  ! =================================================================
213  ! SURFACE PRECIPTATION DATA
214  INTEGER :: precip_forcing_type
215 
216  INTEGER,PARAMETER :: precip_is_wrfgrid = 0
217  INTEGER,PARAMETER :: precip_is_fvcomgrid = 1
218 
219  TYPE(time) :: precip_period
220 
221  TYPE(ncfile), POINTER :: precip_file
222  CHARACTER(LEN=Char_max_attlen), PUBLIC, ALLOCATABLE:: precip_forcing_comments(:)
223  TYPE(interp_weights),POINTER :: precip_intp_n
224  TYPE(interp_weights),POINTER :: precip_intp_c
225  TYPE(ncvar), POINTER :: precip_pre_n, precip_pre_p ! PRECIPITATION
226  TYPE(ncvar), POINTER :: precip_evp_n, precip_evp_p ! EVAPORATION
227 
228  ! =================================================================
229  ! AIR PRESSURE FILE DATA
230  INTEGER :: airpressure_forcing_type
231 
232  INTEGER, PARAMETER :: airpressure_is_wrfgrid = 0
233  INTEGER, PARAMETER :: airpressure_is_fvcomgrid = 1
234 
235  TYPE(time) :: airpressure_period
236 
237  TYPE(ncfile), POINTER :: airpressure_p_file
238  CHARACTER(LEN=Char_max_attlen), PUBLIC, ALLOCATABLE :: airpressure_forcing_comments(:)
239  TYPE(interp_weights),POINTER :: airpressure_intp_n
240  TYPE(interp_weights),POINTER :: airpressure_intp_c
241  TYPE(ncvar), POINTER :: air_pressure_n, air_pressure_p
242 
243 
244  ! =================================================================
245  ! ICE MODEL DATA
246  INTEGER :: ice_forcing_type
247 
248  INTEGER,PARAMETER :: ice_is_wrfgrid = 0
249  INTEGER,PARAMETER :: ice_is_fvcomgrid = 1
250 
251  TYPE(time) :: ice_period
252 
253  TYPE(ncfile), POINTER :: ice_file
254  CHARACTER(LEN=Char_max_attlen), PUBLIC, ALLOCATABLE:: ice_forcing_comments(:)
255  TYPE(interp_weights),POINTER :: ice_intp_n
256  TYPE(interp_weights),POINTER :: ice_intp_c
257  TYPE(ncvar), POINTER :: ice_swv_n, ice_swv_p ! SHORT WAVE
258  TYPE(ncvar), POINTER :: ice_sat_n, ice_sat_p ! SEA LEVEL AIR TEMPERATURE
259  TYPE(ncvar), POINTER :: ice_spq_n, ice_spq_p ! SPECFIC HUMIDITY
260  TYPE(ncvar), POINTER :: ice_cld_n, ice_cld_p ! CLOUD COVER
261 
262  ! =================================================================
263  ! ICING MODEL DATA
264  INTEGER :: icing_forcing_type
265 
266  INTEGER,PARAMETER :: icing_is_wrfgrid = 0
267  INTEGER,PARAMETER :: icing_is_fvcomgrid = 1
268 
269  TYPE(time) :: icing_period
270 
271  TYPE(ncfile), POINTER :: icing_file
272  CHARACTER(LEN=Char_max_attlen), PUBLIC, ALLOCATABLE:: icing_forcing_comments(:)
273  TYPE(interp_weights),POINTER :: icing_intp_n
274  TYPE(interp_weights),POINTER :: icing_intp_c
275  TYPE(ncvar), POINTER :: icing_sat_n, icing_sat_p ! SEA LEVEL AIR PRESSURE
276  TYPE(ncvar), POINTER :: icing_wspx_n, icing_wspx_p ! SEA LEVEL AIR TEMPERATURE
277  TYPE(ncvar), POINTER :: icing_wspy_n, icing_wspy_p ! SPECFIC HUMIDITY
278 
279 
280  PUBLIC :: setup_forcing
281  PUBLIC :: update_groundwater
282  PUBLIC :: update_heat
283  PUBLIC :: update_wind
284  PUBLIC :: update_wave
285 
286 
287 
288 
289  PUBLIC :: update_precipitation
290  PUBLIC :: update_airpressure
291  PUBLIC :: update_tide
292  PUBLIC :: update_rivers
293  PUBLIC :: update_obc_temp
294  PUBLIC :: update_obc_salt
295  PUBLIC :: update_ice
296  PUBLIC :: update_icing
297 
298 CONTAINS
299 
300  SUBROUTINE setup_forcing
301  IMPLICIT NONE
302  IF(dbg_set(dbg_sbr)) write(ipt,*) "START SETUP_FORCING"
303 
304  IF(dbg_set(dbg_log)) THEN
305  WRITE(ipt,* )'!'
306  WRITE(ipt,* )'! SETTING UP PRESCRIBED BOUNDARY CONDITIONS '
307  WRITE(ipt,* )'!'
308  END IF
309 
310 
311  ! NULLIFY EVERYTHING
312  NULLIFY(tide_file, tide_elv_n, tide_elv_p)
313 
314  NULLIFY(gwater_file)
315 
316  NULLIFY(heat_file,heat_intp_n, heat_intp_c, heat_swv_p,&
317  & heat_swv_n)
318 
319  NULLIFY(winds_file,winds_intp_n,winds_intp_c, winds_strx_n,&
320  & winds_strx_p, winds_stry_n, winds_stry_p)
321 
322  NULLIFY(airpressure_p_file,airpressure_intp_n,airpressure_intp_c, air_pressure_n,&
323  & air_pressure_p)
324 
325  NULLIFY(waves_file,waves_intp_n,waves_intp_c, &
326  & waves_height_n, waves_height_p, &
327  & waves_length_n, waves_length_p, &
328  & waves_direction_n, waves_direction_p, &
329  & waves_period_n, waves_period_p, &
330  & waves_per_bot_n, waves_per_bot_p, &
331  & waves_ub_bot_n, waves_ub_bot_p )
332 
333 
334 
335 
336 
337  CALL tidal_elevation
338  CALL obc_temperature
339  CALL obc_salinity
340  CALL river_discharge
341  CALL surface_heating
342  CALL surface_windstress
343  CALL surface_precipitation
344  CALL surface_airpressure
345 
346 
347 
348 
349  CALL ground_water
350 
351  ! ORDER IS IMPORTANT! ICE AND ICING MAY USE THE SAME POINTERS TO
352  ! REFERENCE FILE! THEY MUST BE SET UP LAST.
353  CALL icing_forcing
354 
355  CALL ice_model_forcing
356 
357  IF(dbg_set(dbg_sbr)) write(ipt,*) "END SETUP_FORCING"
358  END SUBROUTINE setup_forcing
359  !================================================================
360  !================================================================
361  SUBROUTINE ground_water
362  IMPLICIT NONE
363  ! SOME NC POINTERS
364  TYPE(ncatt), POINTER :: att, att_date
365  TYPE(ncdim), POINTER :: dim
366  TYPE(ncvar), POINTER :: var
367  LOGICAL :: found
368 
369  REAL(sp), POINTER :: storage_arr(:,:), storage_vec(:)
370  CHARACTER(len=60) :: tempstrng, flowstrng, saltstrng
371  TYPE(time) :: timetest
372 
373  INTEGER :: lats, lons, i, ntimes
374 
375  INTEGER :: status
376 
377  IF(dbg_set(dbg_sbr)) write(ipt,*) "START GROUND_WATER"
378 
379  IF (.NOT. groundwater_on ) THEN
380  IF(dbg_set(dbg_log)) write(ipt,*) "! GROUND WATER FORCING IS OFF!"
381  ALLOCATE(gwater_forcing_comments(1))
382  gwater_forcing_comments="GROUND WATER FORCING IS OFF!"
383  RETURN
384  END IF
385 
386 
387 
388  ! DETERMINE HOW TO LOAD THE DATA
389  SELECT CASE(groundwater_kind)
390  CASE (cnstnt)
391 
392  write(flowstrng,'(f8.4)') groundwater_flow
393  write(tempstrng,'(f8.4)') groundwater_temp
394  write(saltstrng,'(f8.4)') groundwater_salt
395 
396  IF(dbg_set(dbg_log)) THEN
397  WRITE(ipt,*)"! SETTING UP CONSTANT GROUNDWATER FORCING: "
398  WRITE(ipt,*)" Flow Rate: "//trim(flowstrng)
399  WRITE(ipt,*)" Temp: "//trim(tempstrng)
400  WRITE(ipt,*)" Salt: "//trim(saltstrng)
401  END IF
402 
403  ALLOCATE(gwater_forcing_comments(4))
404  gwater_forcing_comments(1) = "Using constant groundwater forcing from run file:"
405  gwater_forcing_comments(2) = "Flow Rate:"//trim(flowstrng)
406  IF(groundwater_temp_on) THEN
407  gwater_forcing_comments(3) = "Temperature (specified):"//trim(tempstrng)
408  ELSE
409  gwater_forcing_comments(3) = "Temperature is calculated"
410  END IF
411 
412  IF(groundwater_salt_on) THEN
413  gwater_forcing_comments(4) = "Salinity (specified):"//trim(saltstrng)
414  ELSE
415  gwater_forcing_comments(4) = "Salinity is calculated"
416  END IF
417  RETURN
418 
419  CASE(sttc)
420 
421  CALL fatal_error("STATIC GROUNDWATER Not Set Up Yet")
422 
423  CASE(tmdpndnt)
424 
425  CALL fatal_error("TIME DEPENDENT GROUNDWATER Not Set Up Yet")
426 
427  CASE(prdc)
428 
429  gwater_file => find_file(filehead,trim(groundwater_file),found)
430  IF(.not. found) CALL fatal_error &
431  & ("COULD NOT FIND GROUNDWATER FILE OBJECT",&
432  & "FILE NAME: "//trim(groundwater_file))
433 
434  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
435  att => find_att(gwater_file,"source",found)
436  IF(.not. found) att => find_att(gwater_file,"Source",found)
437  IF(.not. found) CALL fatal_error &
438  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
439  & "FILE NAME: "//trim(groundwater_file),&
440  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
441 
442  IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
443  & trim(fvcom_grid_source)) THEN
444  gwater_forcing_type = gwater_is_fvcomgrid
445 
446  ELSEIF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
447  & trim(fvcom_cap_grid_source)) THEN
448  gwater_forcing_type = gwater_is_fvcomgrid
449 
450  ELSE
451  CALL print_file(gwater_file)
452  CALL fatal_error("CAN NOT RECOGNIZE GROUNDWATER FILE!",&
453  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
454  END IF
455  ! GOT GRID TYPE
456 
457  ALLOCATE(gwater_forcing_comments(5))
458  gwater_forcing_comments(1) = "FVCOM periodic GroundWater forcing:"
459  gwater_forcing_comments(2) = "FILE NAME:"//trim(groundwater_file)
460  gwater_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
461  IF(groundwater_temp_on) THEN
462  gwater_forcing_comments(4) = "Temperature is specified"
463  ELSE
464  gwater_forcing_comments(4) = "Temperature is calculated"
465  END IF
466 
467  IF(groundwater_salt_on) THEN
468  gwater_forcing_comments(5) = "Salinity is specified"
469  ELSE
470  gwater_forcing_comments(5) = "Salinity is calculated"
471  END IF
472 
473  ! GET THE FILES LENGTH OF TIME AND SAVE FOR PERIODIC FORCING
474 
475  ! LOOK FOR THE DIMENSIONS
476  dim => find_unlimited(gwater_file,found)
477  IF(.not. found) CALL fatal_error &
478  & ("IN GROUNDWATER FILE OBJECT",&
479  & "FILE NAME: "//trim(groundwater_file),&
480  &"COULD NOT FIND THE UNLIMITED DIMENSION")
481 
482  ntimes = dim%DIM
483 
484  gwater_period = get_file_time(gwater_file,ntimes)
485 
486 
487  IF (zerotime /= get_file_time(gwater_file,1)) THEN
488 
489  CALL print_real_time(get_file_time(gwater_file,1),ipt,"FIRST FILE TIME",timezone)
490  CALL print_real_time(get_file_time(gwater_file,ntimes),ipt,"LAST FILE TIME",timezone)
491 
492  CALL fatal_error&
493  &("TO USE PERIODIC FORCING THE FILE TIME MUST COUNT FROM ZERO",&
494  & "THE DIFFERENCE BETWEEN THE CURRENT MODEL TIME AND THE START TIME,",&
495  & "MODULO THE FORCING PERIOD, DETERMINES THE CURRENT FORCING")
496  END IF
497 
498  IF(dbg_set(dbg_log)) THEN
499  WRITE(ipt,*) "! USING PERIODIC GroundWater FORCING:"
500  CALL print_time(gwater_period,ipt,"PERIOD")
501  END IF
502 
503  CASE(vrbl)
504 
505  gwater_file => find_file(filehead,trim(groundwater_file),found)
506  IF(.not. found) CALL fatal_error &
507  & ("COULD NOT FIND GROUNDWATER FILE OBJECT",&
508  & "FILE NAME: "//trim(groundwater_file))
509 
510  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
511  att => find_att(gwater_file,"source",found)
512  IF(.not. found) att => find_att(gwater_file,"Source",found)
513  IF(.not. found) CALL fatal_error &
514  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
515  & "FILE NAME: "//trim(groundwater_file),&
516  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
517 
518  IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
519  & trim(fvcom_cap_grid_source)) THEN
520  gwater_forcing_type = gwater_is_fvcomgrid
521 
522  ELSEIF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
523  & trim(fvcom_grid_source)) THEN
524  gwater_forcing_type = gwater_is_fvcomgrid
525 
526  ELSE
527  CALL print_file(gwater_file)
528  CALL fatal_error("CAN NOT RECOGNIZE GROUNDWATER FILE!",&
529  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
530  END IF
531  ! GOT GRID TYPE
532 
533  ALLOCATE(gwater_forcing_comments(5))
534  gwater_forcing_comments(1) = "FVCOM variable GroundWater forcing:"
535  gwater_forcing_comments(2) = "FILE NAME:"//trim(groundwater_file)
536  gwater_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
537 
538  IF(groundwater_temp_on) THEN
539  gwater_forcing_comments(4) = "Temperature is specified"
540  ELSE
541  gwater_forcing_comments(4) = "Temperature is calculated"
542  END IF
543 
544  IF(groundwater_salt_on) THEN
545  gwater_forcing_comments(5) = "Salinity is specified"
546  ELSE
547  gwater_forcing_comments(5) = "Salinity is calculated"
548  END IF
549 
550  ! GET THE FILES LENGTH OF TIME AND SAVE FOR PERIODIC FORCING
551 
552  ! LOOK FOR THE DIMENSIONS
553  dim => find_unlimited(gwater_file,found)
554  IF(.not. found) CALL fatal_error &
555  & ("IN GROUNDWATER FILE OBJECT",&
556  & "FILE NAME: "//trim(groundwater_file),&
557  &"COULD NOT FIND THE UNLIMITED DIMENSION")
558 
559  ntimes = dim%DIM
560 
561  ! CHECK THE FILE TIME AND COMPARE WITH MODEL RUN TIME
562  timetest = get_file_time(gwater_file,1)
563  IF(timetest > starttime) CALL fatal_error &
564  & ("IN THE GROUNDWATER FILE OBJECT",&
565  & "FILE NAME: "//trim(groundwater_file),&
566  &"THE MODEL RUN STARTS BEFORE THE FORCING TIME SERIES")
567 
568  timetest = get_file_time(gwater_file,ntimes)
569  IF(timetest < endtime) CALL fatal_error &
570  & ("IN THE GROUNDWATER FILE OBJECT",&
571  & "FILE NAME: "//trim(groundwater_file),&
572  &"THE MODEL RUN ENDS AFTER THE FORCING TIME SERIES")
573 
574  CASE DEFAULT
575  CALL fatal_error("GROUND_WATER: UNKNOWN GROUND WATER KIND?")
576 
577  END SELECT
578 
579 
580  !==================================================================
581  SELECT CASE(gwater_forcing_type)
582  !==================================================================
583  CASE(gwater_is_fvcomgrid)
584  !==================================================================
585 
586  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
587  & "! SETTING UP GROUND WATER FORCING FROM A 'fvcom grid' FILE"
588 
589  ! LOOK FOR THE DIMENSIONS
590  dim => find_dim(gwater_file,'node',found)
591  IF(.not. found) CALL fatal_error &
592  & ("IN THE GROUND WATER FILE OBJECT",&
593  & "FILE NAME: "//trim(groundwater_file),&
594  & "COULD NOT FIND DIMENSION 'node'")
595 
596  if (mgl /= dim%dim) CALL fatal_error&
597  &("GROUNDWATER: the number of nodes in the file does not match the fvcom grid?")
598 
599 
600  dim => find_dim(gwater_file,'nele',found)
601  IF(.not. found) CALL fatal_error &
602  & ("IN THE GROUND WATER FILE OBJECT",&
603  & "FILE NAME: "//trim(groundwater_file),&
604  & "COULD NOT FIND DIMENSION 'nele'")
605 
606  if (ngl /= dim%dim) CALL fatal_error&
607  &("GROUNDWATER: the number of elements in the file does not match the fvcom grid?")
608 
609  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
610 
611  ! GROUND WATER FLUX DATA
612  var => find_var(gwater_file,"groundwater_flux",found)
613  IF(.not. found) CALL fatal_error &
614  & ("IN THE GROUNDWATER FILE OBJECT",&
615  & "FILE NAME: "//trim(groundwater_file),&
616  & "COULD NOT FIND VARIABLE 'groundwater_flux'")
617 
618  att => find_att(var,"units",found)
619  IF(.not. found) CALL fatal_error &
620  & ("IN THE GROUNDWATER FILE OBJECT",&
621  & "FILE NAME: "//trim(groundwater_file),&
622  & "COULD NOT FIND THE UNITS FOR THE VARIABLE 'groundwater_flux'")
623 
624  IF (att%CHR(1)(1:len_trim("m3 s-1")) == "m3 s-1") THEN
625  gwater_units = gwater_m3s_1
626  ELSEIF (att%CHR(1)(1:len_trim("m s-1")) == "m s-1") THEN
627  gwater_units = gwater_ms_1
628  ELSE
629  CALL fatal_error &
630  & ("IN THE GROUNDWATER FILE OBJECT",&
631  & "FILE NAME: "//trim(groundwater_file),&
632  & "UNKNOWN UNITS FOR THE VARIABLE 'groundwater_flux'")
633  END IF
634 
635  ! MAKE SPACE FOR THE DATA FROM THE FILE
636  gwater_flux_n => reference_var(var)
637  ALLOCATE(storage_vec(0:mt), stat = status)
638  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN GROUNDWATER")
639  CALL nc_connect_pvar(gwater_flux_n,storage_vec)
640  NULLIFY(storage_vec)
641 
642 
643  ! MAKE SPACE FOR THE DATA FROM THE FILE
644  gwater_flux_p => reference_var(var)
645  ALLOCATE(storage_vec(0:mt), stat = status)
646  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN GROUNDWATER")
647  CALL nc_connect_pvar(gwater_flux_p,storage_vec)
648  NULLIFY(storage_vec)
649 
650  ! GROUNDWATER INFLOW TEMPERATURE
651  IF(groundwater_temp_on)THEN
652  var => find_var(gwater_file,"groundwater_temp",found)
653  IF(.not. found) CALL fatal_error &
654  & ("IN THE GROUNDWATER FILE OBJECT",&
655  & "FILE NAME: "//trim(groundwater_file),&
656  & "COULD NOT FIND VARIABLE 'groundwater_temp'")
657 
658  ! MAKE SPACE FOR THE DATA FROM THE FILE
659  gwater_temp_n => reference_var(var)
660  ALLOCATE(storage_vec(0:mt), stat = status)
661  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN GROUNDWATER")
662  CALL nc_connect_pvar(gwater_temp_n,storage_vec)
663  NULLIFY(storage_vec)
664 
665 
666  ! MAKE SPACE FOR THE DATA FROM THE FILE
667  gwater_temp_p => reference_var(var)
668  ALLOCATE(storage_vec(0:mt), stat = status)
669  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN GROUNDWATER")
670  CALL nc_connect_pvar(gwater_temp_p,storage_vec)
671  NULLIFY(storage_vec)
672  END IF
673 
674  ! GROUNDWATER INFLOW SALINITY
675  IF(groundwater_salt_on)THEN
676  var => find_var(gwater_file,"groundwater_salt",found)
677  IF(.not. found) CALL fatal_error &
678  & ("IN THE GROUNDWATER FILE OBJECT",&
679  & "FILE NAME: "//trim(groundwater_file),&
680  & "COULD NOT FIND VARIABLE 'groundwater_salt'")
681 
682  ! MAKE SPACE FOR THE DATA FROM THE FILE
683  gwater_salt_n => reference_var(var)
684  ALLOCATE(storage_vec(0:mt), stat = status)
685  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN GROUNDWATER")
686  CALL nc_connect_pvar(gwater_salt_n,storage_vec)
687  NULLIFY(storage_vec)
688 
689 
690  ! MAKE SPACE FOR THE DATA FROM THE FILE
691  gwater_salt_p => reference_var(var)
692  ALLOCATE(storage_vec(0:mt), stat = status)
693  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN GROUNDWATER")
694  CALL nc_connect_pvar(gwater_salt_p,storage_vec)
695  NULLIFY(storage_vec)
696  END IF
697 
698 
699  !==================================================================
700  CASE DEFAULT
701  !==================================================================
702  CALL fatal_error("CAN NOT RECOGNIZE GROUND WATER FILE TYPE!")
703  !==================================================================
704  END SELECT
705  !==================================================================
706 
707  ! ---------- new: 2016 , april, after Hint by Qi and ayumi.fujisaki@noaa.gov------
708  ! Initialize some variables
709  ! afm 20150914
710  ! Need initialization. Otherwise, random values are asigned
711  ! and cause a hanging problem of MPI job in UPDATE_VAR_BRACKET
712  ! This problem reported with Intel15.0.3.
713  ! PRECIPITATION
714  gwater_flux_p%curr_stkcnt = 0 ; gwater_flux_n%curr_stkcnt = 0
715  gwater_temp_p%curr_stkcnt = 0 ; gwater_temp_n%curr_stkcnt = 0
716  gwater_salt_p%curr_stkcnt = 0 ; gwater_salt_n%curr_stkcnt = 0
717  ! --------- end new ----------------------------------------------------------------
718 
719 
720 
721 
722  IF(dbg_set(dbg_sbr)) write(ipt,*) "END GROUND_WATER"
723  END SUBROUTINE ground_water
724  !================================================================
725  !================================================================
726  SUBROUTINE tidal_elevation
727  IMPLICIT NONE
728 
729  ! VARIABLES TO CHECK OBC NODE LIST
730  INTEGER mynobc
731  INTEGER, ALLOCATABLE :: myobclist(:)
732 
733  REAL(sp), POINTER :: storage_vec(:)
734  ! SOME NC POINTERS
735  TYPE(ncatt), POINTER :: att
736  TYPE(ncdim), POINTER :: dim
737  TYPE(ncvar), POINTER :: var
738 
739  ! SOME HANDY VARIABLES TO PLAY WITH
740  LOGICAL found, valid
741  INTEGER ntimes
742  TYPE(time) :: timetest
743  real(sp) rbuf,float_time
744  integer status, i, j
745 
746  ! SOME TEST STUFF FOR BRACKET
747  Character(len=80):: dstring
748  Character(len=80) :: dformat, tzone
749 
750  REAL(sp), ALLOCATABLE :: myperiod(:)
751 
752  IF(dbg_set(dbg_sbr)) write(ipt,*) "START TIDAL_ELEVATION"
753 
754 
755  ! ONLY ESCAPE EARLY IF EQUI_TIDE IS OFF. OTHERWISE WE STILL NEED
756  ! THE TIDAL FORCING FILE
757  IF (.NOT. obc_elevation_forcing_on ) THEN
758  IF(dbg_set(dbg_log)) write(ipt,*) "! TIDAL ELEVATION FORCING IS OFF!"
759  ALLOCATE(tide_forcing_comments(1))
760  tide_forcing_comments="TIDAL ELEVATION FORCING IS OFF!"
761  RETURN
762  END IF
763 
764 
765  ! BOTH ASCII AND NETCDF NON JULIAN DATA FILES HAVE A NCFILE
766  ! POINTER. THE DUMMY POINTER WAS CREATED FOR THE ASCII FILE AS A
767  ! WAY TO 'TRICK' THE CODE AND CONTAIN THE NUMBER OF CONTROL VARIABLES
768 
769  ! FIND THE TIDAL FORCING FILE OBJECT
770  tide_file => find_file(filehead,trim(obc_elevation_file),found)
771  IF(.not. found) CALL fatal_error &
772  & ("COULD NOT FIND OPEN BOUNDARY CONDITION ELEVATION FILE OBJECT",&
773  & "FILE NAME: "//trim(obc_elevation_file))
774 
775  att => find_att(tide_file,"type",found)
776  IF(.not. found) CALL fatal_error &
777  & ("IN OPEN BOUNDARY CONDITION ELEVATION FILE OBJECT",&
778  & "FILE NAME: "//trim(obc_elevation_file),&
779  &"COULD NOT FIND GLOBAL ATTRIBURE: 'type'")
780 
781 
782  SELECT CASE(trim(att%CHR(1)))
783  !=================================
784  ! NON JULIAN ELEVATION FORCING DATA
785  CASE("FVCOM NON JULIAN ELEVATION FORCING FILE",&
786  & "FVCOM SPECTRAL ELEVATION FORCING FILE")
787  !==================================
788  att => find_att(tide_file,"components",found)
789  IF(found) THEN
790  ALLOCATE(tide_forcing_comments(size(att%CHR)+1))
791  tide_forcing_comments(1)= "Spectral Tidal Forcing Components:"
792  tide_forcing_comments(2:)= att%CHR(:)
793  ELSE
794  CALL warning("ATTRIBUTE 'components' IS MISSING IN THE TIDAL FORCING FILE!")
795  ALLOCATE(tide_forcing_comments(1))
796  tide_forcing_comments = "Spectral Tidal Forcing Components&
797  &: UNKNOWN"
798  END IF
799 
800 
801  dim => find_dim(tide_file,'tidal_components',found)
802  IF(.not. found) CALL fatal_error &
803  & ("IN OPEN BOUNDARY CONDITION SPECTRAL ELEVATION FILE OBJECT",&
804  & "FILE NAME: "//trim(obc_elevation_file),&
805  &"COULD NOT FIND DIMENSION 'tidal_components'")
806 
807  ntidecomps = dim%DIM
808 
809  ! LOAD TIDAL PERIOD DATA
810  ALLOCATE(period(ntidecomps),stat=status)
811  IF (0 /= status) CALL fatal_error("TIDAL_ELEVATION COULD NOT &
812  &ALLOCATE 'NTIDECOMPS'")
813 
814  var => find_var(tide_file,'tide_period',found)
815  IF(.not. found) CALL fatal_error &
816  & ("IN OPEN BOUNDARY CONDITION SPECTRAL ELEVATION FILE OBJECT",&
817  & "FILE NAME: "//trim(obc_elevation_file),&
818  &"COULD NOT FIND THE VARIABLE 'tide_period'")
819 
820  att => find_att(var,'units',found)
821  IF(.not. found) CALL fatal_error &
822  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
823  & "FILE NAME: "//trim(obc_elevation_file),&
824  &"COULD NOT FIND PERIOD VARIRIABLE'S ATTRIBUTE 'units'")
825 
826  if(trim(att%CHR(1)) .NE. 'seconds') CALL fatal_error &
827  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
828  & "FILE NAME: "//trim(obc_elevation_file),&
829  &"PERIOD VARIRIABLE ATTRIBUTE 'units' SHOULD BE 'seconds'")
830 
831  CALL nc_connect_avar(var,period)
832  CALL nc_read_var(var)
833 
834  ! LOAD THE Time Origin data if present
835  var => find_var(tide_file,'time_origin', found)
836  IF (found) THEN
837 
838  IF( is_valid_datetime( var,tzone)) THEN
839 
840  CALL nc_connect_avar(var,dstring)
841  CALL nc_read_var(var)
842 
843  spectime = read_datetime(dstring,date_format,tzone,status)
844  IF(status == 0) CALL fatal_error&
845  & ("Could not read date in 'time_origin' attribute of spectral forcing file")
846 
847  ELSE IF(is_valid_float_days( var,tzone)) THEN
848 
849  CALL nc_connect_avar(var,float_time)
850  CALL nc_read_var(var)
851 
852  spectime = days2time(float_time)
853 
854  ELSE IF(is_valid_float_seconds( var,tzone)) THEN
855 
856  CALL nc_connect_avar(var,float_time)
857  CALL nc_read_var(var)
858 
859  spectime = seconds2time(float_time)
860 
861  ELSE
862  CALL fatal_error("SPECTRAL TIDAL FORCING TIME ORIGIN VA&
863  &RIABLE MUST BE A CHARACTER STRING Date or a float&
864  &ing point time???")
865  END IF
866 
867  ELSE
868  CALL warning("Setting Spectral Tidal Phase Time Orgin to 0.0 MJD")
869  spectime%MJD =0
870  spectime%MUSOD =0
871  END IF
872 
873 
874 
875  if(iobcn_gl>0) then
876  ! LOOK FOR THE DIMENSIONS 'nobc' and 'tidal_compontents'
877  dim => find_dim(tide_file,'nobc',found)
878  IF(.not. found) CALL fatal_error &
879  & ("IN OPEN BOUNDARY CONDITION SPECTRAL ELEVATION FILE OBJECT",&
880  & "FILE NAME: "//trim(obc_elevation_file),&
881  &"COULD NOT FIND DIMENSION 'nobc'")
882 
883  IF(iobcn_gl /= dim%DIM) CALL fatal_error &
884  & ("IN OPEN BOUNDARY CONDITION SPECTRAL ELEVATION FILE OBJECT",&
885  & "FILE NAME: "//trim(obc_elevation_file),&
886  &"THE DIMENSION 'nobc' MUST MATCH THE NUMBER OF OBC NODES")
887 
888 
889  ! LOAD GLOBAL OPEN BOUNDARY NODE NUMBER DATA AND COMPARE WITH
890  ! OBC.DAT/RESTART FILE INPUT
891  ALLOCATE(myobclist(iobcn))
892  var => find_var(tide_file,'obc_nodes',found)
893  IF(.not. found) CALL fatal_error &
894  & ("IN OPEN BOUNDARY CONDITION SPECTRAL ELEVATION FILE OBJECT",&
895  & "FILE NAME: "//trim(obc_elevation_file),&
896  &"COULD NOT FIND VARIABLE 'obc_nodes'")
897  CALL nc_connect_avar(var,myobclist)
898  CALL nc_read_var(var)
899 
900  DO i = 1, iobcn
901 
902  IF(i_obc_n(i) /= nlid(myobclist(i))) THEN
903  write(ipt,*) "NLID(MYOBCLIST)= ", nlid(myobclist(i)), "; I=",i
904  write(ipt,*) "I_OBC_N= ", i_obc_n(i), "; I=",i
905  CALL fatal_error &
906  & ("IN OPEN BOUNDARY CONDITION SPECTRAL ELEVATION FILE OBJECT",&
907  & "FILE NAME: "//trim(obc_elevation_file),&
908  &"THE LIST OF BOUNDARY NODES DOES NOT MATCH")
909  END IF
910  END DO
911 
912  ! LOAD THE ELEVATION REFERENCE LEVEL DATA
913  ALLOCATE(emean(iobcn))
914  var => find_var(tide_file,'tide_Eref',found)
915  IF(.not. found) CALL fatal_error &
916  & ("IN OPEN BOUNDARY CONDITION SPECTRAL ELEVATION FILE OBJECT",&
917  & "FILE NAME: "//trim(obc_elevation_file),&
918  &"COULD NOT FIND VARIABLE 'tide_Eref'")
919 
920  att => find_att(var,'units',found)
921  IF(.not. found) CALL fatal_error &
922  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
923  & "FILE NAME: "//trim(obc_elevation_file),&
924  &"COULD NOT FIND ELEVATION REFERENCE VARIRIABLE'S ATTRIBUTE 'units'")
925 
926  if(trim(att%CHR(1)) .NE. 'meters') CALL fatal_error &
927  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
928  & "FILE NAME: "//trim(obc_elevation_file),&
929  &"ELEVATION REFERENCE VARIRIABLE ATTRIBUTE 'units' SHOULD BE 'meters'")
930 
931  CALL nc_connect_avar(var,emean)
932  CALL nc_read_var(var)
933 
934  ! LOAD THE AMPLITUDE DATA
935  ALLOCATE(apt(iobcn,ntidecomps))
936  var => find_var(tide_file,'tide_Eamp',found)
937  IF(.not. found) CALL fatal_error &
938  & ("IN OPEN BOUNDARY CONDITION SPECTRAL ELEVATION FILE OBJECT",&
939  & "FILE NAME: "//trim(obc_elevation_file),&
940  &"COULD NOT FIND VARIABLE 'tide_Eamp'")
941 
942  att => find_att(var,'units',found)
943  IF(.not. found) CALL fatal_error &
944  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
945  & "FILE NAME: "//trim(obc_elevation_file),&
946  &"COULD NOT FIND AMPLITUDE VARIRIABLE'S ATTRIBUTE 'units'")
947 
948  if(trim(att%CHR(1)) .NE. 'meters') CALL fatal_error &
949  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
950  & "FILE NAME: "//trim(obc_elevation_file),&
951  &"AMPLITUDE VARIRIABLE ATTRIBUTE 'units' SHOULD BE 'meters'")
952 
953 
954  CALL nc_connect_avar(var,apt)
955  CALL nc_read_var(var)
956 
957  ! LOAD THE PHASE DATA
958  ALLOCATE(phai(iobcn,ntidecomps))
959  var => find_var(tide_file,'tide_Ephase',found)
960  IF(.not. found) CALL fatal_error &
961  & ("IN OPEN BOUNDARY CONDITION SPECTRAL ELEVATION FILE OBJECT",&
962  & "FILE NAME: "//trim(obc_elevation_file),&
963  &"COULD NOT FIND VARIABLE 'tide_Ephase'")
964 
965  att => find_att(var,'units',found)
966  IF(.not. found) CALL fatal_error &
967  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
968  & "FILE NAME: "//trim(obc_elevation_file),&
969  &"COULD NOT FIND PHASE VARIRIABLE'S ATTRIBUTE 'units'")
970 
971  if(att%CHR(1)(1:7) .NE. 'degrees') CALL fatal_error &
972  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
973  & "FILE NAME: "//trim(obc_elevation_file),&
974  &"PHASE VARIRIABLE ATTRIBUTE 'units' SHOULD BE 'degrees'")
975 
976  CALL nc_connect_avar(var,phai)
977  CALL nc_read_var(var)
978 
979 
980  phai = mod(phai,360.0_sp)
981 
982  !--REPORT RESULTS--------------------------------------------------------------!
983 
984  rbuf = maxval(apt)
985  IF(dbg_set(dbg_log)) THEN
986  WRITE(ipt,*)'!'
987  WRITE(ipt,* )'! SPECTRAL TIDE : SET'
988  WRITE(ipt,101)'! MAX TIDE AMPLITUDE : ',rbuf
989  CALL print_real_time(spectime,ipt,"Tide Time Origin")
990  END IF
991 
992  endif
993 
994  ! SET THE TIDE FORCING TYPE FOR USE IN UPDATE
995  tide_forcing_type = tide_forcing_spectral
996 
997 
998  !=========================
999  ! NON JULIAN FORCING DATA IN AN ASCII FILE
1000  CASE("ASCII FILE DUMMY ATTRIBUTE")
1001  !=========================
1002 
1003 
1004  CALL load_julian_obc(ntidecomps,tide_forcing_comments&
1005  &,period,apt_eqi, beta_eqi, tide_type,apt,phai,emean,spectime)
1006 
1007  phai = mod(phai,360.0_sp)
1008 
1009  !--REPORT RESULTS--------------------------------------------------------------!
1010 
1011  rbuf = maxval(apt)
1012  IF(dbg_set(dbg_log)) THEN
1013  WRITE(ipt,*)'!'
1014  WRITE(ipt,* )'! SPECTRAL TIDE : SET'
1015  WRITE(ipt,101)'! MAX TIDE AMPLITUDE : ',rbuf
1016  CALL print_real_time(spectime,ipt,"Tide Time Origin")
1017  END IF
1018 
1019  ! SET THE TIDE FORCING TYPE FOR USE IN UPDATE
1020  tide_forcing_type = tide_forcing_spectral
1021 
1022 
1023  !=========================
1024  ! TIME SERIES FORCING DATA
1025  CASE("FVCOM JULIAN TIME SERIES ELEVATION FORCING FILE", &
1026  & "FVCOM TIME SERIES ELEVATION FORCING FILE")
1027  !=========================
1028 
1029  ALLOCATE(tide_forcing_comments(1))
1030  att => find_att(tide_file,"title",found)
1031  IF(found) THEN
1032  tide_forcing_comments = "Tidal Forcing Time Series Title: "&
1033  &//trim(att%CHR(1))
1034  ELSE
1035  CALL warning("ATTRIBUTE 'title' IS MISSING IN THE TIDAL FORCING FILE!")
1036  tide_forcing_comments = "Tidal Forcing Time Series Title: UNKNOWN"
1037  END IF
1038 
1039 
1040 
1041  ! LOOK FOR THE DIMENSIONS 'nobc' and 'time'
1042  dim => find_dim(tide_file,'time',found)
1043  IF(.not. found) CALL fatal_error &
1044  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
1045  & "FILE NAME: "//trim(obc_elevation_file),&
1046  &"COULD NOT FIND DIMENSION 'time'")
1047 
1048  ntimes = dim%DIM
1049 
1050  dim => find_dim(tide_file,'nobc',found)
1051  IF(.not. found) CALL fatal_error &
1052  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
1053  & "FILE NAME: "//trim(obc_elevation_file),&
1054  &"COULD NOT FIND DIMENSION 'nobc'")
1055 
1056  if(iobcn_gl>0) then
1057  IF(iobcn_gl /= dim%DIM) CALL fatal_error &
1058  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
1059  & "FILE NAME: "//trim(obc_elevation_file),&
1060  &"THE DIMENSION 'nobc' MUST MATCH THE NUMBER OF OBC NODES")
1061  endif
1062 
1063  ! lOAD GLOBAL OPEN BOUNDARY NOD NUMBER DATA AND COMPARE WITH
1064  ! OBC.DAT/RESTART FILE INPUT
1065  ALLOCATE(myobclist(iobcn))
1066  var => find_var(tide_file,'obc_nodes',found)
1067  IF(.not. found) CALL fatal_error &
1068  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
1069  & "FILE NAME: "//trim(obc_elevation_file),&
1070  &"COULD NOT FIND VARIABLE 'obc_nodes'")
1071  CALL nc_connect_avar(var,myobclist)
1072  CALL nc_read_var(var)
1073 
1074  DO i = 1, iobcn
1075 
1076  IF(serial) THEN
1077  IF(i_obc_n(i) /= myobclist(i)) THEN
1078  write(ipt,*) "NLID(MYOBCLIST)= ", myobclist(i), "; I=",i
1079  write(ipt,*) "I_OBC_N= ", i_obc_n(i), "; I=",i
1080  CALL fatal_error &
1081  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
1082  & "FILE NAME: "//trim(obc_elevation_file),&
1083  &"THE LIST OF BOUNDARY NODES DOES NOT MATCH")
1084  END IF
1085  ELSE
1086  END IF
1087  END DO
1088 
1089  ! LOAD TIME AND CHECK TO MAKE SURE THE TIME RANGE IS VALID
1090 
1091  timetest = get_file_time(tide_file,1)
1092 
1093  IF(timetest > starttime) CALL fatal_error &
1094  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
1095  & "FILE NAME: "//trim(obc_elevation_file),&
1096  &"THE MODEL RUN STARTS BEFORE THE ELVATION TIME SERIES")
1097 
1098  timetest = get_file_time(tide_file,ntimes)
1099 
1100 
1101  IF(timetest < endtime) CALL fatal_error &
1102  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
1103  & "FILE NAME: "//trim(obc_elevation_file),&
1104  &"THE MODEL RUN ENDS AFTER THE ELVATION TIME SERIES")
1105 
1106  var => find_var(tide_file,'elevation',found)
1107  IF(.not. found) CALL fatal_error &
1108  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
1109  & "FILE NAME: "//trim(obc_elevation_file),&
1110  &"COULD NOT FIND VARIABLE 'elevation'")
1111 
1112  att => find_att(var,'units',found)
1113  IF(.not. found) CALL fatal_error &
1114  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
1115  & "FILE NAME: "//trim(obc_elevation_file),&
1116  &"COULD NOT FIND ELEVATION VARIRIABLE'S ATTRIBUTE 'units'")
1117 
1118  if(trim(att%CHR(1)) .NE. 'meters') CALL fatal_error &
1119  & ("IN OPEN BOUNDARY CONDITION TIME SERIES ELEVATION FILE OBJECT",&
1120  & "FILE NAME: "//trim(obc_elevation_file),&
1121  &"ELEVATION VARIRIABLE ATTRIBUTE 'units' SHOULD BE 'meters'")
1122 
1123 
1124  ! MAKE SPACE FOR THE DATA FROM THE FILE
1125  ALLOCATE(storage_vec(iobcn), stat = status)
1126  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN TIDAL_ELEVATION")
1127  tide_elv_n => reference_var(var)
1128  CALL nc_connect_pvar(tide_elv_n,storage_vec)
1129  NULLIFY(storage_vec)
1130 
1131  ! MAKE SPACE FOR THE DATA FROM THE FILE
1132  ALLOCATE(storage_vec(iobcn), stat = status)
1133  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN TIDAL_ELEVATION")
1134  tide_elv_p => reference_var(var)
1135  CALL nc_connect_pvar(tide_elv_p,storage_vec)
1136  NULLIFY(storage_vec)
1137 
1138 
1139  ! SINCE NO DATA HAS BEEN LOADED THERE IS NOT MUCH TO REPORT
1140  IF(dbg_set(dbg_log)) THEN
1141  WRITE(ipt,*)'!'
1142  WRITE(ipt,* )'! TIME SERIES TIDE : SET'
1143  END IF
1144 
1145  ! SET THE TIDE FORCING TYPE FOR USE IN UPDATE
1146  tide_forcing_type = tide_forcing_timeseries
1147 
1148 
1149  ! ---------- new: 2016 , april, after Hint by Qi -------------------------
1150  ! Initialize some variables
1151  ! afm 20150914
1152  ! Need initialization. Otherwise, random values are asigned
1153  ! and cause a hanging problem of MPI job in UPDATE_VAR_BRACKET
1154  ! This problem reported with Intel15.0.3.
1155  tide_elv_p%curr_stkcnt = 0; tide_elv_n%curr_stkcnt = 0
1156  ! --------- end new --------------------------------------------
1157 
1158  ! NOT MUCH ELSE TO REPORT SINCE WE DON'T LOAD ANY DATA NOW
1159 
1160  !=====================================
1161  ! DEFAULT CASE IF GLOBAL ATTRIBUTES OF FILE ARE INCORRECT
1162  CASE DEFAULT
1163  !=====================================
1164  CALL fatal_error &
1165  & ("IN OPEN BOUNDARY CONDITION ELEVATION FILE OBJECT",&
1166  & "FILE NAME: "//trim(obc_elevation_file),&
1167  &"THE GLOBAL ATTRIBURE 'type' RETURNED UNKNOWN TYPE:",&
1168  & trim(att%CHR(1)))
1169  END SELECT
1170 
1171  IF(dbg_set(dbg_sbr)) write(ipt,*) "END TIDAL_ELEVATION"
1172 
1173 101 FORMAT(1x,a26,f10.4)
1174  END SUBROUTINE tidal_elevation
1175  !================================================================
1176  !================================================================
1177 
1178  ! Rules about river names: River names must be unique
1179  ! examples: r1, r2, r3
1180  ! : Mississippi, Connecticut, St.Lawrence
1181  ! BAD EXAMPLES: Miss, Mississippi, Missouri
1182  ! : R1, R2, R
1183 
1184  SUBROUTINE river_discharge
1185  IMPLICIT NONE
1186  INTEGER :: i, j,k, fcnt,rcnt,status, nfiles,nrs,ios,ns
1187  TYPE(a_river_file) dummy
1188 
1189  TYPE(ncfile),POINTER :: ncf
1190  TYPE(ncdim), POINTER :: dim
1191  TYPE(ncvar), POINTER :: var
1192  TYPE(ncvar), POINTER :: dum_p
1193 
1194  REAL(sp), POINTER :: storage_vec(:)
1195  LOGICAL :: found, mine
1196  CHARACTER(LEN=7) :: chr
1197  character(len=20), allocatable :: dist_strings(:)
1198 
1199  REAL(sp) :: mydist(kbm1)
1200 
1201  IF(dbg_set(dbg_sbr)) write(ipt,*) "START RIVER_DISCHARGE"
1202 
1203  NULLIFY(storage_vec)
1204 
1205  ! TRANSLATE TO THE OLD NAME FOR TOTAL NUMBER OF RIVERS
1206  numqbc_gl = river_number
1207 
1208  IF (river_number == 0 ) THEN
1209  numqbc = 0
1210  IF(dbg_set(dbg_log)) write(ipt,*) "! THERE ARE NO RIVERS IN THIS MODEL"
1211  ALLOCATE(river_forcing_comments(1))
1212  river_forcing_comments(1) = "THERE ARE NO RIVERS IN T&
1213  &HIS MODEL"
1214  RETURN
1215  END IF
1216 
1217 
1218  IF (dbg_set(dbg_sbrio))THEN
1219  WRITE(ipt,*) "Total Number Of Rivers = ",river_number
1220  WRITE(ipt,*) "RIVER_TS_SETTING = "//trim(river_ts_setting)
1221  WRITE(ipt,*) "RIVER_INFLOW_LOCATION = "//trim(river_inflow_location)
1222  WRITE(ipt,*) "RIVER_KIND = "//trim(river_kind)
1223 
1224  WRITE(ipt,*)"============================="
1225  DO i =1,river_number
1226  write(ipt,*) "River number:",i
1227  WRITE(ipt,*) "River File ="//trim(rivers(i)%FILE)
1228  WRITE(ipt,*) "River Name ="//trim(rivers(i)%NAME)
1229  WRITE(ipt,*) "River Location =",rivers(i)%LOCATION
1230 
1231  WRITE(ipt,*) "River Distribution =",rivers(i)%distribution(1:kbm1)
1232 
1233  WRITE(ipt,*)"============================="
1234  END DO
1235  END IF
1236 
1237  IF(trim(river_ts_setting) /= 'calculated' .AND. trim(river_ts_setting) /= 'specified') THEN
1238  CALL fatal_error("RIVER_TS_SETTING NOT CORRECT IN NAMELIST","SHOULD BE 'calculated' or 'specified'")
1239  END IF
1240 
1241  ALLOCATE(river_forcing_comments(river_number + 3))
1242  WRITE(chr,'(I7)')river_number
1243  river_forcing_comments(1) = "THERE ARE "//trim(adjustl(chr))//" RIVERS IN THIS MODEL."
1244 
1245  river_forcing_comments(2) = "RIVER INFLOW IS ON THE "//trim(river_inflow_location)&
1246  &//"s WHERE TEMPERATURE AND SALINITY ARE "//trim(river_ts_setting)//" IN THE MODEL."
1247 
1248  river_forcing_comments(3) = "THE FOLLOWING RIVER NAMES ARE USED:"
1249  DO i =1,river_number
1250  river_forcing_comments(3+i) = trim(rivers(i)%NAME)
1251  END DO
1252 
1253  ! SELECT CASE(trim(RIVER_INFLOW_LOCATION))
1254 
1255  ! CHECK TO MAKE SURE THE LOCATION IS VALID AND ADD NAMES TO
1256  ! COMMENT STRING
1257  nfiles = 0
1258  numqbc = 0
1259  DO i =1,river_number
1260 
1261 
1262  ! CHECK THE INFLOW LOCATION OF EACH RIVER
1263  ! AND
1264  ! COUNT THE NUMBER THAT BELONG TO EACH PROCESSOR
1265  SELECT CASE(trim(river_inflow_location))
1266  CASE('node')
1267 
1268  IF(rivers(i)%LOCATION > mgl .or. rivers(i)%LOCATION < 1)THEN
1269  write(chr,'(I7)') rivers(i)%LOCATION
1270  CALL fatal_error ("RIVER_DISCHARGE: FOR THE RIVER NAMED: "&
1271  &//trim(rivers(i)%NAME),"THE RIVER GRID LOCATION IN&
1272  & THE NAME LIST IS NOT IN THE GLOBAL DOMAIN",&
1273  & "YOU SPECIFIED NODE NUMBER: "//chr)
1274  END IF
1275 
1276  ! COUNT THE NUMBER OF RIVERS OWNED BY THIS PROC
1277  IF (nlid(rivers(i)%LOCATION) .GT. 0) numqbc = numqbc + 1
1278 
1279 
1280  CASE('edge')
1281  IF(rivers(i)%LOCATION > ngl .or. rivers(i)%LOCATION < 1)THEN
1282  write(chr,'(I7)') rivers(i)%LOCATION
1283  CALL fatal_error ("RIVER_DISCHARGE: FOR THE RIVER NAMED: "&
1284  &//trim(rivers(i)%NAME),"THE RIVER GRID LOCATION IN&
1285  & THE NAME LIST IS NOT IN THE GLOBAL DOMAIN",&
1286  & "YOU SPECIFIED CELL NUMBER: "//chr)
1287  END IF
1288 
1289  ! COUNT THE NUMBER OF RIVERS OWNED BY THIS PROC
1290  IF (elid(rivers(i)%LOCATION) .GT. 0) numqbc = numqbc + 1
1291 
1292 
1293 
1294 
1295  CASE DEFAULT
1296  CALL fatal_error("RIVER_INFLOW_LOCATION: NOT CORRECT IN NAMELIST",&
1297  & "SHOULD BE 'node' or 'edge'")
1298  END SELECT
1299 
1300 
1301  ! COUNT THE NUMBER OF FILES
1302  ncf => find_file(filehead,trim(rivers(i)%FILE),found)
1303  IF (.NOT.found) CALL fatal_error &
1304  & ("RIVER_DISCHARGE: COULD NOT FIND RIVER FILE OBJECT NAMED: &
1305  &"//trim(rivers(i)%FILE))
1306 
1307  IF(.NOT. associated(ncf%FTIME)) CALL fatal_error&
1308  &("RIVER FILE DID NOT LOAD PROPERLY",&
1309  & "File name:"//trim(ncf%FNAME),&
1310  &"Please check the time format!")
1311 
1312 
1313  IF (ncf%FTIME%PREV_STKCNT /= 999) THEN
1314  nfiles = nfiles +1
1315  ncf%FTIME%PREV_STKCNT = 999
1316  END IF
1317 
1318  END DO
1319 
1320 
1321  ! ALLOCATE THE SPACE FOR THE RIVER FILES AND NULLIFY POINTERS
1322  ALLOCATE(river_forcing(nfiles))
1323  DO i =1,nfiles
1324  NULLIFY(river_forcing(i)%NCF)
1325  NULLIFY(river_forcing(i)%FLUX_N)
1326  NULLIFY(river_forcing(i)%FLUX_P)
1327  NULLIFY(river_forcing(i)%TEMP_N)
1328  NULLIFY(river_forcing(i)%TEMP_P)
1329  NULLIFY(river_forcing(i)%SALT_N)
1330  NULLIFY(river_forcing(i)%SALT_P)
1331  END DO
1332 
1333 
1334  ! ALLOCATE THE SPACE FOR THE RIVER DATA
1335  ALLOCATE(riv_gl2loc(numqbc))
1336  ALLOCATE(inodeq(numqbc))
1337  ALLOCATE(icellq(numqbc)) ! THE CELL INDEX
1338  ALLOCATE(n_icellq(numqbc,2)) ! THE NODES BOUNDING THE EDGE
1339  ALLOCATE(vqdist(numqbc,kbm1)); vqdist = 0.0_sp
1340  ALLOCATE(qdis(numqbc)); qdis = 0.0_sp
1341  ALLOCATE(qdis2(numqbc)); qdis2 = 0.0_sp
1342  ALLOCATE(tdis(numqbc)); tdis = 0.0_sp
1343  ALLOCATE(sdis(numqbc)); sdis = 0.0_sp
1344  ALLOCATE(qarea(numqbc)); qarea = 0.0_sp
1345  ALLOCATE(angleq(numqbc)); angleq = 0.0_sp
1346  ALLOCATE(vlctyq(numqbc)); vlctyq = 0.0_sp
1347  ALLOCATE(rdisq(numqbc,2)); rdisq = 0.0_sp
1348 
1349  fcnt = 0
1350  rcnt = 0
1351  DO i =1,river_number
1352  ! SET MINE TO FALSE
1353  mine = .false.
1354  ! Mine is set true if this river name belongs
1355  ! to this processor
1356 
1357 
1358 
1359  ! MAKE THE LOCAL AND GLOBAL INDEX
1360  SELECT CASE(trim(river_inflow_location))
1361  CASE('node')
1362 
1363  IF (nlid(rivers(i)%LOCATION) .GT. 0) THEN
1364  rcnt = rcnt + 1
1365  inodeq(rcnt) = nlid(rivers(i)%LOCATION)
1366  riv_gl2loc(rcnt) = rivers(i)%LOCATION
1367  mine = .true.
1368  END IF
1369 
1370 
1371 
1372 
1373  CASE('edge')
1374 
1375  IF (elid(rivers(i)%LOCATION) .GT. 0) THEN
1376  rcnt = rcnt + 1
1377  icellq(rcnt) = elid(rivers(i)%LOCATION)
1378  riv_gl2loc(rcnt) = rivers(i)%LOCATION
1379  mine = .true.
1380  END IF
1381 
1382  END SELECT
1383 
1384 
1385  ! MAKE VQDIST
1386  IF(mine) THEN
1387 
1388 !--------------------------------------------------------------------
1389 !--------------------------------------------------------------------
1390 
1391  IF(any(rivers(i)%DISTRIBUTION(1:kbm1)<0.0_sp)) CALL fatal_error&
1392  &("You are not permitted to set the river distrobution value less than zero!",&
1393  & "This usually indicates a mistake in the name list - not enough layers specifed" )
1394  vqdist(rcnt,1:kbm1)=rivers(i)%DISTRIBUTION(1:kbm1)
1395 
1396 !--------------------------------------------------------------------
1397 !--------------------------------------------------------------------
1398 
1399  END IF
1400 
1401  ! NOW PUT THE RIVERS IN THE RIVER_FORCING TYPE
1402  ncf => find_file(filehead,trim(rivers(i)%FILE),found)
1403 
1404  IF (ncf%FTIME%PREV_STKCNT == 999) THEN
1405  fcnt = fcnt + 1
1406  river_forcing(fcnt)%NCF => ncf
1407  ncf%FTIME%PREV_STKCNT = 0
1408 
1409  dim => find_dim(ncf,'rivers',found)
1410  IF(.not.found) CALL fatal_error &
1411  & ("COULD NOT FIND DIMENSION 'rivers'",&
1412  & "In the file: "//trim(ncf%FNAME) )
1413 
1414  river_forcing(fcnt)%RIVERS_IN_FILE=dim%DIM
1415 
1416  ALLOCATE(river_forcing(fcnt)%RIV_FILE2LOC(dim%DIM))
1417  river_forcing(fcnt)%RIV_FILE2LOC = 0
1418 
1419  END IF
1420 
1421  ! FIGURE OUT WHICH RIVER IT IS WHICH FILE AND SET THE INDEX
1422  DO j = 1, nfiles
1423  ! IN THIS FILE FIND THE NAME
1424  IF (associated(ncf,river_forcing(j)%NCF)) THEN
1425  k=search_name(ncf,rivers(i)%NAME)
1426 
1427  ! THIS IS MY RIVER SO SET THE INDEX
1428  IF (mine) river_forcing(j)%RIV_FILE2LOC(k)=rcnt
1429 
1430  END IF
1431  END DO
1432 
1433 
1434  END DO
1435 
1436  IF (fcnt /= nfiles) CALL fatal_error&
1437  ("RIVER_DISCHARGE: WE LOST A RIVER FILE IN THE MIDDLE OF NOWHERE!")
1438 
1439  IF (rcnt /= numqbc) CALL fatal_error&
1440  ("RIVER_DISCHARGE: WE LOST A RIVER IN THE MIDDLE OF NOWHERE!")
1441 
1442 
1443  DO i = 1, nfiles
1444 
1445  ncf => river_forcing(i)%NCF
1446 
1447  SELECT CASE (river_kind)
1448  CASE(prdc)
1449  CALL check_river_file(ncf, river_forcing(i)%river_period)
1450  CASE(vrbl)
1451  CALL check_river_file(ncf)
1452  CASE DEFAULT
1453  CALL fatal_error("Invalid RIVER_KIND in namelist runfile:",&
1454  & " Options are: "//trim(prdc)//" or "//trim(vrbl))
1455  END SELECT
1456 
1457  dim => find_dim(ncf,'rivers',found)
1458 
1459  nrs = dim%dim
1460 
1461  ! GET THE FLUX VARIABLE
1462  var => find_var(ncf,'river_flux',found)
1463 
1464  ALLOCATE(storage_vec(nrs), stat = status)
1465  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN RIVER_DISCHARGE")
1466  river_forcing(i)%FLUX_N => reference_var(var)
1467  CALL nc_connect_pvar(river_forcing(i)%FLUX_N,storage_vec)
1468  NULLIFY(storage_vec)
1469 
1470  ALLOCATE(storage_vec(nrs), stat = status)
1471  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN RIVER_DISCHARGE")
1472  river_forcing(i)%FLUX_P => reference_var(var)
1473  CALL nc_connect_pvar(river_forcing(i)%FLUX_P,storage_vec)
1474  NULLIFY(storage_vec)
1475 
1476  ! GET THE TEMPERATURE VARIABLE
1477  var => find_var(ncf,'river_temp',found)
1478 
1479  ALLOCATE(storage_vec(nrs), stat = status)
1480  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN RIVER_DISCHARGE")
1481  river_forcing(i)%TEMP_N => reference_var(var)
1482  CALL nc_connect_pvar(river_forcing(i)%TEMP_N,storage_vec)
1483  NULLIFY(storage_vec)
1484 
1485  ALLOCATE(storage_vec(nrs), stat = status)
1486  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN RIVER_DISCHARGE")
1487  river_forcing(i)%TEMP_P => reference_var(var)
1488  CALL nc_connect_pvar(river_forcing(i)%TEMP_P,storage_vec)
1489  NULLIFY(storage_vec)
1490 
1491  ! GET THE SALINITY VARIABLE
1492  var => find_var(ncf,'river_salt',found)
1493 
1494  ALLOCATE(storage_vec(nrs), stat = status)
1495  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN RIVER_DISCHARGE")
1496  river_forcing(i)%SALT_N => reference_var(var)
1497  CALL nc_connect_pvar(river_forcing(i)%SALT_N,storage_vec)
1498  NULLIFY(storage_vec)
1499 
1500  ALLOCATE(storage_vec(nrs), stat = status)
1501  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN RIVER_DISCHARGE")
1502  river_forcing(i)%SALT_P => reference_var(var)
1503  CALL nc_connect_pvar(river_forcing(i)%SALT_P,storage_vec)
1504  NULLIFY(storage_vec)
1505 
1506  ! ============= New : 2016, April ===================
1507  ! Initialize some variables
1508  ! Similar to the hints by Qi and afm 20160216
1509  river_forcing(i)%FLUX_N%curr_stkcnt = 0; river_forcing(i)%FLUX_P%curr_stkcnt = 0
1510  river_forcing(i)%TEMP_N%curr_stkcnt = 0; river_forcing(i)%TEMP_P%curr_stkcnt = 0
1511  river_forcing(i)%SALT_N%curr_stkcnt = 0; river_forcing(i)%SALT_P%curr_stkcnt = 0
1512  ! ==================== end new ======================================
1513 
1514 
1515 
1516 
1517 
1518 
1519  END DO
1520 
1521  ! SET THE RIVER BNDRY METRICS - USED TO BE SET_BNDRY
1522  CALL set_river_bndry_metrics
1523 
1524 
1525  IF(dbg_set(dbg_log)) THEN
1526  WRITE(ipt,*)"!"
1527  WRITE(ipt,*)"! RIVER FORCING ON"
1528  WRITE(ipt,*)'! GLOBAL NUMBER OF RIVERS :',river_number
1529  WRITE(ipt,*)'! NUMBER OF RIVER FILES :', nfiles
1530  END IF
1531 
1532  IF(dbg_set(dbg_scl)) THEN
1533  WRITE(ipt,*)"/////////=============================///////////"
1534  WRITE(ipt,*)" PRINTING RIVER FORCING DETAILS"
1535 
1536  WRITE(ipt,*)" LOCAL NUMBER OF RIVERS : ", numqbc
1537 
1538  WRITE(ipt,*)"============================="
1539  DO i = 1,nfiles
1540  WRITE(ipt,*)" FILE NAME: "//trim(river_forcing(i)%NCF%FNAME)
1541  ! WRITE(IPT,*)" RIVER NAME: "//TRIM(RIVER_FORCING(I)%NAME)
1542  WRITE(ipt,*)" NUMBER IN FILE=",river_forcing(i)%RIVERS_IN_FILE
1543  WRITE(ipt,*)" RIV_FILE2LOC = ",river_forcing(i)%RIV_FILE2LOC
1544  WRITE(ipt,*)"============================="
1545  END DO
1546 
1547  WRITE(ipt,*)"/////////=============================///////////"
1548  END IF
1549 
1550  IF(dbg_set(dbg_sbr)) write(ipt,*) "END RIVER_DISCHARGE"
1551 
1552 
1553 
1554  END SUBROUTINE river_discharge
1555  !================================================================
1556  !================================================================
1557  FUNCTION search_name(NCF,NAME) RESULT(RES)
1558  ! OUTPUT is the TYPE we are trying to set
1559  ! Input is the River type we are searching from
1560  IMPLICIT NONE
1561  INTEGER :: res
1562  TYPE(ncfile), POINTER :: ncf
1563  CHARACTER(LEN=*) :: name
1564 
1565  INTEGER :: i, rvrs_in_file,strlen,status
1566  TYPE(ncdim), POINTER :: dim
1567  TYPE(ncvar), POINTER :: var
1568  LOGICAL found
1569 
1570  IF (dbg_set(dbg_io)) THEN
1571  WRITE(ipt,*)"SEARCH_NAME (RIVERS)"
1572  WRITE(ipt,*)"============================="
1573  write(ipt,*)"LOOKING FOR: '"//trim(name)//"'"
1574  WRITE(ipt,*)"=========="
1575  CALL print_file(ncf)
1576  END IF
1577 
1578 
1579  ! FIND THE RIVER NAME IN THE FILE
1580  dim => find_dim(ncf,'rivers',found)
1581  rvrs_in_file = dim%DIM
1582 
1583  var => find_var(ncf,'river_names',found)
1584 
1585  ! ATTEMPT TO ONLY READ NAMES LIST ONCE
1586  IF(.NOT. ASSOCIATED(var%VEC_CHR)) THEN
1587 
1588  ALLOCATE(var%VEC_CHR(dim%DIM),stat=status)
1589  IF(status/=0) CALL fatal_error("SEARCH_NAME: CAN NOT ALLOCATE TEMP!")
1590 
1591  CALL nc_read_var(var)
1592 
1593  END IF
1594 
1595  DO i = 1,rvrs_in_file
1596  IF(var%VEC_CHR(i) .EQ. name)THEN
1597  res = i
1598  RETURN
1599  END IF
1600  END DO
1601 
1602 
1603 
1604  ! SHOULD NOT BE HERE, SOMETHING IS WRONG
1605 
1606  IF (dbg_set(dbg_log)) THEN
1607  WRITE(ipt,*)"============================="
1608  write(ipt,*)"LOOKING FOR: '"//trim(name)//"'; In File:"
1609  WRITE(ipt,*)"============================="
1610  CALL print_file(ncf)
1611  DO i = 1,rvrs_in_file
1612  WRITE(ipt,*) "RIVER NAMES: "//trim(var%VEC_CHR(i))
1613  END DO
1614  WRITE(ipt,*)"============================="
1615  WRITE(ipt,*)"============================="
1616  WRITE(ipt,*)"============================="
1617  END IF
1618 
1619 
1620  CALL fatal_error("COULD NOT FIND CORRECT NAME IN RIVER FILE?")
1621 
1622  END FUNCTION search_name
1623  !================================================================
1624  !================================================================
1625  SUBROUTINE check_river_file(NCF,PERIOD)
1626  ! CALL FATAL_ERROR IF THERE IS ANYTHING WRONG WITH THE FILE
1627  IMPLICIT NONE
1628  TYPE(ncfile), POINTER ::ncf
1629  TYPE(time),OPTIONAL :: period
1630  ! SOME NC POINTERS
1631  TYPE(ncatt), POINTER :: att
1632  TYPE(ncdim), POINTER :: dim
1633  TYPE(ncvar), POINTER :: var
1634 
1635  TYPE(time) :: fstart, fend
1636  INTEGER :: ntimes,ns
1637  LOGICAL found
1638 
1639  IF(.NOT. ASSOCIATED(ncf)) CALL fatal_error &
1640  & ("THE RIVER FILE OBJECT PASSED TO 'check_river_file' IS NOT ASSOCIATED")
1641 
1642  ! CHECK DIMENSIONS
1643  dim => find_dim(ncf,'time',found)
1644  IF(.NOT. found) CALL fatal_error &
1645  & ("THE RIVER FILE:"//trim(ncf%FNAME),"IS MISSING THE 'time' DIMENSION")
1646 
1647  ntimes = dim%dim
1648 
1649  dim => find_dim(ncf,'namelen',found)
1650  IF(.NOT. found) CALL fatal_error &
1651  & ("THE RIVER FILE:"//trim(ncf%FNAME),"IS MISSING THE 'namelen' DIMENSION")
1652 
1653  dim => find_dim(ncf,'rivers',found)
1654  IF(.NOT. found) CALL fatal_error &
1655  & ("THE RIVER FILE:"//trim(ncf%FNAME),"IS MISSING THE 'rivers' DIMENSION")
1656 
1657  ! CHECK VARIABLES AND THEIR ATTS
1658  IF(.NOT. ASSOCIATED(ncf%FTIME)) CALL fatal_error &
1659  & ('THE RIVER FILE '//trim(ncf%FNAME),&
1660  'DOES NOT HAVE A RECONGIZED TIME VARIABLE')
1661 
1662  IF(PRESENT(period)) THEN
1663 
1664  ! CHECK START AND END TIME FOR THE FILE:
1665  fstart = get_file_time(ncf,1)
1666  IF(zerotime /= fstart) THEN
1667  CALL print_time(fstart,ipt,"River Data Start")
1668  CALL fatal_error &
1669  & ("Date of the first river data point must be 0.0 for periodic forcoing mode:",&
1670  & "The River File: "//trim(ncf%FNAME)//'; has a bad start date.')
1671  END IF
1672 
1673  period = get_file_time(ncf,ntimes)
1674  IF(period .LE. zerotime) THEN
1675  CALL print_real_time(period,ipt,"River Data End")
1676 
1677  CALL fatal_error &
1678  & ("Date of the last river data point must be greater than or equal to zero for periodic forcing mode:",&
1679  & "The River File: "//trim(ncf%FNAME)//'; has a bad end date.')
1680  END IF
1681 
1682 
1683  ELSE
1684  ! CHECK START AND END TIME FOR THE FILE:
1685  fstart = get_file_time(ncf,1)
1686  IF(fstart > starttime) THEN
1687  CALL print_real_time(starttime,ipt,"Model Start")
1688  CALL print_real_time(fstart,ipt,"River Data Start")
1689  CALL fatal_error &
1690  & ("Date of the first river data point must be less than or equal to the model start date:",&
1691  & "The River File: "//trim(ncf%FNAME)//'; has a bad start date.')
1692  END IF
1693 
1694  fend = get_file_time(ncf,ntimes)
1695  IF(fend < endtime) THEN
1696  CALL print_real_time(endtime,ipt,"Model End")
1697  CALL print_real_time(fend,ipt,"River Data End")
1698 
1699  CALL fatal_error &
1700  & ("Date of the last river data point must be greater than or equal to the model end date:",&
1701  & "The River File: "//trim(ncf%FNAME)//'; has a bad end date.')
1702  END IF
1703  END IF
1704 
1705  var => find_var(ncf,'river_names',found)
1706  IF(.NOT. found) CALL fatal_error &
1707  & ("THE RIVER FILE:"//trim(ncf%FNAME),"IS MISSING THE 'river_names' VARIABLE")
1708  ! HAS NO ATTRIBUTES
1709 
1710  var => find_var(ncf,'river_flux',found)
1711  IF(.NOT. found) CALL fatal_error &
1712  & ("THE RIVER FILE:"//trim(ncf%FNAME),"IS MISSING THE 'river_flux' VARIABLE")
1713 
1714  att => find_att(var,'units',found)
1715  IF(.NOT. found) CALL fatal_error &
1716  & ("THE RIVER FILE:"//trim(ncf%FNAME),"THE VARIABLE: "&
1717  &//trim(var%VARNAME), "IS MISSING THE ATTRIBUTE 'units'")
1718 
1719  IF(trim(att%CHR(1)) /= "m^3s^-1")CALL fatal_error &
1720  & ("THE RIVER FILE:"//trim(ncf%FNAME),"THE VARIABLE: "&
1721  &//trim(var%VARNAME), "THE ATTRIBUTE 'units' IS INCORRECT: EXPE&
1722  &CTING 'm^3s^-1'")
1723 
1724  var => find_var(ncf,'river_temp',found)
1725  IF(.NOT. found) CALL fatal_error &
1726  & ("THE RIVER FILE:"//trim(ncf%FNAME),"IS MISSING THE 'river_temp' VARIABLE")
1727 
1728  att => find_att(var,'units',found)
1729  IF(.NOT. found) CALL fatal_error &
1730  & ("THE RIVER FILE:"//trim(ncf%FNAME),"THE VARIABLE: "&
1731  &//trim(var%VARNAME), "IS MISSING THE ATTRIBUTE 'units'")
1732 
1733  IF(trim(att%CHR(1)) /= "Celsius")CALL fatal_error &
1734  & ("THE RIVER FILE:"//trim(ncf%FNAME),"THE VARIABLE: "&
1735  &//trim(var%VARNAME), "THE ATTRIBUTE 'units' IS INCORRECT: EXPE&
1736  &CTING 'Celsius'")
1737 
1738  var => find_var(ncf,'river_salt',found)
1739  IF(.NOT. found) CALL fatal_error &
1740  & ("THE RIVER FILE:"//trim(ncf%FNAME),"IS MISSING THE 'river_salt' VARIABLE")
1741 
1742  att => find_att(var,'units',found)
1743  IF(.NOT. found) CALL fatal_error &
1744  & ("THE RIVER FILE:"//trim(ncf%FNAME),"THE VARIABLE: "&
1745  &//trim(var%VARNAME), "IS MISSING THE ATTRIBUTE 'units'")
1746 
1747  IF(trim(att%CHR(1)) /= "PSU")CALL fatal_error &
1748  & ("THE RIVER FILE:"//trim(ncf%FNAME),"THE VARIABLE: "&
1749  &//trim(var%VARNAME), "THE ATTRIBUTE 'units' IS INCORRECT: EXPE&
1750  &CTING 'PSU'")
1751 
1752  END SUBROUTINE check_river_file
1753  !==============================================================================|
1754  ! SET METRICS FOR THE BOUNDARY CONDITIONS |
1755  !==============================================================================|
1756  SUBROUTINE set_river_bndry_metrics
1757  IMPLICIT NONE
1758  REAL(dp) dx12,dy12,dx32,dy32,atmp1,atmp2,dxytmp,htmp,areatmp
1759  REAL(dp) xnorm,ynorm,xp,yp,xn,yn,xi,yi,fac,xnext,ynext,modnr
1760  INTEGER i,j,i1,i2,i3,j1,j2,ii,itmp,jtmp,inode,jnode,knode,nnorm
1761  CHARACTER(len=7) :: strng
1762 
1763  !------------------------------------------------------------------------------!
1764 
1765  IF(dbg_set(dbg_sbr)) write(ipt,*) "START SET_RIVER_BNDRY_METRICS"
1766 
1767  SELECT CASE(trim(river_inflow_location))
1768  !=====================================
1769  ! CASE NODE: if the river inflow is on the nodes
1770  CASE('node')
1771  !=====================================
1772 
1773  ! WHY DON'T WE REQUIRE THAT RIVERS ARE ON THE BOUNDARY FOR NODE?
1774 
1775  DO i=1,numqbc
1776  j=inodeq(i)
1777  if (isonb(j) /= 1) THEN
1778  write(strng,'(I6)') ngid(j)
1779  CALL fatal_error &
1780  & ("You seem to be trying to put a river in the middle of the domain",&
1781  & "The global node number you selected is: "//trim(adjustl(strng)),&
1782  &"but this is not a solid boundary node?")
1783  END if
1784  i1=nbsn(j,2)
1785  i2=nbsn(j,1)
1786  i3=nbsn(j,ntsn(j)-1)
1787  dy12=vy(i1)-vy(i2)
1788  dy32=vy(i3)-vy(i2)
1789  dx12=vx(i1)-vx(i2)
1790  dx32=vx(i3)-vx(i2)
1791 
1792  atmp1=atan2(dy12,dx12)
1793  atmp2=atan2(dy32,dx32)
1794  ! IF(ATMP1 < 0.0_SP) ATMP1=ATMP1+2.0_SP*3.1415927_SP
1795  ! IF(ATMP2 < 0.0_SP) ATMP2=ATMP2+2.0_SP*3.1415927_SP
1796  IF(atmp1 < atmp2) atmp1=atmp1+2.0_sp*3.1415927_sp
1797  dxytmp=sqrt(dx12**2+dy12**2)+sqrt(dx32**2+dy32**2)
1798  qarea(i)=0.5_sp*dxytmp*h(inodeq(i))
1799  angleq(i)=(atmp1-atmp2)/2.+atmp2
1800  END DO
1801 
1802  !=====================================
1803  ! CASE EDGE: if the river inflow is on the cell edge
1804  CASE('edge')
1805  !=====================================
1806  DO i=1,numqbc
1807  ii=icellq(i)
1808  IF(isbce(ii) /= 1) THEN
1809 
1810  write(strng,'(I6)') egid(ii)
1811  CALL fatal_error &
1812  & ("You seem to be trying to put a river in the middle of the domain",&
1813  & "The global cell number you selected is: "//trim(adjustl(strng)),&
1814  &"but this is not a solid boundary node?")
1815  END IF
1816  itmp=0
1817  DO j=1,3
1818  IF(nbe(ii,j) == 0) THEN
1819  jtmp=j
1820  itmp=itmp+1
1821  END IF
1822  END DO
1823  IF(itmp /= 1) THEN
1824 
1825  write(strng,'(I6)') egid(ii)
1826  CALL fatal_error &
1827  & ("You have selected an invalide cell for edge based river inflow.",&
1828  & "The global cell number you selected is: "//trim(adjustl(strng)),&
1829  & "This cell has the wrong number of solid boundaries!")
1830  END IF
1831  j1=jtmp+1-int((jtmp+1)/4)*3
1832  j2=jtmp+2-int((jtmp+2)/4)*3
1833  i1=nv(ii,j1)
1834  i2=nv(ii,j2)
1835  n_icellq(i,1)=i1
1836  n_icellq(i,2)=i2
1837  htmp=0.5_sp*(h(i1)+h(i2))
1838  dy12=vy(i1)-vy(i2)
1839  dx12=vx(i1)-vx(i2)
1840  atmp1=atan2(dy12,dx12)
1841  qarea(i)=sqrt(dx12**2+dy12**2)*htmp
1842  angleq(i)=atmp1+3.1415927/2.0
1843  areatmp=art1(i1)+art1(i2)
1844  rdisq(i,1)=art1(i1)/areatmp
1845  rdisq(i,2)=art1(i2)/areatmp
1846  END DO
1847  !=====================================
1848  ! DEFAULT CASE: if the name list has a bad value
1849  CASE DEFAULT
1850  !=====================================
1851  CALL fatal_error("RIVER_INFLOW_LOCATION: NOT CORRECT IN NAMELIST",&
1852  & "SHOULD BE 'node' or 'edge' - It passed River_Discharge: how?")
1853  END SELECT
1854 
1855 
1856  IF(dbg_set(dbg_sbr)) write(ipt,*) "END SET_RIVER_BNDRY_METRICS"
1857 
1858  RETURN
1859  END SUBROUTINE set_river_bndry_metrics
1860  !================================================================
1861  !================================================================
1862  SUBROUTINE set_distribution(NAME,TYPE,LOC,MYDIST)
1863  IMPLICIT NONE
1864  CHARACTER(LEN=*),INTENT(IN) :: name,type
1865  INTEGER, INTENT(IN) :: loc
1866  REAL(sp), INTENT(OUT) :: mydist(kbm1)
1867 
1868  REAL(sp) :: myz(kbm1)
1869  REAL(sp) :: myh,myel
1870 
1871  REAL(sp) :: total
1872 
1873  CHARACTER(LEN=12) :: idx
1874 
1875  ! FOR GET VAL================
1876  INTEGER :: nline, nchar, intval(150), nval
1877  REAL(dp) :: realval(150)
1878  CHARACTER(LEN=40) :: varname
1879  CHARACTER(LEN=80) :: stringval(150)
1880  CHARACTER(LEN=7) :: vartype
1881  LOGICAL :: logval
1882  !============================
1883 
1884  mydist = 0.0_sp
1885 
1886  IF (trim(type)=='node') THEN
1887  mydist = dz(nlid(loc),1:kbm1)
1888  myz = zz(nlid(loc),1:kbm1)
1889  myh = h(nlid(loc))
1890  myel = el(nlid(loc))
1891 
1892  ELSEIF (trim(type)=='edge') THEN
1893  mydist = dz1(elid(loc),1:kbm1)
1894  myz = zz1(elid(loc),1:kbm1)
1895  myh = h1(elid(loc))
1896  myel = el1(elid(loc))
1897  ELSE
1898  CALL fatal_error("BAD RIVER LOCATION (edge OR node) ?")
1899  END IF
1900 
1901  SELECT CASE(name(1:6))
1902  ! UNIFORM FUNCTION
1903  CASE ('unifor')
1904 
1905  ! ALREADY SET VALUES
1906  WRITE(ipt,*) "UNIFORM RIVER DISTRIBUTION",mydist
1907  ! HEAVISIDE FUNCTION
1908  CASE('heavis')
1909 
1910  nline=-1
1911  nchar = len_trim(name)
1912  CALL get_value(nline,nchar,name,varname,vartype,logval&
1913  &,stringval,realval,intval,nval)
1914 
1915  IF(vartype /= "float") THEN
1916  WRITE(idx,*) loc
1917  CALL fatal_error&
1918  &("HEAVISIDE RIVER DISTRIBUTION MUST SET A FLOATING POINT VALUE",&
1919  &"River on "//trim(type)//" number:"//trim(idx))
1920  END IF
1921 
1922  IF(nval>1) CALL fatal_error&
1923  &("COULD NOT READ RIVER DISTRIBUTION STRING?",&
1924  & "BAD STRING:"//trim(name))
1925 
1926  IF(index(varname,'depth')/=0)THEN
1927 
1928 
1929  myz = (myh+myel)*myz+myel
1930 
1931  IF(myz(kbm1) > realval(1) .OR. realval(1) > myz(1)) THEN
1932  WRITE(idx,*) loc
1933  WRITE(ipt,*) "================================"
1934  WRITE(ipt,*) "HEAVISIDE CASE- depth",realval(1)
1935  WRITE(ipt,*) "RIVER DEPTH = ",myh
1936  WRITE(ipt,*) "RIVER SURFACE = ",myel
1937 
1938  CALL fatal_error("RIVER DISTRIBUTION: Depth value out of bounds!",&
1939  & "River on "//trim(type)//" number:"//trim(idx))
1940  END IF
1941 
1942  WRITE(ipt,*) "DEPTH:",myz
1943 
1944  WHERE (myz<realval(1))
1945  mydist = 0.0_sp
1946  END WHERE
1947 
1948  total = sum(mydist)
1949  mydist = mydist/total
1950 
1951  ELSEIF(index(varname,'sigma')/=0)THEN
1952 
1953 
1954  IF(-1.0_sp > realval(1) .OR. realval(1) >0.0_sp) THEN
1955  WRITE(ipt,*) "================================"
1956  WRITE(ipt,*) "HEAVISIDE CASE- sigma",realval(1)
1957  WRITE(idx,*) loc
1958  CALL fatal_error&
1959  &("RIVER DISTRIBUTION: Sigma value out of bounds!",&
1960  & "River on "//trim(type)//" number:"//trim(idx))
1961  END IF
1962 
1963  WHERE (myz<realval(1))
1964  mydist = 0.0_sp
1965  END WHERE
1966 
1967  total = sum(mydist)
1968  mydist = mydist/total
1969 
1970  ELSE
1971 
1972  CALL fatal_error("RIVER DISTRIBUTION: UNKNOWN HEAVISIDE SETTING?",&
1973  & "BAD STRING:"//trim(name))
1974 
1975  END IF
1976  WRITE(ipt,*) "HEAVISIDE RIVER DISTRIBUTION",mydist
1977 
1978  CASE('linear')
1979 
1980 
1981  nline=-1
1982  nchar = len_trim(name)
1983  CALL get_value(nline,nchar,name,varname,vartype,logval&
1984  &,stringval,realval,intval,nval)
1985 
1986  IF(vartype /= "float") THEN
1987  WRITE(idx,*) loc
1988  CALL fatal_error&
1989  &("LINEAR RIVER DISTRIBUTION MUST SET A FLOATING POINT VALUE",&
1990  &"River on "//trim(type)//" number:"//trim(idx))
1991  END IF
1992 
1993  IF(nval>1) CALL fatal_error&
1994  &("COULD NOT READ RIVER DISTRIBUTION STRING?",&
1995  & "BAD STRING:"//trim(name))
1996 
1997  IF(index(varname,'slope')/=0)THEN
1998 
1999  IF(realval(1) <0.0_sp) THEN
2000  WRITE(ipt,*) "================================"
2001  WRITE(ipt,*) "LINEAR CASE- slope",realval(1)
2002  WRITE(idx,*) loc
2003  CALL fatal_error&
2004  &("RIVER DISTRIBUTION: linear slope less than zero!",&
2005  & "River on "//trim(type)//" number:"//trim(idx))
2006  END IF
2007 
2008  myz = (myh+myel)*myz+myel
2009 
2010  myz = myz *mydist * realval(1)
2011 
2012  DO WHILE(sum(myz,myz>0.0_sp)<1.0_sp)
2013  myz=myz + mydist*0.01
2014  END DO
2015 
2016  WHERE (myz > 0.0_sp)
2017  mydist = myz
2018  ELSEWHERE
2019  mydist = 0.0_sp
2020  END WHERE
2021 
2022  total = sum(mydist)
2023  mydist = mydist/total
2024 
2025  ELSE
2026 
2027  CALL fatal_error("RIVER DISTRIBUTION: UNKOWN LINEAR SETTING?",&
2028  & "BAD STRING:"//trim(name))
2029 
2030  END IF
2031 
2032 
2033  WRITE(ipt,*) "LINEAR RIVER DISTRIBUTION",mydist
2034 
2035  CASE DEFAULT
2036 
2037  CALL fatal_error("UNKNOWN RIVER DISTRIBUTION FUNCTION:"//trim(name),&
2038  &"SEE FVCOM MANUAL OR mod_force.F FOR OPTIONS!")
2039 
2040  END SELECT
2041 
2042 
2043  END SUBROUTINE set_distribution
2044 
2045  !================================================================
2046  !================================================================
2047  SUBROUTINE obc_temperature
2048  IMPLICIT NONE
2049  ! SOME NC POINTERS
2050  TYPE(ncatt), POINTER :: att, att_date
2051  TYPE(ncdim), POINTER :: dim
2052  TYPE(ncvar), POINTER :: var
2053  LOGICAL :: found
2054 
2055  INTEGER mynobc
2056  INTEGER, ALLOCATABLE :: myobclist(:)
2057  INTEGER :: mysiglay
2058 
2059  REAL(sp), POINTER :: storage_arr(:,:), storage_vec(:)
2060  INTEGER :: ntimes, i
2061  TYPE(time) :: timetest
2062 
2063  INTEGER :: status
2064 
2065 
2066  IF(dbg_set(dbg_sbr)) write(ipt,*) "START OBC_TEMPERATURE"
2067 
2068  IF (.NOT. obc_temp_nudging) THEN
2069  IF(dbg_set(dbg_log)) write(ipt,*) "! OPEN BOUNDARY TEMPERATURE NUDGING IS OFF!"
2070  obc_t_comments="OPEN BOUNDARY TEMPERATURE NUDGING IS OFF!"
2071  RETURN
2072  END IF
2073 
2074  IF(dbg_set(dbg_log)) write(ipt,*) "! OPEN BOUNDARY TEMPERATURE NUDGING IS ON!"
2075 
2076  obc_t_comments="OPEN BOUNDARY TEMPERATURE NUDGING IS ON!"
2077 
2078  ! FIND THE TIDAL FORCING FILE OBJECT
2079  obc_t_file => find_file(filehead,trim(obc_temp_file),found)
2080  IF(.not. found) CALL fatal_error &
2081  & ("COULD NOT FIND OPEN BOUNDARY CONDITION TEMPERATURE FILE OBJECT",&
2082  & "FILE NAME: "//trim(obc_temp_file))
2083 
2084  att => find_att(obc_t_file,"type",found)
2085  IF(.not. found) CALL fatal_error &
2086  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE FILE OBJECT",&
2087  & "FILE NAME: "//trim(obc_temp_file),&
2088  &"COULD NOT FIND GLOBAL ATTRIBURE: 'type'")
2089 
2090 
2091  SELECT CASE(trim(att%CHR(1)))
2092  !=================================
2093  ! TIME SERIES OBC TEMPERATURE NUDGING DATA
2094  CASE("FVCOM TIME SERIES OBC TS FILE")
2095  !==================================
2096 
2097  obc_t_type = obc_t_sigma
2098 
2099  att => find_att(obc_t_file,"title",found)
2100  IF(found) THEN
2101  obc_t_comments = "Open Boundary Temperature Data: "&
2102  &//trim(att%CHR(1))
2103  ELSE
2104  CALL warning("ATTRIBUTE 'title' IS MISSING IN THE TEMPERATURE NUDGING FILE!")
2105  obc_t_comments = "Open Boundary Temperature Data: UNKOWN SOURCE"
2106  END IF
2107 
2108  ! LOOK FOR THE DIMENSIONS 'nobc' and 'time'
2109  dim => find_dim(obc_t_file,'time',found)
2110  IF(.not. found) CALL fatal_error &
2111  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2112  & "FILE NAME: "//trim(obc_temp_file),&
2113  &"COULD NOT FIND DIMENSION 'time'")
2114 
2115  ntimes = dim%DIM
2116 
2117  dim => find_dim(obc_t_file,'siglay',found)
2118  IF(.not. found) CALL fatal_error &
2119  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2120  & "FILE NAME: "//trim(obc_temp_file),&
2121  &"COULD NOT FIND DIMENSION 'siglay'")
2122 
2123  mysiglay = dim%DIM
2124 
2125  if(kbm1 /= mysiglay) CALL fatal_error&
2126  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2127  & "FILE NAME: "//trim(obc_temp_file),&
2128  &"THE 'siglay' DIMENSION DOES NOT MATCH THE MODEL RUN!")
2129 
2130  dim => find_dim(obc_t_file,'nobc',found)
2131  IF(.not. found) CALL fatal_error &
2132  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2133  & "FILE NAME: "//trim(obc_temp_file),&
2134  &"COULD NOT FIND DIMENSION 'nobc'")
2135 
2136  if(iobcn_gl>0) then
2137  IF(iobcn_gl /= dim%DIM) CALL fatal_error &
2138  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2139  & "FILE NAME: "//trim(obc_temp_file),&
2140  &"THE DIMENSION 'nobc' MUST MATCH THE NUMBER OF OBC NODES")
2141  endif
2142 
2143  ! lOAD GLOBAL OPEN BOUNDARY NOD NUMBER DATA AND COMPARE WITH
2144  ! OBC.DAT/RESTART FILE INPUT
2145  ALLOCATE(myobclist(iobcn))
2146  var => find_var(obc_t_file,'obc_nodes',found)
2147  IF(.not. found) CALL fatal_error &
2148  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2149  & "FILE NAME: "//trim(obc_temp_file),&
2150  &"COULD NOT FIND VARIABLE 'obc_nodes'")
2151  CALL nc_connect_avar(var,myobclist)
2152  CALL nc_read_var(var)
2153 
2154  DO i = 1, iobcn
2155 
2156  IF(serial) THEN
2157  IF(i_obc_n(i) /= myobclist(i)) THEN
2158  write(ipt,*) "NLID(MYOBCLIST)= ", myobclist(i), "; I=",i
2159  write(ipt,*) "I_OBC_N= ", i_obc_n(i), "; I=",i
2160  CALL fatal_error &
2161  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2162  & "FILE NAME: "//trim(obc_temp_file),&
2163  &"THE LIST OF BOUNDARY NODES DOES NOT MATCH")
2164  END IF
2165  ELSE
2166  END IF
2167  END DO
2168 
2169  ! LOAD TIME AND CHECK TO MAKE SURE THE TIME RANGE IS VALID
2170 
2171  timetest = get_file_time(obc_t_file,1)
2172 
2173  IF(timetest > starttime) CALL fatal_error &
2174  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2175  & "FILE NAME: "//trim(obc_temp_file),&
2176  &"THE MODEL RUN STARTS BEFORE THE TEMPERATURE TIME SERIES")
2177 
2178  timetest = get_file_time(obc_t_file,ntimes)
2179 
2180  IF(timetest < endtime) CALL fatal_error &
2181  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2182  & "FILE NAME: "//trim(obc_temp_file),&
2183  &"THE MODEL RUN ENDS AFTER THE TEMPERATURE TIME SERIES")
2184 
2185  var => find_var(obc_t_file,'obc_temp',found)
2186  IF(.not. found) CALL fatal_error &
2187  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2188  & "FILE NAME: "//trim(obc_temp_file),&
2189  &"COULD NOT FIND VARIABLE 'obc_temp'")
2190 
2191  att => find_att(var,'units',found)
2192  IF(.not. found) CALL fatal_error &
2193  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2194  & "FILE NAME: "//trim(obc_temp_file),&
2195  &"COULD NOT FIND TEMP VARIRIABLE'S ATTRIBUTE 'units'")
2196 
2197  if(trim(att%CHR(1)) .NE. 'Celsius' .and. trim(att%CHR(1)) .NE. 'Celcius') CALL fatal_error &
2198  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE NUDGING FILE OBJECT",&
2199  & "FILE NAME: "//trim(obc_temp_file),&
2200  &"TEMP VARIRIABLE ATTRIBUTE 'units' SHOULD BE 'Celsius'")
2201 
2202 
2203 
2204  ! MAKE SPACE FOR THE DATA FROM THE FILE
2205  ALLOCATE(storage_arr(iobcn,kbm1), stat = status)
2206  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN OBC_TEMPERATURE")
2207  obc_t_n => reference_var(var)
2208  CALL nc_connect_pvar(obc_t_n,storage_arr)
2209  NULLIFY(storage_arr)
2210 
2211  ! MAKE SPACE FOR THE DATA FROM THE FILE
2212  ALLOCATE(storage_arr(iobcn,kbm1), stat = status)
2213  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN OBC_TEMPERATURE")
2214  obc_t_p => reference_var(var)
2215  CALL nc_connect_pvar(obc_t_p,storage_arr)
2216  NULLIFY(storage_arr)
2217 
2218 
2219  !=====================================
2220  ! DEFAULT CASE IF GLOBAL ATTRIBUTES OF FILE ARE INCORRECT
2221  CASE DEFAULT
2222  !=====================================
2223  CALL fatal_error &
2224  & ("IN OPEN BOUNDARY CONDITION TEMPERATURE FILE OBJECT",&
2225  & "FILE NAME: "//trim(obc_temp_file),&
2226  &"THE GLOBAL ATTRIBURE 'type' RETURNED UNKNOWN TYPE:",&
2227  & trim(att%CHR(1)))
2228  END SELECT
2229 
2230 
2231  IF(dbg_set(dbg_sbr)) write(ipt,*) "END OBC_TEMPERATURE"
2232 
2233  ! ---------- new: 2016 , april, after Hint by Qi -------------------------
2234  ! Initialize some variables
2235  ! afm 20150914
2236  ! Need initialization. Otherwise, random values are asigned
2237  ! and cause a hanging problem of MPI job in UPDATE_VAR_BRACKET
2238  ! This problem reported with Intel15.0.3.
2239  obc_t_n%curr_stkcnt = 0; obc_t_p%curr_stkcnt = 0
2240  ! ---------- end new ---------------------------------------
2241 
2242  END SUBROUTINE obc_temperature
2243  !================================================================
2244  !================================================================
2245  SUBROUTINE obc_salinity
2246  IMPLICIT NONE
2247  ! SOME NC POINTERS
2248  TYPE(ncatt), POINTER :: att, att_date
2249  TYPE(ncdim), POINTER :: dim
2250  TYPE(ncvar), POINTER :: var
2251  LOGICAL :: found
2252 
2253  INTEGER mynobc
2254  INTEGER, ALLOCATABLE :: myobclist(:)
2255  INTEGER :: mysiglay
2256 
2257  REAL(sp), POINTER :: storage_arr(:,:), storage_vec(:)
2258  INTEGER :: ntimes, i
2259  TYPE(time) :: timetest
2260 
2261  INTEGER :: status
2262 
2263 
2264  IF(dbg_set(dbg_sbr)) write(ipt,*) "START OBC_SALINITY"
2265 
2266  IF (.NOT. obc_salt_nudging) THEN
2267  IF(dbg_set(dbg_log)) write(ipt,*) "! OPEN BOUNDARY SALINITY NUDGING IS OFF!"
2268  obc_s_comments="OPEN BOUNDARY SALINITY NUDGING IS OFF!"
2269  RETURN
2270  END IF
2271 
2272  IF(dbg_set(dbg_log)) write(ipt,*) "! OPEN BOUNDARY SALINITY NUDGING IS ON!"
2273  obc_s_comments="OPEN BOUNDARY SALINITY NUDGING IS ON!"
2274 
2275  ! FIND THE TIDAL FORCING FILE OBJECT
2276  obc_s_file => find_file(filehead,trim(obc_salt_file),found)
2277  IF(.not. found) CALL fatal_error &
2278  & ("COULD NOT FIND OPEN BOUNDARY CONDITION SALINITY FILE OBJECT",&
2279  & "FILE NAME: "//trim(obc_salt_file))
2280 
2281  att => find_att(obc_s_file,"type",found)
2282  IF(.not. found) CALL fatal_error &
2283  & ("IN OPEN BOUNDARY CONDITION SALINITY FILE OBJECT",&
2284  & "FILE NAME: "//trim(obc_salt_file),&
2285  &"COULD NOT FIND GLOBAL ATTRIBURE: 'type'")
2286 
2287 
2288  SELECT CASE(trim(att%CHR(1)))
2289  !=================================
2290  ! TIME SERIES OBC SALINITY NUDGING DATA
2291  CASE("FVCOM TIME SERIES OBC TS FILE")
2292  !==================================
2293 
2294  obc_s_type = obc_s_sigma
2295 
2296  att => find_att(obc_s_file,"title",found)
2297  IF(found) THEN
2298  obc_s_comments = "Open Boundary Salinity Data: "&
2299  &//trim(att%CHR(1))
2300  ELSE
2301  CALL warning("ATTRIBUTE 'title' IS MISSING IN THE SALINITY NUDGING FILE!")
2302  obc_s_comments = "Open Boundary Salinity Data: UNKOWN SOURCE"
2303  END IF
2304 
2305  ! LOOK FOR THE DIMENSIONS 'nobc' and 'time'
2306  dim => find_dim(obc_s_file,'time',found)
2307  IF(.not. found) CALL fatal_error &
2308  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2309  & "FILE NAME: "//trim(obc_salt_file),&
2310  &"COULD NOT FIND DIMENSION 'time'")
2311 
2312  ntimes = dim%DIM
2313 
2314  dim => find_dim(obc_s_file,'siglay',found)
2315  IF(.not. found) CALL fatal_error &
2316  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2317  & "FILE NAME: "//trim(obc_salt_file),&
2318  &"COULD NOT FIND DIMENSION 'siglay'")
2319 
2320  mysiglay = dim%DIM
2321 
2322  if(kbm1 /= mysiglay) CALL fatal_error&
2323  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2324  & "FILE NAME: "//trim(obc_salt_file),&
2325  &"THE 'siglay' DIMENSION DOES NOT MATCH THE MODEL RUN!")
2326 
2327  dim => find_dim(obc_s_file,'nobc',found)
2328  IF(.not. found) CALL fatal_error &
2329  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2330  & "FILE NAME: "//trim(obc_salt_file),&
2331  &"COULD NOT FIND DIMENSION 'nobc'")
2332 
2333  if(iobcn_gl>0) then
2334  IF(iobcn_gl /= dim%DIM) CALL fatal_error &
2335  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2336  & "FILE NAME: "//trim(obc_salt_file),&
2337  &"THE DIMENSION 'nobc' MUST MATCH THE NUMBER OF OBC NODES")
2338  endif
2339 
2340  ! lOAD GLOBAL OPEN BOUNDARY NOD NUMBER DATA AND COMPARE WITH
2341  ! OBC.DAT/RESTART FILE INPUT
2342  ALLOCATE(myobclist(iobcn))
2343  var => find_var(obc_s_file,'obc_nodes',found)
2344  IF(.not. found) CALL fatal_error &
2345  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2346  & "FILE NAME: "//trim(obc_salt_file),&
2347  &"COULD NOT FIND VARIABLE 'obc_nodes'")
2348  CALL nc_connect_avar(var,myobclist)
2349  CALL nc_read_var(var)
2350 
2351  DO i = 1, iobcn
2352 
2353  IF(serial) THEN
2354  IF(i_obc_n(i) /= myobclist(i)) THEN
2355  write(ipt,*) "NLID(MYOBCLIST)= ", myobclist(i), "; I=",i
2356  write(ipt,*) "I_OBC_N= ", i_obc_n(i), "; I=",i
2357  CALL fatal_error &
2358  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2359  & "FILE NAME: "//trim(obc_salt_file),&
2360  &"THE LIST OF BOUNDARY NODES DOES NOT MATCH")
2361  END IF
2362  ELSE
2363  END IF
2364  END DO
2365 
2366  ! LOAD TIME AND CHECK TO MAKE SURE THE TIME RANGE IS VALID
2367 
2368  timetest = get_file_time(obc_s_file,1)
2369 
2370  IF(timetest > starttime) CALL fatal_error &
2371  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2372  & "FILE NAME: "//trim(obc_salt_file),&
2373  &"THE MODEL RUN STARTS BEFORE THE SALINITY TIME SERIES")
2374 
2375  timetest = get_file_time(obc_s_file,ntimes)
2376 
2377 
2378  IF(timetest < endtime) CALL fatal_error &
2379  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2380  & "FILE NAME: "//trim(obc_salt_file),&
2381  &"THE MODEL RUN ENDS AFTER THE SALINITY TIME SERIES")
2382 
2383  var => find_var(obc_s_file,'obc_salinity',found)
2384  IF(.not. found) CALL fatal_error &
2385  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2386  & "FILE NAME: "//trim(obc_salt_file),&
2387  &"COULD NOT FIND VARIABLE 'obc_salinity'")
2388 
2389  att => find_att(var,'units',found)
2390  IF(.not. found) CALL fatal_error &
2391  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2392  & "FILE NAME: "//trim(obc_salt_file),&
2393  &"COULD NOT FIND TEMP VARIRIABLE'S ATTRIBUTE 'units'")
2394 
2395  if(trim(att%CHR(1)) .NE. 'PSU') CALL fatal_error &
2396  & ("IN OPEN BOUNDARY CONDITION SALINITY NUDGING FILE OBJECT",&
2397  & "FILE NAME: "//trim(obc_salt_file),&
2398  &"TEMP VARIRIABLE ATTRIBUTE 'units' SHOULD BE 'PSU'")
2399 
2400 
2401 
2402  ! MAKE SPACE FOR THE DATA FROM THE FILE
2403  ALLOCATE(storage_arr(iobcn,kbm1), stat = status)
2404  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN OBC_SALINITY")
2405  obc_s_n => reference_var(var)
2406  CALL nc_connect_pvar(obc_s_n,storage_arr)
2407  NULLIFY(storage_arr)
2408 
2409  ! MAKE SPACE FOR THE DATA FROM THE FILE
2410  ALLOCATE(storage_arr(iobcn,kbm1), stat = status)
2411  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN OBC_SALINITY")
2412  obc_s_p => reference_var(var)
2413  CALL nc_connect_pvar(obc_s_p,storage_arr)
2414  NULLIFY(storage_arr)
2415 
2416 
2417  !=====================================
2418  ! DEFAULT CASE IF GLOBAL ATTRIBUTES OF FILE ARE INCORRECT
2419  CASE DEFAULT
2420  !=====================================
2421  CALL fatal_error &
2422  & ("IN OPEN BOUNDARY CONDITION SALINITY FILE OBJECT",&
2423  & "FILE NAME: "//trim(obc_salt_file),&
2424  &"THE GLOBAL ATTRIBURE 'type' RETURNED UNKNOWN TYPE:",&
2425  & trim(att%CHR(1)))
2426  END SELECT
2427  ! ---------- new: 2016 , april, after Hint by Qi -------------------------
2428  ! Initialize some variables
2429  ! afm 20150914
2430  ! Need initialization. Otherwise, random values are asigned
2431  ! and cause a hanging problem of MPI job in UPDATE_VAR_BRACKET
2432  ! This problem reported with Intel15.0.3.
2433  obc_s_n%curr_stkcnt = 0; obc_s_p%curr_stkcnt = 0
2434  ! -------- end new ---------------------------------------------
2435 
2436 
2437  IF(dbg_set(dbg_sbr)) write(ipt,*) "END OBC_SALINITY"
2438 
2439  END SUBROUTINE obc_salinity
2440  !================================================================
2441  !================================================================
2442  !================================================================
2443  !================================================================
2444  !================================================================
2445  !================================================================
2446 
2447  ! CURRENTELY NOT IN USE! REPLACEED BY INTERP_BILINEAR WHICH IS A
2448  ! GENERAL INTERPOLATION SCHEME FOR CURVILINEAR COORDINATES
2449 
2450 !!$ SUBROUTINE SET_FILE_INTERP_QUAD(NCF,INTP_N,INTP_C)
2451 !!$ IMPLICIT NONE
2452 !!$ TYPE(NCFILE), POINTER :: NCF
2453 !!$ TYPE(INTERP_WEIGHTS),POINTER :: INTP_N
2454 !!$ TYPE(INTERP_WEIGHTS),POINTER :: INTP_C
2455 !!$
2456 !!$ TYPE(NCATT), POINTER :: ATT
2457 !!$ TYPE(NCDIM), POINTER :: DIM
2458 !!$ TYPE(NCVAR), POINTER :: VAR
2459 !!$
2460 !!$ INTEGER :: LATS, LONS, I, Ntimes
2461 !!$ REAL(SP), POINTER :: XLON(:,:),XLAT(:,:)
2462 !!$ REAL(SP), POINTER :: HEATX(:,:),HEATY(:,:)
2463 !!$ REAL(SP), POINTER :: TMP1(:),TMP2(:)
2464 !!$
2465 !!$ real(sp) :: rzero
2466 !!$
2467 !!$ LOGICAL :: FOUND
2468 !!$
2469 !!$ IF(.NOT. ASSOCIATED(NCF))CALL FATAL_ERROR&
2470 !!$ & ("SET_FILE_INTERP: FILE OBJECT ARGUMENT IS NOT ASSOCIATED!")
2471 !!$
2472 !!$ ! EITHER BOTH WEIGHTS MUST ALREADY BE SET OR NONE
2473 !!$ IF(ASSOCIATED(NCF%INTERP_N)) THEN
2474 !!$ IF(ASSOCIATED(NCF%INTERP_C)) THEN
2475 !!$ INTP_N => NCF%INTERP_N
2476 !!$ INTP_C => NCF%INTERP_C
2477 !!$ RETURN
2478 !!$ ELSE
2479 !!$ CALL PRINT_FILE(NCF)
2480 !!$ CALL FATAL_ERROR("ONLY ONE INTERP POINTER IS ASSOCAITED IN THIS FILE",&
2481 !!$ & "SET_FILE_INTERP: IS NOT PREPARED TO HANDLE THIS.")
2482 !!$ END IF
2483 !!$ ELSE
2484 !!$ IF(ASSOCIATED(NCF%INTERP_C))THEN
2485 !!$ CALL PRINT_FILE(NCF)
2486 !!$ CALL FATAL_ERROR("ONLY ONE INTERP POINTER IS ASSOCAITED IN THIS FILE",&
2487 !!$ & "SET_FILE_INTERP: IS NOT PREPARED TO HANDLE THIS.")
2488 !!$ END IF
2489 !!$
2490 !!$ END IF
2491 !!$
2492 !!$
2493 !!$ ATT => FIND_ATT(NCF,'DX',FOUND)
2494 !!$ IF(.not. FOUND) CALL FATAL_ERROR &
2495 !!$ & ( "SET_FILE_INTERP:",&
2496 !!$ & "FILE NAME: "//TRIM(NCF%FNAME),&
2497 !!$ & "COULD NOT FIND ATTRIBUTE 'DX'")
2498 !!$
2499 !!$ rzero = att%flt(1)
2500 !!$
2501 !!$ DIM => FIND_DIM(NCF,'south_north',FOUND)
2502 !!$ IF(.not. FOUND) CALL FATAL_ERROR &
2503 !!$ & ("SET_FILE_INTERP:",&
2504 !!$ & "FILE NAME: "//TRIM(NCF%FNAME),&
2505 !!$ & "COULD NOT FIND DIMENSION 'south_north'")
2506 !!$
2507 !!$ LATS = DIM%DIM
2508 !!$
2509 !!$ DIM => FIND_DIM(NCF,'west_east',FOUND)
2510 !!$ IF(.not. FOUND) CALL FATAL_ERROR &
2511 !!$ & ("SET_FILE_INTERP:",&
2512 !!$ & "FILE NAME: "//TRIM(NCF%FNAME),&
2513 !!$ & "COULD NOT FIND DIMENSION 'west_east'")
2514 !!$ LONS = DIM%DIM
2515 !!$
2516 !!$
2517 !!$ ! GET THE INTERPOLATION COEFFICIENTS
2518 !!$ ALLOCATE(XLON(lons,lats))
2519 !!$ ALLOCATE(XLAT(lons,lats))
2520 !!$
2521 !!$ VAR => FIND_VAR(NCF,"XLAT",FOUND)
2522 !!$ IF(.not. FOUND) CALL FATAL_ERROR &
2523 !!$ & ("SET_FILE_INTERP:",&
2524 !!$ & "FILE NAME: "//TRIM(NCF%FNAME),&
2525 !!$ & "COULD NOT FIND VARIABLE 'XLAT'")
2526 !!$
2527 !!$ CALL NC_CONNECT_PVAR(VAR,XLAT)
2528 !!$ CALL NC_READ_VAR(VAR)
2529 !!$
2530 !!$
2531 !!$ VAR => FIND_VAR(NCF,"XLONG",FOUND)
2532 !!$ IF(.not. FOUND) CALL FATAL_ERROR &
2533 !!$ & ("SET_FILE_INTERP:",&
2534 !!$ & "FILE NAME: "//TRIM(NCF%FNAME),&
2535 !!$ & "COULD NOT FIND VARIABLE 'XLONG'")
2536 !!$
2537 !!$ CALL NC_CONNECT_PVAR(VAR,XLON)
2538 !!$ CALL NC_READ_VAR(VAR)
2539 !!$
2540 !!$# if !defined(SPHERICAL)
2541 !!$ ALLOCATE(HEATX(lons,lats))
2542 !!$ ALLOCATE(HEATY(lons,lats))
2543 !!$
2544 !!$ IF (.NOT. USE_PROJ) CALL FATAL_ERROR('PROJ IS NEEDED TO USE T&
2545 !!$ &HIS TYPE OF FORCING FILE IN CARTESIAN MODE:',&
2546 !!$ & ' RECOMPILE WITH projection 4')
2547 !!$
2548 !!$ CALL DEGREES2METERS(XLON,XLAT,PROJECTION_REFERENCE,HEATX,HEATY,lons,lats)
2549 !!$
2550 !!$ DEALLOCATE(XLAT,XLON)
2551 !!$# else
2552 !!$ HEATX => XLON
2553 !!$ HEATY => XLAT
2554 !!$
2555 !!$ NULLIFY(XLON)
2556 !!$ NULLIFY(XLAT)
2557 !!$# endif
2558 !!$ TMP1 => XM
2559 !!$ TMP2 => YM
2560 !!$ ALLOCATE(INTP_N)
2561 !!$ CALL SETUP_INTERP_QUAD_P(HEATX,HEATY,TMP1,TMP2,INTP_N,rzero)
2562 !!$
2563 !!$ TMP1 => XMC
2564 !!$ TMP2 => YMC
2565 !!$
2566 !!$ ALLOCATE(INTP_C)
2567 !!$ CALL SETUP_INTERP_QUAD_P(HEATX,HEATY,TMP1,TMP2,INTP_C,rzero)
2568 !!$
2569 !!$ ! THIS SHOULD DEALLOCATE HEATX,HEATY FOR NON SPHERICAL
2570 !!$ ! THIS SHOULD DEALLOCATE HEATX,HEATY WHICH ARE POINTED AT
2571 !!$ ! XLONS AND XLATS IN THE SHPERICAL CASE
2572 !!$ DEALLOCATE(HEATX, HEATY)
2573 !!$
2574 !!$
2575 !!$ NCF%INTERP_N => INTP_N
2576 !!$ NCF%INTERP_C => INTP_C
2577 !!$
2578 !!$ END SUBROUTINE SET_FILE_INTERP_QUAD
2579  !================================================================
2580  SUBROUTINE set_file_interp_bilinear(NCF,INTP_N,INTP_C,MASK_VAR_NAME)
2581  IMPLICIT NONE
2582  TYPE(ncfile), POINTER :: ncf
2583  TYPE(interp_weights),POINTER :: intp_n
2584  TYPE(interp_weights),POINTER :: intp_c
2585 
2586  TYPE(ncatt), POINTER :: att
2587  TYPE(ncdim), POINTER :: dim
2588  TYPE(ncvar), POINTER :: var
2589 
2590  INTEGER :: lats, lons, i, ntimes,j, ierr
2591  REAL(sp), POINTER :: xlon(:,:),xlat(:,:)
2592  REAL(sp), POINTER :: heatx(:,:),heaty(:,:)
2593  REAL(sp), POINTER :: tmp1(:),tmp2(:)
2594 
2595 
2596  CHARACTER(LEN=80), OPTIONAL :: mask_var_name
2597  REAL(sp), POINTER :: fmask(:,:)
2598  INTEGER, POINTER :: mask(:,:)
2599 
2600 
2601  LOGICAL :: found
2602 
2603  IF(.NOT. ASSOCIATED(ncf))CALL fatal_error&
2604  & ("SET_FILE_INTERP: FILE OBJECT ARGUMENT IS NOT ASSOCIATED!")
2605 
2606  ! EITHER BOTH WEIGHTS MUST ALREADY BE SET OR NONE
2607  IF(ASSOCIATED(ncf%INTERP_N)) THEN
2608  IF(ASSOCIATED(ncf%INTERP_C)) THEN
2609  intp_n => ncf%INTERP_N
2610  intp_c => ncf%INTERP_C
2611  RETURN
2612  ELSE
2613  CALL print_file(ncf)
2614  CALL fatal_error("ONLY ONE INTERP POINTER IS ASSOCAITED IN THIS FILE",&
2615  & "SET_FILE_INTERP: IS NOT PREPARED TO HANDLE THIS.")
2616  END IF
2617  ELSE
2618  IF(ASSOCIATED(ncf%INTERP_C))THEN
2619  CALL print_file(ncf)
2620  CALL fatal_error("ONLY ONE INTERP POINTER IS ASSOCAITED IN THIS FILE",&
2621  & "SET_FILE_INTERP: IS NOT PREPARED TO HANDLE THIS.")
2622  END IF
2623 
2624  END IF
2625 
2626 
2627  dim => find_dim(ncf,'south_north',found)
2628  IF(.not. found) CALL fatal_error &
2629  & ("SET_FILE_INTERP:",&
2630  & "FILE NAME: "//trim(ncf%FNAME),&
2631  & "COULD NOT FIND DIMENSION 'south_north'")
2632 
2633  lats = dim%DIM
2634 
2635  dim => find_dim(ncf,'west_east',found)
2636  IF(.not. found) CALL fatal_error &
2637  & ("SET_FILE_INTERP:",&
2638  & "FILE NAME: "//trim(ncf%FNAME),&
2639  & "COULD NOT FIND DIMENSION 'west_east'")
2640  lons = dim%DIM
2641 
2642 
2643  ! GET THE INTERPOLATION COEFFICIENTS
2644  ALLOCATE(xlon(lons,lats))
2645  ALLOCATE(xlat(lons,lats))
2646 
2647  var => find_var(ncf,"XLAT",found)
2648  IF(.not. found) CALL fatal_error &
2649  & ("SET_FILE_INTERP:",&
2650  & "FILE NAME: "//trim(ncf%FNAME),&
2651  & "COULD NOT FIND VARIABLE 'XLAT'")
2652 
2653  CALL nc_connect_pvar(var,xlat)
2654  CALL nc_read_var(var)
2655 
2656 
2657  var => find_var(ncf,"XLONG",found)
2658  IF(.not. found) CALL fatal_error &
2659  & ("SET_FILE_INTERP:",&
2660  & "FILE NAME: "//trim(ncf%FNAME),&
2661  & "COULD NOT FIND VARIABLE 'XLONG'")
2662 
2663  CALL nc_connect_pvar(var,xlon)
2664  CALL nc_read_var(var)
2665 
2666  ALLOCATE(heatx(lons,lats))
2667  ALLOCATE(heaty(lons,lats))
2668 
2669  IF (.NOT. use_proj) CALL fatal_error('PROJ IS NEEDED TO USE T&
2670  &HIS TYPE OF FORCING FILE IN CARTESIAN MODE:',&
2671  & ' RECOMPILE WITH projection 4')
2672  IF(msr) CALL degrees2meters(xlon,xlat,projection_reference,heatx,heaty,lons,lats)
2673 
2674  DEALLOCATE(xlat,xlon)
2675 
2676 !!$ THIS IS VERY SLOW - LOAD DATA FROM A FILE IF NEEDED
2677 !!$ ! MAKE A LAND MASK
2678 !!$ ALLOCATE(MASK(lons,lats))
2679 !!$ DO I = 1,lons
2680 !!$ DO J = 1,lats
2681 !!$ MASK(i,j) = FIND_ELEMENT_CONTAINING(HEATX(i,j)-vxmin,HEATY(i,j)-vymin)
2682 !!$ END DO
2683 !!$ END DO
2684 !!$ WHERE (MASK >0)
2685 !!$ MASK = 0
2686 !!$ elsewhere
2687 !!$ MASK = 1
2688 !!$ END WHERE
2689 
2690 
2691  IF (PRESENT(mask_var_name))THEN
2692  var => find_var(ncf,mask_var_name,found)
2693  IF(.not. found) CALL fatal_error &
2694  & ("SET_FILE_INTERP:",&
2695  & "FILE NAME: "//trim(ncf%FNAME),&
2696  & "COULD NOT FIND VARIABLE 'XLONG'")
2697 
2698 
2699  select case(var%XTYPE)
2700  case(nf90_int)
2701  ALLOCATE(mask(lons,lats))
2702  CALL nc_connect_pvar(var,mask)
2703  CALL nc_read_var(var)
2704 
2705  case(nf90_float)
2706  ALLOCATE(mask(lons,lats))
2707  ALLOCATE(fmask(lons,lats))
2708  CALL nc_connect_pvar(var,fmask)
2709  CALL nc_read_var(var)
2710  mask = anint(fmask)
2711  deallocate(fmask)
2712 
2713  case default
2714  call fatal_error("SET_FILE_INTERP_BILINEAR: Unknown mask variable xtype?")
2715  END select
2716 
2717  tmp1 => vx
2718  tmp2 => vy
2719 
2720  tmp1 = tmp1 + vxmin
2721  tmp2 = tmp2 + vymin
2722 
2723  ALLOCATE(intp_n)
2724  CALL setup_interp_bilinear_p(heatx,heaty,tmp1,tmp2,intp_n,mask)
2725 
2726  tmp1 = tmp1 - vxmin
2727  tmp2 = tmp2 - vymin
2728 
2729  tmp1 => xc
2730  tmp2 => yc
2731 
2732  tmp1 = tmp1 + vxmin
2733  tmp2 = tmp2 + vymin
2734 
2735  ALLOCATE(intp_c)
2736  CALL setup_interp_bilinear_p(heatx,heaty,tmp1,tmp2,intp_c,mask)
2737 
2738  tmp1 = tmp1 - vxmin
2739  tmp2 = tmp2 - vymin
2740 
2741  ELSE
2742 
2743 
2744  tmp1 => vx
2745  tmp2 => vy
2746 
2747  tmp1 = tmp1 + vxmin
2748  tmp2 = tmp2 + vymin
2749 
2750  ! NO MASK
2751  ALLOCATE(intp_n)
2752  CALL setup_interp_bilinear_p(heatx,heaty,tmp1,tmp2,intp_n)
2753 
2754  tmp1 = tmp1 - vxmin
2755  tmp2 = tmp2 - vymin
2756 
2757  tmp1 => xc
2758  tmp2 => yc
2759 
2760  tmp1 = tmp1 + vxmin
2761  tmp2 = tmp2 + vymin
2762 
2763  ALLOCATE(intp_c)
2764  CALL setup_interp_bilinear_p(heatx,heaty,tmp1,tmp2,intp_c)
2765 
2766  tmp1 = tmp1 - vxmin
2767  tmp2 = tmp2 - vymin
2768 
2769  END IF
2770 
2771  ! THIS SHOULD DEALLOCATE HEATX,HEATY FOR NON SPHERICAL
2772  ! THIS SHOULD DEALLOCATE HEATX,HEATY WHICH ARE POINTED AT
2773  ! XLONS AND XLATS IN THE SHPERICAL CASE
2774  DEALLOCATE(heatx, heaty)
2775 
2776 
2777  ncf%INTERP_N => intp_n
2778  ncf%INTERP_C => intp_c
2779 
2780  END SUBROUTINE set_file_interp_bilinear
2781  !================================================================
2782  !================================================================
2783  SUBROUTINE surface_heating
2784  IMPLICIT NONE
2785  ! SOME NC POINTERS
2786  TYPE(ncatt), POINTER :: att, att_date
2787  TYPE(ncdim), POINTER :: dim
2788  TYPE(ncvar), POINTER :: var
2789  LOGICAL :: found
2790 
2791  REAL(sp), POINTER :: storage_arr(:,:), storage_vec(:)
2792  CHARACTER(len=60) :: swrstrng, nhfstrng
2793  TYPE(time) :: timetest
2794 
2795  INTEGER :: lats, lons, i, ntimes
2796 
2797  INTEGER :: status
2798 
2799  IF(dbg_set(dbg_sbr)) write(ipt,*) "START SURFACE_HEATING"
2800 
2801  NULLIFY(att,dim,var,storage_arr,storage_vec)
2802 
2803  IF (.NOT. heating_on ) THEN
2804  IF(dbg_set(dbg_log)) write(ipt,*) "! SURFACE HEAT FORCING IS OFF!"
2805  ALLOCATE(heat_forcing_comments(1))
2806  heat_forcing_comments(1) = "SURFACE HEAT FORCING IS OFF"
2807  RETURN
2808  END IF
2809 
2810 
2811  ! DETERMINE HOW TO LOAD THE DATA
2812  SELECT CASE(heating_kind)
2813  CASE (cnstnt)
2814 
2815  write(swrstrng,'(f8.4)') heating_radiation
2816  write(nhfstrng,'(f8.4)') heating_netflux
2817 
2818  IF(dbg_set(dbg_log)) THEN
2819  WRITE(ipt,*)"! SETTING UP CONSTANT HEAT FORCING: "
2820  WRITE(ipt,*)" Radiation: "//trim(swrstrng)
2821  WRITE(ipt,*)" Net Heat Flux: "//trim(nhfstrng)
2822  END IF
2823 
2824  ALLOCATE(heat_forcing_comments(3))
2825  heat_forcing_comments(1) = "Using constant heating from run file:"
2826  heat_forcing_comments(2) = "Radiation:"//trim(swrstrng)
2827  heat_forcing_comments(3) = "Net Heat Flux:"//trim(nhfstrng)
2828  RETURN
2829 
2830  CASE(sttc)
2831 
2832  CALL fatal_error("STATIC HEATING Not Set Up Yet")
2833 
2834  CASE(tmdpndnt)
2835 
2836  CALL fatal_error("TIME DEPENDANT HEATING Not Set Up Yet")
2837 
2838  CASE(prdc)
2839 
2840  heat_file => find_file(filehead,trim(heating_file),found)
2841  IF(.not. found) CALL fatal_error &
2842  & ("COULD NOT FIND SURFACE HEATING BOUNDARY CONDINTION FILE OBJECT",&
2843  & "FILE NAME: "//trim(heating_file))
2844 
2845  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
2846  att => find_att(heat_file,"source",found)
2847  IF(.not. found) att => find_att(heat_file,"Source",found)
2848  IF(.not. found) CALL fatal_error &
2849  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
2850  & "FILE NAME: "//trim(heating_file),&
2851  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
2852 
2853  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
2854  & trim(wrf2fvcom_source)) THEN
2855  heat_forcing_type = heat_is_wrfgrid
2856 
2857  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
2858  & trim(fvcom_grid_source)) THEN
2859  heat_forcing_type = heat_is_fvcomgrid
2860 
2861  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
2862  & trim(fvcom_cap_grid_source)) THEN
2863  heat_forcing_type = heat_is_fvcomgrid
2864 
2865  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
2866  & trim(wrf_grid_source)) THEN
2867  heat_forcing_type = heat_is_wrfgrid
2868 
2869  ELSE
2870  CALL print_file(heat_file)
2871  CALL fatal_error("CAN NOT RECOGNIZE HEATING FILE!",&
2872  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
2873  END IF
2874  ! GOT GRID TYPE
2875 
2876  ALLOCATE(heat_forcing_comments(4))
2877  heat_forcing_comments(1) = "FVCOM periodic surface heat forcing:"
2878  heat_forcing_comments(2) = "FILE NAME:"//trim(heating_file)
2879 
2880  heat_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
2881 
2882  att_date => find_att(heat_file,"START_DATE",found)
2883  IF (found) THEN
2884  heat_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
2885  ELSE
2886  heat_forcing_comments(4) = "Unknown start date meta data format"
2887  END IF
2888 
2889  ! GET THE FILES LENGTH OF TIME AND SAVE FOR PERIODIC FORCING
2890 
2891  ! LOOK FOR THE DIMENSIONS
2892  dim => find_unlimited(heat_file,found)
2893  IF(.not. found) CALL fatal_error &
2894  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
2895  & "FILE NAME: "//trim(heating_file),&
2896  &"COULD NOT FIND THE UNLIMITED DIMENSION")
2897 
2898  ntimes = dim%DIM
2899 
2900  heat_period = get_file_time(heat_file,ntimes)
2901 
2902  heat_period = heat_period - get_file_time(heat_file,1)
2903 
2904 
2905  IF (heat_period /= get_file_time(heat_file,ntimes)) THEN
2906 
2907  CALL print_real_time(get_file_time(heat_file,1),ipt,"FIRST FILE TIME",timezone)
2908  CALL print_real_time(get_file_time(heat_file,ntimes),ipt,"LAST FILE TIME",timezone)
2909 
2910  CALL fatal_error&
2911  &("TO USE PERIODIC FORCING THE FILE TIME MUST COUNT FROM ZERO",&
2912  & "THE DIFFERENCE BETWEEN THE CURRENT MODEL TIME AND THE START TIME,",&
2913  & "MODULO THE FORCING PERIOD, DETERMINES THE CURRENT FORCING")
2914  END IF
2915 
2916 
2917  IF(dbg_set(dbg_log)) THEN
2918  WRITE(ipt,*) "! USING PERIODIC HEAT FORCING:"
2919  CALL print_time(heat_period,ipt,"PERIOD")
2920  END IF
2921 
2922  CASE(vrbl)
2923 
2924  heat_file => find_file(filehead,trim(heating_file),found)
2925  IF(.not. found) CALL fatal_error &
2926  & ("COULD NOT FIND SURFACE HEATING BOUNDARY CONDINTION FILE OBJECT",&
2927  & "FILE NAME: "//trim(heating_file))
2928 
2929  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
2930  att => find_att(heat_file,"source",found)
2931  IF(.not. found) att => find_att(heat_file,"Source",found)
2932  IF(.not. found) CALL fatal_error &
2933  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
2934  & "FILE NAME: "//trim(heating_file),&
2935  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
2936 
2937  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
2938  & trim(wrf2fvcom_source)) THEN
2939  heat_forcing_type = heat_is_wrfgrid
2940 
2941  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
2942  & trim(fvcom_grid_source)) THEN
2943  heat_forcing_type = heat_is_fvcomgrid
2944 
2945  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
2946  & trim(fvcom_cap_grid_source)) THEN
2947  heat_forcing_type = heat_is_fvcomgrid
2948 
2949  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
2950  & trim(wrf_grid_source)) THEN
2951  heat_forcing_type = heat_is_wrfgrid
2952 
2953  ELSE
2954  CALL print_file(heat_file)
2955  CALL fatal_error("CAN NOT RECOGNIZE HEATING FILE!",&
2956  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
2957  END IF
2958  ! GOT GRID TYPE
2959 
2960  ALLOCATE(heat_forcing_comments(4))
2961  heat_forcing_comments(1) = "FVCOM variable surface heat forcing file:"
2962 
2963  heat_forcing_comments(2) = "FILE NAME:"//trim(heating_file)
2964  heat_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
2965 
2966  att_date => find_att(heat_file,"START_DATE",found)
2967  IF (found) THEN
2968  heat_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
2969  ELSE
2970  heat_forcing_comments(4) = "Unknown start date meta data format"
2971  END IF
2972 
2973  ! CHECK DIMENSIONS
2974  dim => find_unlimited(heat_file,found)
2975  IF(.not. found) CALL fatal_error &
2976  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
2977  & "FILE NAME: "//trim(heating_file),&
2978  &"COULD NOT FIND UNLIMITED DIMENSION")
2979 
2980  ntimes = dim%DIM
2981 
2982  ! CHECK THE FILE TIME AND COMPARE WITH MODEL RUN TIME
2983  timetest = get_file_time(heat_file,1)
2984  IF(timetest > starttime) CALL fatal_error &
2985  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
2986  & "FILE NAME: "//trim(heating_file),&
2987  &"THE MODEL RUN STARTS BEFORE THE FORCING TIME SERIES")
2988 
2989  timetest = get_file_time(heat_file,ntimes)
2990  IF(timetest < endtime) CALL fatal_error &
2991  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
2992  & "FILE NAME: "//trim(heating_file),&
2993  &"THE MODEL RUN ENDS AFTER THE FORCING TIME SERIES")
2994 
2995  CASE DEFAULT
2996  CALL fatal_error("SURFACE_HEATING: UNKNOWN HEATING KIND?")
2997  END SELECT
2998 
2999 
3000 
3001  !==================================================================
3002  SELECT CASE(heat_forcing_type)
3003  !==================================================================
3004  CASE(heat_is_wrfgrid)
3005  !==================================================================
3006 
3007  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
3008  & "! SETTING UP HEAT FORCING FROM A 'wrf grid' FILE"
3009 
3010  ! LOOK FOR THE DIMENSIONS
3011  dim => find_dim(heat_file,'south_north',found)
3012  IF(.not. found) CALL fatal_error &
3013  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
3014  & "FILE NAME: "//trim(heating_file),&
3015  & "COULD NOT FIND DIMENSION 'south_north'")
3016 
3017  lats = dim%DIM
3018 
3019  dim => find_dim(heat_file,'west_east',found)
3020  IF(.not. found) CALL fatal_error &
3021  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
3022  & "FILE NAME: "//trim(heating_file),&
3023  & "COULD NOT FIND DIMENSION 'west_east'")
3024  lons = dim%DIM
3025 
3026 
3027  CALL set_file_interp_bilinear(heat_file,heat_intp_n,heat_intp_c)
3028 
3029  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
3030 
3031  ! SHORT WAVE RADIATION DATA
3032  var => find_var(heat_file,"short_wave",found)
3033  IF(.not. found) var => find_var(heat_file,"Shortwave",found)
3034  IF(.not. found) CALL fatal_error &
3035  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
3036  & "FILE NAME: "//trim(heating_file),&
3037  & "COULD NOT FIND VARIABLE 'short_wave'")
3038 
3039  ! MAKE SPACE FOR THE DATA FROM THE FILE
3040  ALLOCATE(storage_arr(lons,lats), stat = status)
3041  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3042  heat_swv_n => reference_var(var)
3043  CALL nc_connect_pvar(heat_swv_n,storage_arr)
3044  NULLIFY(storage_arr)
3045 
3046  ! MAKE SPACE FOR THE INTERPOLATED DATA
3047  ALLOCATE(storage_vec(0:mt), stat = status)
3048  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3049  CALL nc_connect_pvar(heat_swv_n,storage_vec)
3050  NULLIFY(storage_vec)
3051 
3052 
3053  ! MAKE SPACE FOR THE DATA FROM THE FILE
3054  ALLOCATE(storage_arr(lons,lats), stat = status)
3055  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3056  heat_swv_p => reference_var(var)
3057  CALL nc_connect_pvar(heat_swv_p,storage_arr)
3058  NULLIFY(storage_arr)
3059 
3060  ! MAKE SPACE FOR THE INTERPOLATED DATA
3061  ALLOCATE(storage_vec(0:mt), stat = status)
3062  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3063  CALL nc_connect_pvar(heat_swv_p,storage_vec)
3064  NULLIFY(storage_vec)
3065 
3066  ! NET HEAT FLUX DATA
3067  var => find_var(heat_file,"net_heat_flux",found)
3068  IF(.not. found) var => find_var(heat_file,"Net_Heat",found)
3069  IF(.not. found) CALL fatal_error &
3070  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
3071  & "FILE NAME: "//trim(heating_file),&
3072  & "COULD NOT FIND VARIABLE 'net_heat_flux'")
3073 
3074  ! MAKE SPACE FOR THE DATA FROM THE FILE
3075  ALLOCATE(storage_arr(lons,lats), stat = status)
3076  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3077  heat_net_n => reference_var(var)
3078  CALL nc_connect_pvar(heat_net_n,storage_arr)
3079  NULLIFY(storage_arr)
3080 
3081  ! MAKE SPACE FOR THE INTERPOLATED DATA
3082  ALLOCATE(storage_vec(0:mt), stat = status)
3083  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3084  CALL nc_connect_pvar(heat_net_n,storage_vec)
3085  NULLIFY(storage_vec)
3086 
3087 
3088  ! MAKE SPACE FOR THE DATA FROM THE FILE
3089  ALLOCATE(storage_arr(lons,lats), stat = status)
3090  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3091  heat_net_p => reference_var(var)
3092  CALL nc_connect_pvar(heat_net_p,storage_arr)
3093  NULLIFY(storage_arr)
3094 
3095  ! MAKE SPACE FOR THE INTERPOLATED DATA
3096  ALLOCATE(storage_vec(0:mt), stat = status)
3097  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3098  CALL nc_connect_pvar(heat_net_p,storage_vec)
3099  NULLIFY(storage_vec)
3100 
3101  !==================================================================
3102  CASE(heat_is_fvcomgrid)
3103  !==================================================================
3104 
3105  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
3106  & "! SETTING UP HEAT FORCING FROM A 'fvcom grid' FILE"
3107 
3108  ! LOOK FOR THE DIMENSIONS
3109  dim => find_dim(heat_file,'node',found)
3110  IF(.not. found) CALL fatal_error &
3111  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
3112  & "FILE NAME: "//trim(heating_file),&
3113  & "COULD NOT FIND DIMENSION 'node'")
3114 
3115  if (mgl /= dim%dim) CALL fatal_error&
3116  &("Surface Heating: the number of nodes in the file does not match the fvcom grid?")
3117 
3118 
3119  dim => find_dim(heat_file,'nele',found)
3120  IF(.not. found) CALL fatal_error &
3121  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
3122  & "FILE NAME: "//trim(heating_file),&
3123  & "COULD NOT FIND DIMENSION 'nele'")
3124 
3125  if (ngl /= dim%dim) CALL fatal_error&
3126  &("Surface Heating: the number of elements in the file does not match the fvcom grid?")
3127 
3128  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
3129 
3130  ! SHORT WAVE RADIATION DATA
3131  var => find_var(heat_file,"short_wave",found)
3132  IF(.not. found) CALL fatal_error &
3133  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
3134  & "FILE NAME: "//trim(heating_file),&
3135  & "COULD NOT FIND VARIABLE 'short_wave'")
3136 
3137  ! MAKE SPACE FOR THE DATA FROM THE FILE
3138  heat_swv_n => reference_var(var)
3139  ALLOCATE(storage_vec(0:mt), stat = status)
3140  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3141  CALL nc_connect_pvar(heat_swv_n,storage_vec)
3142  NULLIFY(storage_vec)
3143 
3144 
3145  ! MAKE SPACE FOR THE DATA FROM THE FILE
3146  heat_swv_p => reference_var(var)
3147  ALLOCATE(storage_vec(0:mt), stat = status)
3148  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3149  CALL nc_connect_pvar(heat_swv_p,storage_vec)
3150  NULLIFY(storage_vec)
3151 
3152  ! NET HEAT FLUX DATA
3153  var => find_var(heat_file,"net_heat_flux",found)
3154  IF(.not. found) CALL fatal_error &
3155  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
3156  & "FILE NAME: "//trim(heating_file),&
3157  & "COULD NOT FIND VARIABLE 'net_heat_flux'")
3158 
3159  ! MAKE SPACE FOR THE DATA FROM THE FILE
3160  heat_net_n => reference_var(var)
3161  ALLOCATE(storage_vec(0:mt), stat = status)
3162  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3163  CALL nc_connect_pvar(heat_net_n,storage_vec)
3164  NULLIFY(storage_vec)
3165 
3166 
3167  ! MAKE SPACE FOR THE DATA FROM THE FILE
3168  heat_net_p => reference_var(var)
3169  ALLOCATE(storage_vec(0:mt), stat = status)
3170  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE HEATING")
3171  CALL nc_connect_pvar(heat_net_p,storage_vec)
3172  NULLIFY(storage_vec)
3173 
3174  !==================================================================
3175  CASE DEFAULT
3176  !==================================================================
3177  CALL fatal_error("CAN NOT RECOGNIZE HEATING FILE TYPE!")
3178  !==================================================================
3179  END SELECT
3180  !==================================================================
3181 
3182  ! ---------- new: 2016 , april, after Hint by Qi -------------------------
3183  ! Initialize some variables
3184  ! afm 20150914
3185  ! Need initialization. Otherwise, random values are asigned
3186  ! and cause a hanging problem of MPI job in UPDATE_VAR_BRACKET
3187  ! This problem reported with Intel15.0.3.
3188  heat_net_n%curr_stkcnt=0
3189  heat_net_p%curr_stkcnt=0
3190  heat_swv_n%curr_stkcnt=0
3191  heat_swv_p%curr_stkcnt=0
3192  ! -------- end new ----------------------------------------------
3193 
3194  IF(dbg_set(dbg_sbr)) write(ipt,*) "END SURFACE_HEATING"
3195  END SUBROUTINE surface_heating
3196  !================================================================
3197  !================================================================
3198 !========================================================================
3199 !========================================================================
3200  !================================================================
3201  !================================================================
3202  SUBROUTINE ice_model_forcing
3203  IMPLICIT NONE
3204  ! SOME NC POINTERS
3205  TYPE(ncatt), POINTER :: att, att_date
3206  TYPE(ncdim), POINTER :: dim
3207  TYPE(ncvar), POINTER :: var
3208  LOGICAL :: found
3209 
3210  REAL(sp), POINTER :: storage_arr(:,:), storage_vec(:)
3211  CHARACTER(len=60) :: satstrng, slpstrng,spqstrng,cldstrng, swvstrng
3212  TYPE(time) :: timetest
3213 
3214  INTEGER :: lats, lons, i, ntimes
3215 
3216  INTEGER :: status
3217 
3218  IF(dbg_set(dbg_sbr)) write(ipt,*) "START ICE MODEL FORCING"
3219 
3220  NULLIFY(att,dim,var,storage_arr,storage_vec)
3221 
3222  IF (.NOT. ice_model) THEN
3223  IF(dbg_set(dbg_log)) write(ipt,*) "! ICE MODEL IS OFF!"
3224 
3225  ALLOCATE(ice_forcing_comments(1))
3226  ice_forcing_comments(1) = "ICE MODEL FORCING IS OFF"
3227  RETURN
3228  END IF
3229 
3230 
3231  ! DETERMINE HOW TO LOAD THE DATA
3232  SELECT CASE(ice_forcing_kind)
3233  CASE (cnstnt)
3234 
3235 
3236  ALLOCATE(ice_forcing_comments(6))
3237  write(satstrng,'(f8.4)') ice_air_temp
3238  write(spqstrng,'(f8.4)') ice_spec_humidity
3239  write(cldstrng,'(f8.4)') ice_cloud_cover
3240  write(swvstrng,'(f8.4)') ice_shortwave
3241 
3242 
3243  ice_forcing_comments(1) = "Using constant ice forcing:"
3244  ice_forcing_comments(2) = "Sea Leval Air Temp="//trim(satstrng)
3245  ice_forcing_comments(4) = "Specific Humidity="//trim(spqstrng)
3246  ice_forcing_comments(5) = "Cloud Cover="//trim(cldstrng)
3247  ice_forcing_comments(6) = "Shortwave Radiation="//trim(swvstrng)
3248 
3249  IF(dbg_set(dbg_log)) THEN
3250  WRITE(ipt,*)"! SETTING UP CONSTANT ICE FORCING:"
3251  WRITE(ipt,*)"! Sea Leval Air Temp="//trim(satstrng)
3252  WRITE(ipt,*)"! Specific Humidity="//trim(spqstrng)
3253  WRITE(ipt,*)"! Cloud Cover="//trim(cldstrng)
3254  WRITE(ipt,*)"! Shortwave Radiation="//trim(swvstrng)
3255  END IF
3256 
3257  RETURN
3258 
3259  CASE(sttc)
3260 
3261  CALL fatal_error("STATIC ICE FORCING Not Set Up Yet")
3262  ! HEAT_FORCING_COMMENTS = "Using Static heating from file"
3263 
3264  CASE(tmdpndnt)
3265 
3266  CALL fatal_error("TIME DEPENDANT ICE FORCING Not Set Up Yet")
3267  ! HEAT_FORCING_COMMENTS = "Using TIME DEPENDENT heating from file"
3268 
3269  CASE(prdc)
3270 
3271  ice_file => find_file(filehead,trim(ice_forcing_file),found)
3272  IF(.not. found) CALL fatal_error &
3273  & ("COULD NOT FIND ICE MODEL BOUNDARY CONDINTION FILE OBJECT",&
3274  & "FILE NAME: "//trim(ice_forcing_file))
3275 
3276 
3277  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
3278  att => find_att(ice_file,"source",found)
3279  IF(.not. found) att => find_att(ice_file,"Source",found)
3280  IF(.not. found) CALL fatal_error &
3281  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3282  & "FILE NAME: "//trim(ice_forcing_file),&
3283  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
3284 
3285  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
3286  & trim(wrf2fvcom_source)) THEN
3287  ice_forcing_type = ice_is_wrfgrid
3288 
3289  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
3290  & trim(fvcom_cap_grid_source)) THEN
3291  ice_forcing_type = ice_is_fvcomgrid
3292 
3293  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
3294  & trim(fvcom_grid_source)) THEN
3295  ice_forcing_type = ice_is_fvcomgrid
3296 
3297  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
3298  & trim(wrf_grid_source)) THEN
3299  ice_forcing_type = ice_is_wrfgrid
3300 
3301  ELSE
3302  CALL print_file(ice_file)
3303  CALL fatal_error("CAN NOT RECOGNIZE ICE FORCING FILE!",&
3304  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
3305  END IF
3306  ! GOT GRID TYPE
3307 
3308  ALLOCATE(ice_forcing_comments(4))
3309  ice_forcing_comments(1) = "FVCOM periodic surface ice model forcing:"
3310  ice_forcing_comments(2) = "FILE NAME:"//trim(ice_forcing_file)
3311 
3312  ice_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
3313 
3314  att_date => find_att(ice_file,"START_DATE",found)
3315  IF (found) THEN
3316  ice_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
3317  ELSE
3318  ice_forcing_comments(4) = "Unknown start date meta data format"
3319  END IF
3320 
3321  ! GET THE FILES LENGTH OF TIME AND SAVE FOR PERIODIC FORCING
3322 
3323  ! LOOK FOR THE DIMENSIONS
3324  dim => find_unlimited(ice_file,found)
3325  IF(.not. found) CALL fatal_error &
3326  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3327  & "FILE NAME: "//trim(ice_forcing_file),&
3328  &"COULD NOT FIND THE UNLIMITED DIMENSION")
3329 
3330  ntimes = dim%DIM
3331 
3332  ice_period = get_file_time(ice_file,ntimes)
3333 
3334  ice_period = ice_period - get_file_time(ice_file,1)
3335 
3336 
3337  IF (ice_period /= get_file_time(ice_file,ntimes)) THEN
3338 
3339  CALL print_time(get_file_time(ice_file,1),ipt,"FIRST FILE TIME")
3340  CALL print_time(get_file_time(ice_file,ntimes),ipt,"LAST FILE TIME")
3341 
3342  CALL fatal_error&
3343  &("TO USE PERIODIC FORCING THE FILE TIME MUST COUNT FROM ZERO",&
3344  & "THE DIFFERENCE BETWEEN THE CURRENT MODEL TIME AND THE START TIME,",&
3345  & "MODULO THE FORCING PERIOD, DETERMINES THE CURRENT FORCING")
3346  END IF
3347 
3348 
3349  IF(dbg_set(dbg_log)) THEN
3350  WRITE(ipt,*) "! USING PERIODIC ICE FORCING:"
3351  CALL print_time(ice_period,ipt,"PERIOD")
3352  END IF
3353 
3354  CASE(vrbl)
3355 
3356  ice_file => find_file(filehead,trim(ice_forcing_file),found)
3357  IF(.not. found) CALL fatal_error &
3358  & ("COULD NOT FIND ICE FORCING BOUNDARY CONDINTION FILE OBJECT",&
3359  & "FILE NAME: "//trim(ice_forcing_file))
3360 
3361  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
3362  att => find_att(ice_file,"source",found)
3363  IF(.not. found) att => find_att(ice_file,"Source",found)
3364  IF(.not. found) CALL fatal_error &
3365  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3366  & "FILE NAME: "//trim(ice_forcing_file),&
3367  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
3368 
3369  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
3370  & trim(wrf2fvcom_source)) THEN
3371  ice_forcing_type = ice_is_wrfgrid
3372 
3373  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
3374  & trim(fvcom_grid_source)) THEN
3375  ice_forcing_type = ice_is_fvcomgrid
3376 
3377  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
3378  & trim(fvcom_cap_grid_source)) THEN
3379  ice_forcing_type = ice_is_fvcomgrid
3380 
3381  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
3382  & trim(wrf_grid_source)) THEN
3383  ice_forcing_type = ice_is_wrfgrid
3384 
3385  ELSE
3386  CALL print_file(ice_file)
3387  CALL fatal_error("CAN NOT RECOGNIZE ICE FORCING FILE!",&
3388  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
3389  END IF
3390  ! GOT GRID TYPE
3391 
3392 
3393  ALLOCATE(ice_forcing_comments(4))
3394  ice_forcing_comments(1) = "FVCOM variable surface ice model forcing:"
3395  ice_forcing_comments(2) = "FILE NAME:"//trim(ice_forcing_file)
3396 
3397  ice_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
3398 
3399  att_date => find_att(ice_file,"START_DATE",found)
3400  IF (found) THEN
3401  ice_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
3402  ELSE
3403  ice_forcing_comments(4) = "Unknown start date meta data format"
3404  END IF
3405 
3406 
3407  ! CHECK DIMENSIONS
3408  dim => find_unlimited(ice_file,found)
3409  IF(.not. found) CALL fatal_error &
3410  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3411  & "FILE NAME: "//trim(ice_forcing_file),&
3412  &"COULD NOT FIND UNLIMITED DIMENSION")
3413 
3414  ntimes = dim%DIM
3415 
3416  ! CHECK THE FILE TIME AND COMPARE WITH MODEL RUN TIME
3417  timetest = get_file_time(ice_file,1)
3418  IF(timetest > starttime) CALL fatal_error &
3419  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3420  & "FILE NAME: "//trim(ice_forcing_file),&
3421  &"THE MODEL RUN STARTS BEFORE THE FORCING TIME SERIES")
3422 
3423  timetest = get_file_time(ice_file,ntimes)
3424  IF(timetest < endtime) CALL fatal_error &
3425  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3426  & "FILE NAME: "//trim(ice_forcing_file),&
3427  &"THE MODEL RUN ENDS AFTER THE FORCING TIME SERIES")
3428 
3429  CASE DEFAULT
3430  CALL fatal_error("ICE FORCING: UNKNOWN ICE_FORCING KIND?")
3431  END SELECT
3432 
3433 
3434 
3435  !==================================================================
3436  SELECT CASE(ice_forcing_type)
3437  !==================================================================
3438  CASE(ice_is_wrfgrid)
3439  !==================================================================
3440 
3441  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
3442  & "! SETTING UP ICE FORCING FROM A 'wrf grid' FILE"
3443 
3444 
3445  ! LOOK FOR THE DIMENSIONS
3446  dim => find_dim(ice_file,'south_north',found)
3447  IF(.not. found) CALL fatal_error &
3448  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3449  & "FILE NAME: "//trim(ice_forcing_file),&
3450  & "COULD NOT FIND DIMENSION 'south_north'")
3451 
3452  lats = dim%DIM
3453 
3454  dim => find_dim(ice_file,'west_east',found)
3455  IF(.not. found) CALL fatal_error &
3456  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3457  & "FILE NAME: "//trim(ice_forcing_file),&
3458  & "COULD NOT FIND DIMENSION 'west_east'")
3459  lons = dim%DIM
3460 
3461 
3462  CALL set_file_interp_bilinear(ice_file,ice_intp_n,ice_intp_c)
3463  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
3464 
3465  !IF(ASSOCIATED(ICE_FILE,HEAT_FILE)) THEN
3466  var => find_var(heat_file,"short_wave",found)
3467  IF( found ) THEN
3468  ! USE THE SAME MEMORY USED FOR OCEAN MODEL HEAT FLUX
3469 
3470  ice_swv_n => heat_swv_n
3471 
3472  ice_swv_p => heat_swv_p
3473 
3474  ELSE
3475  ! LOAD YOUR OWN DATA FOR THE ICE MODEL
3476 
3477  ! SHORT WAVE RADIATION DATA
3478  var => find_var(ice_file,"short_wave",found)
3479  IF(.not. found) var => find_var(ice_file,"Shortwave",found)
3480  IF(.not. found) CALL fatal_error &
3481  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3482  & "FILE NAME: "//trim(ice_forcing_file),&
3483  & "COULD NOT FIND VARIABLE 'short_wave'")
3484 
3485  ! MAKE SPACE FOR THE DATA FROM THE FILE
3486  ALLOCATE(storage_arr(lons,lats), stat = status)
3487  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3488  ice_swv_n => reference_var(var)
3489  CALL nc_connect_pvar(ice_swv_n,storage_arr)
3490  NULLIFY(storage_arr)
3491 
3492  ! MAKE SPACE FOR THE INTERPOLATED DATA
3493  ALLOCATE(storage_vec(0:mt), stat = status)
3494  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3495  CALL nc_connect_pvar(ice_swv_n,storage_vec)
3496  NULLIFY(storage_vec)
3497 
3498 
3499  ! MAKE SPACE FOR THE DATA FROM THE FILE
3500  ALLOCATE(storage_arr(lons,lats), stat = status)
3501  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3502  ice_swv_p => reference_var(var)
3503  CALL nc_connect_pvar(ice_swv_p,storage_arr)
3504  NULLIFY(storage_arr)
3505 
3506  ! MAKE SPACE FOR THE INTERPOLATED DATA
3507  ALLOCATE(storage_vec(0:mt), stat = status)
3508  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3509  CALL nc_connect_pvar(ice_swv_p,storage_vec)
3510  NULLIFY(storage_vec)
3511 
3512  END IF
3513 
3514 
3515  ! Surface Air Temperature DATA
3516  var => find_var(ice_file,"SAT",found)
3517  var => find_var(ice_file,"T2",found)
3518  IF(.not. found) CALL fatal_error &
3519  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3520  & "FILE NAME: "//trim(ice_forcing_file),&
3521  & "COULD NOT FIND VARIABLE 'T2' of 'SAT'")
3522 
3523  ! MAKE SPACE FOR THE DATA FROM THE FILE
3524  ALLOCATE(storage_arr(lons,lats), stat = status)
3525  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3526  ice_sat_n => reference_var(var)
3527  CALL nc_connect_pvar(ice_sat_n,storage_arr)
3528  NULLIFY(storage_arr)
3529 
3530  ! MAKE SPACE FOR THE INTERPOLATED DATA
3531  ALLOCATE(storage_vec(0:mt), stat = status)
3532  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3533  CALL nc_connect_pvar(ice_sat_n,storage_vec)
3534  NULLIFY(storage_vec)
3535 
3536 
3537  ! MAKE SPACE FOR THE DATA FROM THE FILE
3538  ALLOCATE(storage_arr(lons,lats), stat = status)
3539  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3540  ice_sat_p => reference_var(var)
3541  CALL nc_connect_pvar(ice_sat_p,storage_arr)
3542  NULLIFY(storage_arr)
3543 
3544  ! MAKE SPACE FOR THE INTERPOLATED DATA
3545  ALLOCATE(storage_vec(0:mt), stat = status)
3546  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3547  CALL nc_connect_pvar(ice_sat_p,storage_vec)
3548  NULLIFY(storage_vec)
3549 
3550  ! Specific Humidity DATA
3551  var => find_var(ice_file,"SPQ",found)
3552  var => find_var(ice_file,"Q2",found)
3553  IF(.not. found) CALL fatal_error &
3554  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3555  & "FILE NAME: "//trim(ice_forcing_file),&
3556  & "COULD NOT FIND VARIABLE 'Q2' of 'SPQ'")
3557 
3558  ! MAKE SPACE FOR THE DATA FROM THE FILE
3559  ALLOCATE(storage_arr(lons,lats), stat = status)
3560  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3561  ice_spq_n => reference_var(var)
3562  CALL nc_connect_pvar(ice_spq_n,storage_arr)
3563  NULLIFY(storage_arr)
3564 
3565  ! MAKE SPACE FOR THE INTERPOLATED DATA
3566  ALLOCATE(storage_vec(0:mt), stat = status)
3567  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3568  CALL nc_connect_pvar(ice_spq_n,storage_vec)
3569  NULLIFY(storage_vec)
3570 
3571 
3572  ! MAKE SPACE FOR THE DATA FROM THE FILE
3573  ALLOCATE(storage_arr(lons,lats), stat = status)
3574  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3575  ice_spq_p => reference_var(var)
3576  CALL nc_connect_pvar(ice_spq_p,storage_arr)
3577  NULLIFY(storage_arr)
3578 
3579  ! MAKE SPACE FOR THE INTERPOLATED DATA
3580  ALLOCATE(storage_vec(0:mt), stat = status)
3581  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3582  CALL nc_connect_pvar(ice_spq_p,storage_vec)
3583  NULLIFY(storage_vec)
3584 
3585  ! Cloud Cover DATA
3586  var => find_var(ice_file,"cloud_cover",found)
3587  IF(.not. found) CALL fatal_error &
3588  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3589  & "FILE NAME: "//trim(ice_forcing_file),&
3590  & "COULD NOT FIND VARIABLE 'cloud_cover'")
3591 
3592  ! MAKE SPACE FOR THE DATA FROM THE FILE
3593  ALLOCATE(storage_arr(lons,lats), stat = status)
3594  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3595  ice_cld_n => reference_var(var)
3596  CALL nc_connect_pvar(ice_cld_n,storage_arr)
3597  NULLIFY(storage_arr)
3598 
3599  ! MAKE SPACE FOR THE INTERPOLATED DATA
3600  ALLOCATE(storage_vec(0:mt), stat = status)
3601  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3602  CALL nc_connect_pvar(ice_cld_n,storage_vec)
3603  NULLIFY(storage_vec)
3604 
3605 
3606  ! MAKE SPACE FOR THE DATA FROM THE FILE
3607  ALLOCATE(storage_arr(lons,lats), stat = status)
3608  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3609  ice_cld_p => reference_var(var)
3610  CALL nc_connect_pvar(ice_cld_p,storage_arr)
3611  NULLIFY(storage_arr)
3612 
3613  ! MAKE SPACE FOR THE INTERPOLATED DATA
3614  ALLOCATE(storage_vec(0:mt), stat = status)
3615  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3616  CALL nc_connect_pvar(ice_cld_p,storage_vec)
3617  NULLIFY(storage_vec)
3618 
3619  !==================================================================
3620  CASE(ice_is_fvcomgrid)
3621  !==================================================================
3622 
3623  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
3624  & "! SETTING UP HEAT FORCING FROM A 'fvcom grid' FILE"
3625 
3626  ! LOOK FOR THE DIMENSIONS
3627  dim => find_dim(ice_file,'node',found)
3628  IF(.not. found) CALL fatal_error &
3629  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3630  & "FILE NAME: "//trim(ice_forcing_file),&
3631  & "COULD NOT FIND DIMENSION 'node'")
3632 
3633  if (mgl /= dim%dim) CALL fatal_error&
3634  &("Ice Forcing: the number of nodes in the file does not match the fvcom grid?")
3635 
3636 
3637  dim => find_dim(ice_file,'nele',found)
3638  IF(.not. found) CALL fatal_error &
3639  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3640  & "FILE NAME: "//trim(ice_forcing_file),&
3641  & "COULD NOT FIND DIMENSION 'nele'")
3642 
3643  if (ngl /= dim%dim) CALL fatal_error&
3644  &("Ice Forcing: the number of elements in the file does not match the fvcom grid?")
3645 
3646  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
3647 
3648  ! SHORT WAVE RADIATION DATA
3649  !IF(ASSOCIATED(ICE_FILE,HEAT_FILE)) THEN
3650  var => find_var(heat_file,"short_wave",found)
3651  IF( found ) THEN
3652  ! USE THE SAME MEMORY USED FOR OCEAN MODEL HEAT FLUX
3653 
3654  ice_swv_n => heat_swv_n
3655 
3656  ice_swv_p => heat_swv_p
3657 
3658  ELSE
3659  ! LOAD YOUR OWN DATA FOR THE ICE MODEL
3660 
3661  ! SHORT WAVE RADIATION DATA
3662  var => find_var(ice_file,"short_wave",found)
3663  IF(.not. found) var => find_var(ice_file,"Shortwave",found)
3664  IF(.not. found) CALL fatal_error &
3665  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3666  & "FILE NAME: "//trim(ice_forcing_file),&
3667  & "COULD NOT FIND VARIABLE 'short_wave'")
3668 
3669  ! MAKE SPACE FOR THE DATA FROM THE FILE
3670  ice_swv_n => reference_var(var)
3671  ALLOCATE(storage_vec(0:mt), stat = status)
3672  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3673  CALL nc_connect_pvar(ice_swv_n,storage_vec)
3674  NULLIFY(storage_vec)
3675 
3676 
3677  ! MAKE SPACE FOR THE DATA FROM THE FILE
3678  ice_swv_p => reference_var(var)
3679  ALLOCATE(storage_vec(0:mt), stat = status)
3680  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3681  CALL nc_connect_pvar(ice_swv_p,storage_vec)
3682  NULLIFY(storage_vec)
3683 
3684  END IF
3685 
3686 
3687  ! Surface Air Temperature DATA
3688  var => find_var(ice_file,"SAT",found)
3689  IF(.not. found) var => find_var(ice_file,"T2",found)
3690  IF(.not. found) CALL fatal_error &
3691  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3692  & "FILE NAME: "//trim(ice_forcing_file),&
3693  & "COULD NOT FIND VARIABLE 'T2' or 'SAT'")
3694 
3695  ! MAKE SPACE FOR THE DATA FROM THE FILE
3696  ice_sat_n => reference_var(var)
3697  ALLOCATE(storage_vec(0:mt), stat = status)
3698  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3699  CALL nc_connect_pvar(ice_sat_n,storage_vec)
3700  NULLIFY(storage_vec)
3701 
3702 
3703  ! MAKE SPACE FOR THE DATA FROM THE FILE
3704  ice_sat_p => reference_var(var)
3705  ALLOCATE(storage_vec(0:mt), stat = status)
3706  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3707  CALL nc_connect_pvar(ice_sat_p,storage_vec)
3708  NULLIFY(storage_vec)
3709 
3710  ! Specific Humidity DATA
3711  var => find_var(ice_file,"SPQ",found)
3712  IF(.not. found) var => find_var(ice_file,"Q2",found)
3713  IF(.not. found) CALL fatal_error &
3714  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3715  & "FILE NAME: "//trim(ice_forcing_file),&
3716  & "COULD NOT FIND VARIABLE 'Q2' or 'SPQ'")
3717 
3718  ! MAKE SPACE FOR THE DATA FROM THE FILE
3719  ice_spq_n => reference_var(var)
3720  ALLOCATE(storage_vec(0:mt), stat = status)
3721  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3722  CALL nc_connect_pvar(ice_spq_n,storage_vec)
3723  NULLIFY(storage_vec)
3724 
3725 
3726  ! MAKE SPACE FOR THE DATA FROM THE FILE
3727  ice_spq_p => reference_var(var)
3728  ALLOCATE(storage_vec(0:mt), stat = status)
3729  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3730  CALL nc_connect_pvar(ice_spq_p,storage_vec)
3731  NULLIFY(storage_vec)
3732 
3733  ! Specific Humidity DATA
3734  var => find_var(ice_file,"cloud_cover",found)
3735  IF(.not. found) CALL fatal_error &
3736  & ("IN ICE FORCING BOUNDARY CONDITION FILE OBJECT",&
3737  & "FILE NAME: "//trim(ice_forcing_file),&
3738  & "COULD NOT FIND VARIABLE 'cloud_cover'")
3739 
3740  ! MAKE SPACE FOR THE DATA FROM THE FILE
3741  ice_cld_n => reference_var(var)
3742  ALLOCATE(storage_vec(0:mt), stat = status)
3743  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3744  CALL nc_connect_pvar(ice_cld_n,storage_vec)
3745  NULLIFY(storage_vec)
3746 
3747 
3748  ! MAKE SPACE FOR THE DATA FROM THE FILE
3749  ice_cld_p => reference_var(var)
3750  ALLOCATE(storage_vec(0:mt), stat = status)
3751  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICE FORCING")
3752  CALL nc_connect_pvar(ice_cld_p,storage_vec)
3753  NULLIFY(storage_vec)
3754 
3755 
3756  !==================================================================
3757  CASE DEFAULT
3758  !==================================================================
3759  CALL fatal_error("CAN NOT RECOGNIZE ICE FORCING FILE TYPE!")
3760  !==================================================================
3761  END SELECT
3762  !==================================================================
3763 
3764 
3765  ! ---------- new: 2016 , april, after Hint by Qi -------------------------
3766  ! Initialize some variables
3767  ! afm 20150914
3768  ! Need initialization. Otherwise, random values are asigned
3769  ! and cause a hanging problem of MPI job in UPDATE_VAR_BRACKET
3770  ! This problem reported with Intel15.0.3.
3771  ice_swv_n%curr_stkcnt = 0;ice_swv_p%curr_stkcnt = 0
3772  ice_sat_n%curr_stkcnt = 0;ice_sat_p%curr_stkcnt = 0
3773  ice_spq_n%curr_stkcnt = 0;ice_spq_p%curr_stkcnt = 0
3774  ice_cld_n%curr_stkcnt = 0;ice_cld_p%curr_stkcnt = 0
3775  ! --------- end new --------------------------------------------
3776 
3777  IF(dbg_set(dbg_sbr)) write(ipt,*) "END ICE MODEL FORCING"
3778  END SUBROUTINE ice_model_forcing
3779  !================================================================
3780  !================================================================
3781  SUBROUTINE icing_forcing
3782  IMPLICIT NONE
3783  ! SOME NC POINTERS
3784  TYPE(ncatt), POINTER :: att, att_date
3785  TYPE(ncdim), POINTER :: dim
3786  TYPE(ncvar), POINTER :: var
3787  LOGICAL :: found
3788 
3789  REAL(sp), POINTER :: storage_arr(:,:), storage_vec(:)
3790  CHARACTER(len=30) :: satstrng, wspdstrng
3791  TYPE(time) :: timetest
3792 
3793  INTEGER :: lats, lons, i, ntimes
3794 
3795  INTEGER :: status
3796 
3797  IF(dbg_set(dbg_sbr)) write(ipt,*) "START ICING_FORCING"
3798 
3799  NULLIFY(att,dim,var,storage_arr,storage_vec)
3800 
3801  IF (.NOT. icing_model ) THEN
3802  IF(dbg_set(dbg_log)) write(ipt,*) "! ICING MODEL IS OFF!"
3803  ALLOCATE(icing_forcing_comments(1))
3804  icing_forcing_comments(1) = "ICING MODEL IS OFF"
3805  RETURN
3806  END IF
3807 
3808 
3809  ! DETERMINE HOW TO LOAD THE DATA
3810  SELECT CASE(icing_forcing_kind)
3811  CASE (cnstnt)
3812 
3813  write(satstrng,'(f8.4)') icing_air_temp
3814  write(wspdstrng,'(f8.4)') icing_wspd
3815 
3816  ALLOCATE(icing_forcing_comments(3))
3817  icing_forcing_comments(1) = "Using Constant heating:"
3818 
3819  icing_forcing_comments(2) = "Sea Level Air Temperature:"//trim(satstrng)
3820  icing_forcing_comments(3) = "Wind Speed:"//trim(wspdstrng)
3821 
3822  IF(dbg_set(dbg_log)) THEN
3823  WRITE(ipt,*) "! SETTING UP CONSTANT ICING: "
3824  WRITE(ipt,*) "! Sea Level Air Temperature:"//trim(satstrng)
3825  WRITE(ipt,*) "! Wind Speed:"//trim(wspdstrng)
3826  END IF
3827  RETURN
3828 
3829  CASE(sttc)
3830 
3831  CALL fatal_error("STATIC HEATING Not Set Up Yet")
3832  ! HEAT_FORCING_COMMENTS = "Using Static heating from file"
3833 
3834  CASE(tmdpndnt)
3835 
3836  CALL fatal_error("TIME DEPENDANT HEATING Not Set Up Yet")
3837  ! HEAT_FORCING_COMMENTS = "Using TIME DEPENDENT heating from file"
3838 
3839  CASE(prdc)
3840 
3841  icing_file => find_file(filehead,trim(icing_forcing_file),found)
3842  IF(.not. found) CALL fatal_error &
3843  & ("COULD NOT FIND SURFACE ICING BOUNDARY CONDINTION FILE OBJECT",&
3844  & "FILE NAME: "//trim(icing_forcing_file))
3845 
3846  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
3847  att => find_att(icing_file,"source",found)
3848  IF(.not. found) att => find_att(icing_file,"Source",found)
3849  IF(.not. found) CALL fatal_error &
3850  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
3851  & "FILE NAME: "//trim(icing_forcing_file),&
3852  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
3853 
3854  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
3855  & trim(wrf2fvcom_source)) THEN
3856  icing_forcing_type = icing_is_wrfgrid
3857 
3858  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
3859  & trim(fvcom_cap_grid_source)) THEN
3860  icing_forcing_type = icing_is_fvcomgrid
3861 
3862  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
3863  & trim(fvcom_grid_source)) THEN
3864  icing_forcing_type = icing_is_fvcomgrid
3865 
3866  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
3867  & trim(wrf_grid_source)) THEN
3868  icing_forcing_type = icing_is_wrfgrid
3869 
3870  ELSE
3871  CALL print_file(icing_file)
3872  CALL fatal_error("CAN NOT RECOGNIZE ICING FILE!",&
3873  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
3874  END IF
3875  ! GOT GRID TYPE
3876 
3877  ALLOCATE(icing_forcing_comments(4))
3878  icing_forcing_comments(1) = "FVCOM periodic surface icing forcing:"
3879  icing_forcing_comments(2) = "FILE NAME:"//trim(icing_forcing_file)
3880 
3881  icing_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
3882 
3883  att_date => find_att(icing_file,"START_DATE",found)
3884  IF (found) THEN
3885  icing_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
3886  ELSE
3887  icing_forcing_comments(4) = "Unknown start date meta data format"
3888  END IF
3889 
3890  ! GET THE FILES LENGTH OF TIME AND SAVE FOR PERIODIC FORCING
3891 
3892  ! LOOK FOR THE DIMENSIONS
3893  dim => find_unlimited(icing_file,found)
3894  IF(.not. found) CALL fatal_error &
3895  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
3896  & "FILE NAME: "//trim(icing_forcing_file),&
3897  &"COULD NOT FIND THE UNLIMITED DIMENSION")
3898 
3899  ntimes = dim%DIM
3900 
3901  icing_period = get_file_time(icing_file,ntimes)
3902 
3903  icing_period = icing_period - get_file_time(icing_file,1)
3904 
3905 
3906  IF (icing_period /= get_file_time(icing_file,ntimes)) THEN
3907 
3908  CALL print_real_time(get_file_time(icing_file,1),ipt,"FIRST FILE TIME",timezone)
3909  CALL print_real_time(get_file_time(icing_file,ntimes),ipt,"LAST FILE TIME",timezone)
3910 
3911  CALL fatal_error&
3912  &("TO USE PERIODIC FORCING THE FILE TIME MUST COUNT FROM ZERO",&
3913  & "THE DIFFERENCE BETWEEN THE CURRENT MODEL TIME AND THE START TIME,",&
3914  & "MODULO THE FORCING PERIOD, DETERMINES THE CURRENT FORCING")
3915  END IF
3916 
3917 
3918  IF(dbg_set(dbg_log)) THEN
3919  WRITE(ipt,*) "! USING PERIODIC ICING FORCING:"
3920  CALL print_time(icing_period,ipt,"PERIOD")
3921  END IF
3922 
3923  CASE(vrbl)
3924 
3925  icing_file => find_file(filehead,trim(icing_forcing_file),found)
3926  IF(.not. found) CALL fatal_error &
3927  & ("COULD NOT FIND SURFACE ICING BOUNDARY CONDINTION FILE OBJECT",&
3928  & "FILE NAME: "//trim(icing_forcing_file))
3929 
3930  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
3931  att => find_att(icing_file,"source",found)
3932  IF(.not. found) att => find_att(icing_file,"Source",found)
3933  IF(.not. found) CALL fatal_error &
3934  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
3935  & "FILE NAME: "//trim(icing_forcing_file),&
3936  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
3937 
3938  icing_forcing_comments ="VARIABLE ICING: "//trim(att%CHR(1))
3939 
3940  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
3941  & trim(wrf2fvcom_source)) THEN
3942  icing_forcing_type = icing_is_wrfgrid
3943 
3944  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
3945  & trim(fvcom_grid_source)) THEN
3946  icing_forcing_type = icing_is_fvcomgrid
3947 
3948  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
3949  & trim(fvcom_cap_grid_source)) THEN
3950  icing_forcing_type = icing_is_fvcomgrid
3951 
3952  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
3953  & trim(wrf_grid_source)) THEN
3954  icing_forcing_type = icing_is_wrfgrid
3955 
3956  ELSE
3957  CALL print_file(icing_file)
3958  CALL fatal_error("CAN NOT RECOGNIZE ICING FILE!",&
3959  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
3960  END IF
3961  ! GOT GRID TYPE
3962 
3963  ALLOCATE(icing_forcing_comments(4))
3964  icing_forcing_comments(1) = "FVCOM variable surface icing forcing:"
3965  icing_forcing_comments(2) = "FILE NAME:"//trim(icing_forcing_file)
3966 
3967  icing_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
3968 
3969  att_date => find_att(icing_file,"START_DATE",found)
3970  IF (found) THEN
3971  icing_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
3972  ELSE
3973  icing_forcing_comments(4) = "Unknown start date meta data format"
3974  END IF
3975 
3976 
3977  ! CHECK DIMENSIONS
3978  dim => find_unlimited(icing_file,found)
3979  IF(.not. found) CALL fatal_error &
3980  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
3981  & "FILE NAME: "//trim(icing_forcing_file),&
3982  &"COULD NOT FIND UNLIMITED DIMENSION")
3983 
3984  ntimes = dim%DIM
3985 
3986  ! CHECK THE FILE TIME AND COMPARE WITH MODEL RUN TIME
3987  timetest = get_file_time(icing_file,1)
3988  IF(timetest > starttime) CALL fatal_error &
3989  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
3990  & "FILE NAME: "//trim(icing_forcing_file),&
3991  &"THE MODEL RUN STARTS BEFORE THE FORCING TIME SERIES")
3992 
3993  timetest = get_file_time(icing_file,ntimes)
3994  IF(timetest < endtime) CALL fatal_error &
3995  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
3996  & "FILE NAME: "//trim(icing_forcing_file),&
3997  &"THE MODEL RUN ENDS AFTER THE FORCING TIME SERIES")
3998 
3999  CASE DEFAULT
4000  CALL fatal_error("SURFACE_ICING: UNKNOWN ICING KIND?")
4001  END SELECT
4002 
4003 
4004 
4005  !==================================================================
4006  SELECT CASE(icing_forcing_type)
4007  !==================================================================
4008  CASE(icing_is_wrfgrid)
4009  !==================================================================
4010 
4011  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
4012  & "! SETTING UP ICING FORCING FROM A 'wrf grid' FILE"
4013 
4014  ! LOOK FOR THE DIMENSIONS
4015  dim => find_dim(icing_file,'south_north',found)
4016  IF(.not. found) CALL fatal_error &
4017  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
4018  & "FILE NAME: "//trim(icing_forcing_file),&
4019  & "COULD NOT FIND DIMENSION 'south_north'")
4020 
4021  lats = dim%DIM
4022 
4023  dim => find_dim(icing_file,'west_east',found)
4024  IF(.not. found) CALL fatal_error &
4025  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
4026  & "FILE NAME: "//trim(icing_forcing_file),&
4027  & "COULD NOT FIND DIMENSION 'west_east'")
4028  lons = dim%DIM
4029 
4030 
4031  CALL set_file_interp_bilinear(icing_file,icing_intp_n,icing_intp_c)
4032 
4033  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
4034 
4035  ! SEA LEVEL AIR TEMPERATURE
4036  IF(ASSOCIATED(ice_file,icing_file)) THEN
4037  ! USE THE ALREADY LOADED DATA FROM THE ICE MODEL
4038  icing_sat_n => ice_sat_n
4039  icing_sat_p => ice_sat_p
4040 
4041  ELSE
4042 
4043  var => find_var(icing_file,"T2",found)
4044  ! IF(.not. FOUND) VAR => FIND_VAR(ICING_FILE,"T2",FOUND)
4045  IF(.not. found) CALL fatal_error &
4046  & ("IN SURFACE HEATING BOUNDARY CONDITION FILE OBJECT",&
4047  & "FILE NAME: "//trim(icing_forcing_file),&
4048  & "COULD NOT FIND VARIABLE 'T2'")
4049 
4050  ! MAKE SPACE FOR THE DATA FROM THE FILE
4051  ALLOCATE(storage_arr(lons,lats), stat = status)
4052  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4053  icing_sat_n => reference_var(var)
4054  CALL nc_connect_pvar(icing_sat_n,storage_arr)
4055  NULLIFY(storage_arr)
4056 
4057  ! MAKE SPACE FOR THE INTERPOLATED DATA
4058  ALLOCATE(storage_vec(0:mt), stat = status)
4059  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4060  CALL nc_connect_pvar(icing_sat_n,storage_vec)
4061  NULLIFY(storage_vec)
4062 
4063 
4064  ! MAKE SPACE FOR THE DATA FROM THE FILE
4065  ALLOCATE(storage_arr(lons,lats), stat = status)
4066  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4067  icing_sat_p => reference_var(var)
4068  CALL nc_connect_pvar(icing_sat_p,storage_arr)
4069  NULLIFY(storage_arr)
4070 
4071  ! MAKE SPACE FOR THE INTERPOLATED DATA
4072  ALLOCATE(storage_vec(0:mt), stat = status)
4073  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4074  CALL nc_connect_pvar(icing_sat_p,storage_vec)
4075  NULLIFY(storage_vec)
4076 
4077  END IF
4078 
4079  ! NET WIND SPEED X
4080  var => find_var(heat_file,"U10",found)
4081 ! IF(.not. FOUND) VAR => FIND_VAR(HEAT_FILE,"U10",FOUND)
4082  IF(.not. found) CALL fatal_error &
4083  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
4084  & "FILE NAME: "//trim(icing_forcing_file),&
4085  & "COULD NOT FIND VARIABLE 'U10'")
4086 
4087  ! MAKE SPACE FOR THE DATA FROM THE FILE
4088  ALLOCATE(storage_arr(lons,lats), stat = status)
4089  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4090  icing_wspx_n => reference_var(var)
4091  CALL nc_connect_pvar(icing_wspx_n,storage_arr)
4092  NULLIFY(storage_arr)
4093 
4094  ! MAKE SPACE FOR THE INTERPOLATED DATA
4095  ALLOCATE(storage_vec(0:mt), stat = status)
4096  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4097  CALL nc_connect_pvar(icing_wspx_n,storage_vec)
4098  NULLIFY(storage_vec)
4099 
4100 
4101  ! MAKE SPACE FOR THE DATA FROM THE FILE
4102  ALLOCATE(storage_arr(lons,lats), stat = status)
4103  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4104  icing_wspx_p => reference_var(var)
4105  CALL nc_connect_pvar(icing_wspx_p,storage_arr)
4106  NULLIFY(storage_arr)
4107 
4108  ! MAKE SPACE FOR THE INTERPOLATED DATA
4109  ALLOCATE(storage_vec(0:mt), stat = status)
4110  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4111  CALL nc_connect_pvar(icing_wspx_p,storage_vec)
4112  NULLIFY(storage_vec)
4113 
4114  ! NET WIND SPEED Y
4115  var => find_var(heat_file,"V10",found)
4116 ! IF(.not. FOUND) VAR => FIND_VAR(HEAT_FILE,"U10",FOUND)
4117  IF(.not. found) CALL fatal_error &
4118  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
4119  & "FILE NAME: "//trim(icing_forcing_file),&
4120  & "COULD NOT FIND VARIABLE 'V10'")
4121 
4122  ! MAKE SPACE FOR THE DATA FROM THE FILE
4123  ALLOCATE(storage_arr(lons,lats), stat = status)
4124  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4125  icing_wspy_n => reference_var(var)
4126  CALL nc_connect_pvar(icing_wspy_n,storage_arr)
4127  NULLIFY(storage_arr)
4128 
4129  ! MAKE SPACE FOR THE INTERPOLATED DATA
4130  ALLOCATE(storage_vec(0:mt), stat = status)
4131  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4132  CALL nc_connect_pvar(icing_wspy_n,storage_vec)
4133  NULLIFY(storage_vec)
4134 
4135 
4136  ! MAKE SPACE FOR THE DATA FROM THE FILE
4137  ALLOCATE(storage_arr(lons,lats), stat = status)
4138  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4139  icing_wspy_p => reference_var(var)
4140  CALL nc_connect_pvar(icing_wspy_p,storage_arr)
4141  NULLIFY(storage_arr)
4142 
4143  ! MAKE SPACE FOR THE INTERPOLATED DATA
4144  ALLOCATE(storage_vec(0:mt), stat = status)
4145  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4146  CALL nc_connect_pvar(icing_wspy_p,storage_vec)
4147  NULLIFY(storage_vec)
4148 
4149  !==================================================================
4150  CASE(icing_is_fvcomgrid)
4151  !==================================================================
4152 
4153  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
4154  & "! SETTING UP ICING FORCING FROM A 'fvcom grid' FILE"
4155 
4156  ! LOOK FOR THE DIMENSIONS
4157  dim => find_dim(icing_file,'node',found)
4158  IF(.not. found) CALL fatal_error &
4159  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
4160  & "FILE NAME: "//trim(icing_forcing_file),&
4161  & "COULD NOT FIND DIMENSION 'node'")
4162 
4163  if (mgl /= dim%dim) CALL fatal_error&
4164  &("Surface ICing: the number of nodes in the file does not match the fvcom grid?")
4165 
4166 
4167  dim => find_dim(heat_file,'nele',found)
4168  IF(.not. found) CALL fatal_error &
4169  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
4170  & "FILE NAME: "//trim(icing_forcing_file),&
4171  & "COULD NOT FIND DIMENSION 'nele'")
4172 
4173  if (ngl /= dim%dim) CALL fatal_error&
4174  &("Surface Icing: the number of elements in the file does not match the fvcom grid?")
4175 
4176  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
4177 
4178  ! Sea Surface Air Temperature
4179  IF(ASSOCIATED(ice_file,icing_file)) THEN
4180  ! USE THE SAME MEMORY USED FOR OCEAN MODEL HEAT FLUX
4181 
4182  icing_sat_n => ice_sat_n
4183 
4184  icing_sat_p => ice_sat_p
4185 
4186  ELSE
4187  var => find_var(icing_file,"T2",found)
4188  IF(.not. found) CALL fatal_error &
4189  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
4190  & "FILE NAME: "//trim(icing_forcing_file),&
4191  & "COULD NOT FIND VARIABLE 'T2'")
4192 
4193  ! MAKE SPACE FOR THE DATA FROM THE FILE
4194  icing_sat_n => reference_var(var)
4195  ALLOCATE(storage_vec(0:mt), stat = status)
4196  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4197  CALL nc_connect_pvar(icing_sat_n,storage_vec)
4198  NULLIFY(storage_vec)
4199 
4200 
4201  ! MAKE SPACE FOR THE DATA FROM THE FILE
4202  icing_sat_p => reference_var(var)
4203  ALLOCATE(storage_vec(0:mt), stat = status)
4204  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4205  CALL nc_connect_pvar(icing_sat_p,storage_vec)
4206  NULLIFY(storage_vec)
4207 
4208  END IF
4209 
4210  ! Wind Speed X
4211  var => find_var(heat_file,"U10",found)
4212  IF(.not. found) CALL fatal_error &
4213  & ("IN SURFACE ICING BOUNDARY CONDITION FILE OBJECT",&
4214  & "FILE NAME: "//trim(icing_forcing_file),&
4215  & "COULD NOT FIND VARIABLE 'U10'")
4216 
4217  ! MAKE SPACE FOR THE DATA FROM THE FILE
4218  icing_wspx_n => reference_var(var)
4219  ALLOCATE(storage_vec(0:mt), stat = status)
4220  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4221  CALL nc_connect_pvar(icing_wspx_n,storage_vec)
4222  NULLIFY(storage_vec)
4223 
4224 
4225  ! MAKE SPACE FOR THE DATA FROM THE FILE
4226  icing_wspx_p => reference_var(var)
4227  ALLOCATE(storage_vec(0:mt), stat = status)
4228  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN ICING_FORCING")
4229  CALL nc_connect_pvar(icing_wspx_p,storage_vec)
4230  NULLIFY(storage_vec)
4231 
4232  !==================================================================
4233  CASE DEFAULT
4234  !==================================================================
4235  CALL fatal_error("CAN NOT RECOGNIZE ICING FILE TYPE!")
4236  !==================================================================
4237  END SELECT
4238  !==================================================================
4239 
4240 
4241  ! ---------- new: 2016 , april, after Hint by Qi and ayumi.fujisaki@noaa.gov------
4242  ! Initialize some variables
4243  ! afm 20150914
4244  ! Need initialization. Otherwise, random values are asigned
4245  ! and cause a hanging problem of MPI job in UPDATE_VAR_BRACKET
4246  ! This problem reported with Intel15.0.3.
4247  icing_sat_p%CURR_STKCNT = 0; icing_sat_n%CURR_STKCNT = 0
4248  icing_wspx_p%CURR_STKCNT = 0; icing_wspx_n%CURR_STKCNT = 0
4249  icing_wspy_p%CURR_STKCNT = 0; icing_wspy_n%CURR_STKCNT = 0
4250  ! --------------------- end new ----------------------------------------------------
4251 
4252 
4253 
4254  IF(dbg_set(dbg_sbr)) write(ipt,*) "END ICING FORCING"
4255  END SUBROUTINE icing_forcing
4256 !================================================================
4257 !================================================================
4258  SUBROUTINE surface_windstress
4259  IMPLICIT NONE
4260  ! SOME NC POINTERS
4261  TYPE(ncatt), POINTER :: att, att_date
4262  TYPE(ncdim), POINTER :: dim
4263  TYPE(ncvar), POINTER :: var
4264  LOGICAL :: found
4265  REAL(sp), POINTER :: storage_arr(:,:), storage_vec(:)
4266  TYPE(time) :: timetest
4267  INTEGER :: lats, lons, i, ntimes
4268  INTEGER :: status
4269  CHARACTER(len=60) :: xstr, ystr
4270 
4271  IF(dbg_set(dbg_sbr)) write(ipt,*) "START SURFACE_WINDSTRESS"
4272 
4273  NULLIFY(att,dim,var,storage_arr,storage_vec)
4274 
4275 
4276  IF (.NOT. wind_on ) THEN
4277  IF(dbg_set(dbg_log)) write(ipt,*) "! SURFACE WIND FORCING IS OFF!"
4278  ALLOCATE(winds_forcing_comments(1))
4279  winds_forcing_comments(1) = "SURFACE WIND FORCING IS OFF"
4280  RETURN
4281  END IF
4282 
4283  IF (wind_type /= speed .and.wind_type /= stress) CALL fatal_error&
4284  &("YOU MUST SELECT A WIND TYPE IN THE RUNFILE: '"&
4285  &//trim(speed)//", or '"//trim(stress)//"'")
4286 
4287 
4288 ! DETERMINE HOW TO LOAD THE DATA
4289  SELECT CASE(wind_kind)
4290  CASE (cnstnt)
4291 
4292  write(xstr,'(f8.4)') wind_x
4293  write(ystr,'(f8.4)') wind_y
4294 
4295  IF (wind_type == speed)THEN
4296 
4297  IF(dbg_set(dbg_log)) THEN
4298  WRITE(ipt,*)"! SETTING UP CONSTANT WIND SPEED FORCING: "
4299  WRITE(ipt,*)" Xspeed: "//trim(xstr)
4300  WRITE(ipt,*)" Yspeed: "//trim(ystr)
4301  END IF
4302 
4303  ALLOCATE(winds_forcing_comments(3))
4304  winds_forcing_comments(1) = "Using constant wind speed from run file:"
4305  winds_forcing_comments(2) = "Xspeed:"//trim(xstr)
4306  winds_forcing_comments(3) = "Yspeed:"//trim(ystr)
4307  RETURN
4308  ELSEIF(wind_type == stress)THEN
4309 
4310  IF(dbg_set(dbg_log)) THEN
4311  WRITE(ipt,*)"! SETTING UP CONSTANT WIND STRESS FORCING: "
4312  WRITE(ipt,*)" Xstress: "//trim(xstr)
4313  WRITE(ipt,*)" Ystress: "//trim(ystr)
4314  END IF
4315 
4316  ALLOCATE(winds_forcing_comments(3))
4317  winds_forcing_comments(1) = "Using constant wind stress from run file:"
4318  winds_forcing_comments(2) = "Xstress:"//trim(xstr)
4319  winds_forcing_comments(3) = "Ystress:"//trim(ystr)
4320  RETURN
4321 
4322  END IF
4323 
4324  CASE(sttc)
4325 
4326  CALL fatal_error("STATIC WIND Not Set Up Yet")
4327 
4328  CASE(tmdpndnt)
4329 
4330  CALL fatal_error("TIME DEPENDANT WIND Not Set Up Yet")
4331 
4332  CASE(prdc)
4333 
4334  winds_file => find_file(filehead,trim(wind_file),found)
4335  IF(.not. found) CALL fatal_error &
4336  & ("COULD NOT FIND SURFACE WIND BOUNDARY CONDINTION FILE OBJECT",&
4337  & "FILE NAME: "//trim(wind_file))
4338 
4339  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
4340  att => find_att(winds_file,"source",found)
4341  IF(.not. found) att => find_att(winds_file,"Source",found)
4342  IF(.not. found) CALL fatal_error &
4343  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4344  & "FILE NAME: "//trim(wind_file),&
4345  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
4346 
4347 
4348  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
4349  & trim(wrf2fvcom_source)) THEN
4350  winds_forcing_type = winds_are_wrfgrid
4351 
4352  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
4353  & trim(fvcom_grid_source)) THEN
4354  winds_forcing_type = winds_are_fvcomgrid
4355 
4356  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
4357  & trim(fvcom_cap_grid_source)) THEN
4358  winds_forcing_type = winds_are_fvcomgrid
4359 
4360  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
4361  & trim(wrf_grid_source)) THEN
4362  winds_forcing_type = winds_are_wrfgrid
4363  ELSE
4364  CALL print_file(winds_file)
4365  CALL fatal_error("CAN NOT RECOGNIZE WIND FILE!",&
4366  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
4367  END IF
4368  ! GOT GRID TYPE
4369 
4370  ALLOCATE(winds_forcing_comments(4))
4371  winds_forcing_comments(1) = "FVCOM periodic surface Wind forcing:"
4372  winds_forcing_comments(2) = "FILE NAME:"//trim(wind_file)
4373 
4374  winds_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
4375 
4376  att_date => find_att(winds_file,"START_DATE",found)
4377  IF (found) THEN
4378  winds_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
4379  ELSE
4380  winds_forcing_comments(4) = "Unknown start date meta data format"
4381  END IF
4382 
4383 
4384  ! GET THE FILES LENGTH OF TIME AND SAVE FOR PERIODIC FORCING
4385 
4386  ! LOOK FOR THE DIMENSIONS
4387  dim => find_unlimited(winds_file,found)
4388  IF(.not. found) CALL fatal_error &
4389  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4390  & "FILE NAME: "//trim(wind_file),&
4391  &"COULD NOT FIND THE UNLMITIED DIMENSION")
4392 
4393  ntimes = dim%DIM
4394 
4395  winds_period = get_file_time(winds_file,ntimes)
4396 
4397  winds_period = winds_period - get_file_time(winds_file,1)
4398 
4399  IF (winds_period /= get_file_time(winds_file,ntimes)) THEN
4400 
4401  CALL print_real_time(get_file_time(winds_file,1),ipt,"FIRST FILE TIME",timezone)
4402  CALL print_real_time(get_file_time(winds_file,ntimes),ipt,"LAST FILE TIME",timezone)
4403 
4404  CALL fatal_error&
4405  &("TO USE PERIODIC FORCING THE FILE TIME MUST COUNT FROM ZERO",&
4406  & "THE DIFFERENCE BETWEEN THE CURRENT MODEL TIME AND THE START TIME,",&
4407  & "MODULO THE FORCING PERIOD, DETERMINES THE CURRENT FORCING")
4408  END IF
4409 
4410 
4411  IF(dbg_set(dbg_log)) THEN
4412  WRITE(ipt,*) "! USING PERIODIC WIND FORCING:"
4413  CALL print_time(winds_period,ipt,"PERIOD")
4414  END IF
4415 
4416 
4417  CASE(vrbl)
4418 
4419  winds_file => find_file(filehead,trim(wind_file),found)
4420  IF(.not. found) CALL fatal_error &
4421  & ("COULD NOT FIND SURFACE WIND BOUNDARY CONDINTION FILE OBJECT",&
4422  & "FILE NAME: "//trim(wind_file))
4423 
4424  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
4425  att => find_att(winds_file,"source",found)
4426  IF(.not. found) att => find_att(winds_file,"Source",found)
4427  IF(.not. found) CALL fatal_error &
4428  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4429  & "FILE NAME: "//trim(wind_file),&
4430  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
4431 
4432  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
4433  & trim(wrf2fvcom_source)) THEN
4434  winds_forcing_type = winds_are_wrfgrid
4435 
4436  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
4437  & trim(fvcom_grid_source)) THEN
4438  winds_forcing_type = winds_are_fvcomgrid
4439 
4440  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
4441  & trim(fvcom_cap_grid_source)) THEN
4442  winds_forcing_type = winds_are_fvcomgrid
4443 
4444  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
4445  & trim(wrf_grid_source)) THEN
4446  winds_forcing_type = winds_are_wrfgrid
4447  ELSE IF (att%CHR(1)(1:len_trim(surf_forcing_pt_source)) ==&
4448  & trim(surf_forcing_pt_source)) THEN
4449  winds_forcing_type = winds_are_pt_source
4450  ELSE
4451  CALL print_file(winds_file)
4452  CALL fatal_error("CAN NOT RECOGNIZE WIND FILE!",&
4453  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
4454  END IF
4455  ! GOT GRID TYPE
4456 
4457  ALLOCATE(winds_forcing_comments(4))
4458  winds_forcing_comments(1) = "FVCOM variable surface Wind forcing:"
4459  winds_forcing_comments(2) = "FILE NAME:"//trim(wind_file)
4460 
4461  winds_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
4462 
4463  att_date => find_att(winds_file,"START_DATE",found)
4464  IF (found) THEN
4465  winds_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
4466  ELSE
4467  winds_forcing_comments(4) = "Unknown start date meta data format"
4468  END IF
4469 
4470  ! LOOK FOR THE DIMENSIONS
4471  dim => find_unlimited(winds_file,found)
4472  IF(.not. found) CALL fatal_error &
4473  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4474  & "FILE NAME: "//trim(wind_file),&
4475  &"COULD NOT FIND THE UNLIMITED DIMENSION")
4476 
4477  ntimes = dim%DIM
4478 
4479  ! CHECK THE FILE TIME AND COMPARE WITH MODEL RUN TIME
4480  timetest = get_file_time(winds_file,1)
4481  IF(timetest > starttime) CALL fatal_error &
4482  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4483  & "FILE NAME: "//trim(wind_file),&
4484  &"THE MODEL RUN STARTS BEFORE THE FORCING TIME SERIES")
4485 
4486  timetest = get_file_time(winds_file,ntimes)
4487  IF(timetest < endtime) CALL fatal_error &
4488  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4489  & "FILE NAME: "//trim(wind_file),&
4490  &"THE MODEL RUN ENDS AFTER THE FORCING TIME SERIES")
4491 
4492  CASE DEFAULT
4493  CALL fatal_error("SURFACE_WINDSTRESS: UNKNOWN WIND KIND?")
4494  END SELECT
4495 
4496 !==============================================================
4497  SELECT CASE(winds_forcing_type)
4498 !==============================================================
4499  CASE(winds_are_wrfgrid)
4500 !==============================================================
4501 
4502 
4503  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
4504  & "! SETTING UP WIND STRESS FORCING FROM A 'wrf grid' FILE"
4505 
4506  dim => find_dim(winds_file,'south_north',found)
4507  IF(.not. found) CALL fatal_error &
4508  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4509  & "FILE NAME: "//trim(wind_file),&
4510  & "COULD NOT FIND DIMENSION 'south_north'")
4511 
4512  lats = dim%DIM
4513 
4514  dim => find_dim(winds_file,'west_east',found)
4515  IF(.not. found) CALL fatal_error &
4516  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4517  & "FILE NAME: "//trim(wind_file),&
4518  & "COULD NOT FIND DIMENSION 'west_east'")
4519  lons = dim%DIM
4520 
4521  CALL set_file_interp_bilinear(winds_file,winds_intp_n,winds_intp_c)
4522 
4523  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
4524 
4525  IF (wind_type == speed)THEN
4526 
4527  ! WIND SPEED IN THE X or EAST-WEST DIRECTION
4528  var => find_var(winds_file,"uwind_speed",found)
4529  IF(.not. found) var => find_var(winds_file,"U10",found)
4530  IF(.not. found) CALL fatal_error &
4531  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4532  & "FILE NAME: "//trim(wind_file),&
4533  & "COULD NOT FIND VARIABLE 'uwind_speed' or 'U10'")
4534 
4535  ELSEIF(wind_type == stress)THEN
4536  ! WIND STRESS IN THE X or EAST-WEST DIRECTION
4537  var => find_var(winds_file,"uwind_stress",found)
4538  IF(.not. found) var => find_var(winds_file,"Stress_U",found)
4539  IF(.not. found) CALL fatal_error &
4540  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4541  & "FILE NAME: "//trim(wind_file),&
4542  & "COULD NOT FIND VARIABLE 'uwind_stress' or 'Stress_U'")
4543  END IF
4544 
4545  ! MAKE SPACE FOR THE DATA FROM THE FILE
4546  ALLOCATE(storage_arr(lons,lats), stat = status)
4547  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4548  winds_strx_n => reference_var(var)
4549  CALL nc_connect_pvar(winds_strx_n,storage_arr)
4550  NULLIFY(storage_arr)
4551 
4552  ! MAKE SPACE FOR THE INTERPOLATED DATA
4553  ALLOCATE(storage_vec(0:nt), stat = status)
4554  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4555  CALL nc_connect_pvar(winds_strx_n,storage_vec)
4556  NULLIFY(storage_vec)
4557 
4558 
4559  ! MAKE SPACE FOR THE DATA FROM THE FILE
4560  ALLOCATE(storage_arr(lons,lats), stat = status)
4561  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4562  winds_strx_p => reference_var(var)
4563  CALL nc_connect_pvar(winds_strx_p,storage_arr)
4564  NULLIFY(storage_arr)
4565 
4566  ! MAKE SPACE FOR THE INTERPOLATED DATA
4567  ALLOCATE(storage_vec(0:nt), stat = status)
4568  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4569  CALL nc_connect_pvar(winds_strx_p,storage_vec)
4570  NULLIFY(storage_vec)
4571 
4572  IF (wind_type == speed)THEN
4573 
4574  ! WIND SPEED IN THE Y or NORTH SOUTH DIRECTION
4575  var => find_var(winds_file,"vwind_speed",found)
4576  IF(.not. found) var => find_var(winds_file,"V10",found)
4577  IF(.not. found) CALL fatal_error &
4578  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4579  & "FILE NAME: "//trim(wind_file),&
4580  & "COULD NOT FIND VARIABLE 'vwind_speed' or 'V10'")
4581 
4582  ELSEIF(wind_type == stress)THEN
4583  ! WIND STRESS IN THE Y or NORTH SOUTH DIRECTION
4584  var => find_var(winds_file,"vwind_stress",found)
4585  IF(.not. found) var => find_var(winds_file,"Stress_V",found)
4586  IF(.not. found) CALL fatal_error &
4587  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4588  & "FILE NAME: "//trim(wind_file),&
4589  & "COULD NOT FIND VARIABLE 'vwind_stress' or 'Stress_V'")
4590  END IF
4591 
4592  ! MAKE SPACE FOR THE DATA FROM THE FILE
4593  ALLOCATE(storage_arr(lons,lats), stat = status)
4594  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4595  winds_stry_n => reference_var(var)
4596  CALL nc_connect_pvar(winds_stry_n,storage_arr)
4597  NULLIFY(storage_arr)
4598 
4599  ! MAKE SPACE FOR THE INTERPOLATED DATA
4600  ALLOCATE(storage_vec(0:nt), stat = status)
4601  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4602  CALL nc_connect_pvar(winds_stry_n,storage_vec)
4603  NULLIFY(storage_vec)
4604 
4605 
4606  ! MAKE SPACE FOR THE DATA FROM THE FILE
4607  ALLOCATE(storage_arr(lons,lats), stat = status)
4608  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4609  winds_stry_p => reference_var(var)
4610  CALL nc_connect_pvar(winds_stry_p,storage_arr)
4611  NULLIFY(storage_arr)
4612 
4613  ! MAKE SPACE FOR THE INTERPOLATED DATA
4614  ALLOCATE(storage_vec(0:nt), stat = status)
4615  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4616  CALL nc_connect_pvar(winds_stry_p,storage_vec)
4617  NULLIFY(storage_vec)
4618 
4619 
4620 !==============================================================
4621  CASE(winds_are_fvcomgrid)
4622 !==============================================================
4623  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
4624  & "! SETTING UP WIND STRESS FORCING FROM A 'FVCOM GRID' FILE"
4625 
4626  dim => find_dim(winds_file,'node',found)
4627  IF(.not. found) CALL fatal_error &
4628  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4629  & "FILE NAME: "//trim(wind_file),&
4630  & "COULD NOT FIND DIMENSION 'node'")
4631 
4632  if (mgl /= dim%dim) CALL fatal_error&
4633  &("Surface Windstress: the number of nodes in the file does not match the fvcom grid?")
4634 
4635  dim => find_dim(winds_file,'nele',found)
4636  IF(.not. found) CALL fatal_error &
4637  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4638  & "FILE NAME: "//trim(wind_file),&
4639  & "COULD NOT FIND DIMENSION 'nele'")
4640 
4641  if (ngl /= dim%dim) CALL fatal_error&
4642  &("Surface Windstress: the number of elements in the file does not match the fvcom grid?")
4643 
4644 
4645  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
4646 
4647  IF (wind_type == speed)THEN
4648 
4649  ! WIND SPEED IN THE X or EAST-WEST DIRECTION
4650  var => find_var(winds_file,"uwind_speed",found)
4651  IF(.not. found) var => find_var(winds_file,"U10",found)
4652  IF(.not. found) CALL fatal_error &
4653  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4654  & "FILE NAME: "//trim(wind_file),&
4655  & "COULD NOT FIND VARIABLE 'uwind_speed' or 'U10'")
4656 
4657  ELSEIF(wind_type == stress)THEN
4658 
4659  ! WIND STRESS IN THE X or EAST-WEST DIRECTION
4660  var => find_var(winds_file,"uwind_stress",found)
4661  IF(.not. found) CALL fatal_error &
4662  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4663  & "FILE NAME: "//trim(wind_file),&
4664  & "COULD NOT FIND VARIABLE 'uwind_stress'")
4665 
4666  END IF
4667 
4668  ! MAKE SPACE FOR THE DATA FROM THE FILE
4669  winds_strx_n => reference_var(var)
4670  ALLOCATE(storage_vec(0:nt), stat = status)
4671  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4672  CALL nc_connect_pvar(winds_strx_n,storage_vec)
4673  NULLIFY(storage_vec)
4674 
4675 
4676  ! MAKE SPACE FOR THE DATA FROM THE FILE
4677  winds_strx_p => reference_var(var)
4678  ALLOCATE(storage_vec(0:nt), stat = status)
4679  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4680  CALL nc_connect_pvar(winds_strx_p,storage_vec)
4681  NULLIFY(storage_vec)
4682 
4683  IF (wind_type == speed)THEN
4684 
4685  ! WIND SPEED IN THE Y or NORTH SOUTH DIRECTION
4686  var => find_var(winds_file,"vwind_speed",found)
4687  IF(.not. found) var => find_var(winds_file,"V10",found)
4688  IF(.not. found) CALL fatal_error &
4689  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4690  & "FILE NAME: "//trim(wind_file),&
4691  & "COULD NOT FIND VARIABLE 'vwind_speed' or 'V10'")
4692  ELSEIF(wind_type == stress)THEN
4693 
4694  ! WIND STRESS IN THE Y or NORTH SOUTH DIRECTION
4695  var => find_var(winds_file,"vwind_stress",found)
4696  IF(.not. found) CALL fatal_error &
4697  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4698  & "FILE NAME: "//trim(wind_file),&
4699  & "COULD NOT FIND VARIABLE 'vwind_stress'")
4700  END IF
4701 
4702  ! MAKE SPACE FOR THE DATA FROM THE FILE
4703  winds_stry_n => reference_var(var)
4704  ALLOCATE(storage_vec(0:nt), stat = status)
4705  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4706  CALL nc_connect_pvar(winds_stry_n,storage_vec)
4707  NULLIFY(storage_vec)
4708 
4709 
4710  ! MAKE SPACE FOR THE DATA FROM THE FILE
4711  winds_stry_p => reference_var(var)
4712  ALLOCATE(storage_vec(0:nt), stat = status)
4713  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4714  CALL nc_connect_pvar(winds_stry_p,storage_vec)
4715  NULLIFY(storage_vec)
4716 
4717 !==============================================================
4718  CASE(winds_are_pt_source)
4719 !==============================================================
4720  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
4721  & "! SETTING UP WIND STRESS FORCING FROM A 'FVCOM GRID' FILE"
4722 
4723 
4724  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
4725 
4726  IF (wind_type == speed)THEN
4727 
4728  ! WIND SPEED IN THE X or EAST-WEST DIRECTION
4729  var => find_var(winds_file,"uwind_speed",found)
4730  IF(.not. found) var => find_var(winds_file,"U10",found)
4731  IF(.not. found) CALL fatal_error &
4732  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4733  & "FILE NAME: "//trim(wind_file),&
4734  & "COULD NOT FIND VARIABLE 'uwind_speed' or 'U10'")
4735 
4736  ELSEIF(wind_type == stress)THEN
4737 
4738  ! WIND STRESS IN THE X or EAST-WEST DIRECTION
4739  var => find_var(winds_file,"uwind_stress",found)
4740  IF(.not. found) CALL fatal_error &
4741  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4742  & "FILE NAME: "//trim(wind_file),&
4743  & "COULD NOT FIND VARIABLE 'uwind_stress'")
4744 
4745  END IF
4746 
4747  ! MAKE SPACE FOR THE DATA FROM THE FILE
4748  winds_strx_n => reference_var(var)
4749  ALLOCATE(storage_vec(1), stat = status)
4750  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4751  CALL nc_connect_pvar(winds_strx_n,storage_vec)
4752  NULLIFY(storage_vec)
4753 
4754 
4755  ! MAKE SPACE FOR THE DATA FROM THE FILE
4756  winds_strx_p => reference_var(var)
4757  ALLOCATE(storage_vec(1), stat = status)
4758  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4759  CALL nc_connect_pvar(winds_strx_p,storage_vec)
4760  NULLIFY(storage_vec)
4761 
4762  IF (wind_type == speed)THEN
4763 
4764  ! WIND SPEED IN THE Y or NORTH SOUTH DIRECTION
4765  var => find_var(winds_file,"vwind_speed",found)
4766  IF(.not. found) var => find_var(winds_file,"V10",found)
4767  IF(.not. found) CALL fatal_error &
4768  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4769  & "FILE NAME: "//trim(wind_file),&
4770  & "COULD NOT FIND VARIABLE 'vwind_speed' or 'V10'")
4771  ELSEIF(wind_type == stress)THEN
4772 
4773  ! WIND STRESS IN THE Y or NORTH SOUTH DIRECTION
4774  var => find_var(winds_file,"vwind_stress",found)
4775  IF(.not. found) CALL fatal_error &
4776  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
4777  & "FILE NAME: "//trim(wind_file),&
4778  & "COULD NOT FIND VARIABLE 'vwind_stress'")
4779  END IF
4780 
4781  ! MAKE SPACE FOR THE DATA FROM THE FILE
4782  winds_stry_n => reference_var(var)
4783  ALLOCATE(storage_vec(1), stat = status)
4784  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4785  CALL nc_connect_pvar(winds_stry_n,storage_vec)
4786  NULLIFY(storage_vec)
4787 
4788 
4789  ! MAKE SPACE FOR THE DATA FROM THE FILE
4790  winds_stry_p => reference_var(var)
4791  ALLOCATE(storage_vec(1), stat = status)
4792  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE WINDSTRESS")
4793  CALL nc_connect_pvar(winds_stry_p,storage_vec)
4794  NULLIFY(storage_vec)
4795 
4796 !==============================================================
4797  CASE DEFAULT
4798 !==============================================================
4799  CALL fatal_error("CAN NOT RECOGNIZE WIND FILE TYPE!")
4800 !==============================================================
4801  END SELECT
4802 !==============================================================
4803 
4804  ! ---------- new: 2016 , april, after Hint by Qi -------------------------
4805  ! Initialize some variables
4806  ! afm 20150914
4807  ! Need initialization. Otherwise, random values are asigned
4808  ! and cause a hanging problem of MPI job in UPDATE_VAR_BRACKET
4809  ! This problem reported with Intel15.0.3.
4810  winds_strx_n%curr_stkcnt = 0; winds_strx_p%curr_stkcnt = 0
4811  winds_stry_n%curr_stkcnt = 0; winds_stry_p%curr_stkcnt = 0
4812  ! -------- end new ---------------------------------------------
4813 
4814  IF(dbg_set(dbg_sbr)) write(ipt,*) "END SURFACE_WINDSTRESS"
4815  END SUBROUTINE surface_windstress
4816 
4817 !================================================================
4818 
4819 
4820 
4821 
4822 
4823 
4824 
4825 
4826 
4827 
4828 
4829 
4830 
4831 !================================================================
4832  SUBROUTINE surface_wave
4833  IMPLICIT NONE
4834  ! SOME NC POINTERS
4835  TYPE(ncatt), POINTER :: att, att_date
4836  TYPE(ncdim), POINTER :: dim
4837  TYPE(ncvar), POINTER :: var
4838  LOGICAL :: found
4839  REAL(sp), POINTER :: storage_arr(:,:), storage_vec(:)
4840  TYPE(time) :: timetest
4841  INTEGER :: lats, lons, i, ntimes
4842  INTEGER :: status
4843  CHARACTER(len=60) :: w_hs, w_len,w_dir,w_per,w_per_bot,w_ub_bot
4844 
4845  IF(dbg_set(dbg_sbr)) write(ipt,*) "START SURFACE_WAVE"
4846 
4847  NULLIFY(att,dim,var,storage_arr,storage_vec)
4848 
4849 
4850  IF (.NOT. wave_on ) THEN
4851  IF(dbg_set(dbg_log)) write(ipt,*) "! SURFACE WAVE FORCING IS OFF!"
4852  ALLOCATE(waves_forcing_comments(1))
4853  waves_forcing_comments(1) = "SURFACE WAVE FORCING IS OFF"
4854  RETURN
4855  END IF
4856 
4857 
4858 ! DETERMINE HOW TO LOAD THE DATA
4859  SELECT CASE(wave_kind)
4860  CASE (cnstnt)
4861 
4862  write(w_hs, '(f8.4)') wave_height
4863  write(w_len, '(f8.4)') wave_length
4864  write(w_dir, '(f8.4)') wave_direction
4865  write(w_per, '(f8.4)') wave_period
4866  write(w_per_bot,'(f8.4)') wave_per_bot
4867  write(w_ub_bot, '(f8.4)') wave_ub_bot
4868 
4869 
4870  IF(dbg_set(dbg_log)) THEN
4871  WRITE(ipt,*)"! SETTING UP CONSTANT SURFACE WAVE FORCING: "
4872  WRITE(ipt,*)" wave height : "//trim(w_hs)
4873  WRITE(ipt,*)" wave length : "//trim(w_len)
4874  WRITE(ipt,*)" wave direction: "//trim(w_dir)
4875  WRITE(ipt,*)" wave period : "//trim(w_per)
4876  WRITE(ipt,*)" wave per_bot : "//trim(w_per_bot)
4877  WRITE(ipt,*)" wave ub_bot : "//trim(w_ub_bot)
4878  END IF
4879 
4880  ALLOCATE(waves_forcing_comments(7))
4881  waves_forcing_comments(1) = "Using constant surface wave from run file:"
4882  waves_forcing_comments(2) = " wave height : "//trim(w_hs)
4883  waves_forcing_comments(3) = " wave length : "//trim(w_len)
4884  waves_forcing_comments(4) = " wave direction: "//trim(w_dir)
4885  waves_forcing_comments(5) = " wave period : "//trim(w_per)
4886  waves_forcing_comments(6) = " wave per_bot : "//trim(w_per_bot)
4887  waves_forcing_comments(7) = " wave ub_bot : "//trim(w_ub_bot)
4888  RETURN
4889 
4890 
4891  CASE(sttc)
4892 
4893  CALL fatal_error("STATIC WAVE Not Set Up Yet")
4894 
4895  CASE(tmdpndnt)
4896 
4897  CALL fatal_error("TIME DEPENDANT WAVE Not Set Up Yet")
4898 
4899  CASE(prdc)
4900 
4901  waves_file => find_file(filehead,trim(wave_file),found)
4902  IF(.not. found) CALL fatal_error &
4903  & ("COULD NOT FIND SURFACE WAVE BOUNDARY CONDINTION FILE OBJECT",&
4904  & "FILE NAME: "//trim(wave_file))
4905 
4906  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
4907  att => find_att(waves_file,"source",found)
4908  IF(.not. found) att => find_att(waves_file,"Source",found)
4909  IF(.not. found) CALL fatal_error &
4910  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
4911  & "FILE NAME: "//trim(wave_file),&
4912  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
4913 
4914 
4915  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
4916  & trim(wrf2fvcom_source)) THEN
4917  waves_forcing_type = waves_are_wrfgrid
4918 
4919  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
4920  & trim(fvcom_grid_source)) THEN
4921  waves_forcing_type = waves_are_fvcomgrid
4922 
4923  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
4924  & trim(fvcom_cap_grid_source)) THEN
4925  waves_forcing_type = waves_are_fvcomgrid
4926 
4927  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
4928  & trim(wrf_grid_source)) THEN
4929  waves_forcing_type = waves_are_wrfgrid
4930 
4931  ELSE
4932  CALL print_file(waves_file)
4933  CALL fatal_error("CAN NOT RECOGNIZE WAVE FILE!",&
4934  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
4935  END IF
4936  ! GOT GRID TYPE
4937 
4938  ALLOCATE(waves_forcing_comments(4))
4939  waves_forcing_comments(1) = "FVCOM periodic surface wave forcing:"
4940  waves_forcing_comments(2) = "FILE NAME:"//trim(wave_file)
4941 
4942  waves_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
4943 
4944  att_date => find_att(waves_file,"START_DATE",found)
4945  IF (found) THEN
4946  waves_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
4947  ELSE
4948  waves_forcing_comments(4) = "Unknown start date meta data format"
4949  END IF
4950 
4951 
4952  ! GET THE FILES LENGTH OF TIME AND SAVE FOR PERIODIC FORCING
4953 
4954  ! LOOK FOR THE DIMENSIONS
4955  dim => find_unlimited(waves_file,found)
4956  IF(.not. found) CALL fatal_error &
4957  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
4958  & "FILE NAME: "//trim(wave_file),&
4959  &"COULD NOT FIND THE UNLMITIED DIMENSION")
4960 
4961  ntimes = dim%DIM
4962 
4963  waves_period = get_file_time(waves_file,ntimes)
4964 
4965  waves_period = waves_period - get_file_time(waves_file,1)
4966 
4967  IF (waves_period /= get_file_time(waves_file,ntimes)) THEN
4968 
4969  CALL print_real_time(get_file_time(waves_file,1),ipt,"FIRST FILE TIME",timezone)
4970  CALL print_real_time(get_file_time(waves_file,ntimes),ipt,"LAST FILE TIME",timezone)
4971 
4972  CALL fatal_error&
4973  &("TO USE PERIODIC FORCING THE FILE TIME MUST COUNT FROM ZERO",&
4974  & "THE DIFFERENCE BETWEEN THE CURRENT MODEL TIME AND THE START TIME,",&
4975  & "MODULO THE FORCING PERIOD, DETERMINES THE CURRENT FORCING")
4976  END IF
4977 
4978 
4979  IF(dbg_set(dbg_log)) THEN
4980  WRITE(ipt,*) "! USING PERIODIC WAVE FORCING:"
4981  CALL print_time(waves_period,ipt,"PERIOD")
4982  END IF
4983 
4984 
4985  CASE(vrbl)
4986 
4987  waves_file => find_file(filehead,trim(wave_file),found)
4988  IF(.not. found) CALL fatal_error &
4989  & ("COULD NOT FIND SURFACE WAVE BOUNDARY CONDINTION FILE OBJECT",&
4990  & "FILE NAME: "//trim(wave_file))
4991 
4992  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
4993  att => find_att(waves_file,"source",found)
4994  IF(.not. found) att => find_att(waves_file,"Source",found)
4995  IF(.not. found) CALL fatal_error &
4996  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
4997  & "FILE NAME: "//trim(wave_file),&
4998  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
4999 
5000  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
5001  & trim(wrf2fvcom_source)) THEN
5002  waves_forcing_type = waves_are_wrfgrid
5003 
5004  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
5005  & trim(fvcom_grid_source).or.(att%CHR(1)(1:5)=='fvcom')) THEN
5006  waves_forcing_type = waves_are_fvcomgrid
5007 
5008  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
5009  & trim(fvcom_cap_grid_source).or.(att%CHR(1)(1:5)=='FVCOM')) THEN
5010  waves_forcing_type = waves_are_fvcomgrid
5011 
5012  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
5013  & trim(wrf_grid_source)) THEN
5014  waves_forcing_type = waves_are_wrfgrid
5015 
5016  ELSE
5017  CALL print_file(waves_file)
5018  CALL fatal_error("CAN NOT RECOGNIZE WAVE FILE!",&
5019  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
5020  END IF
5021  ! GOT GRID TYPE
5022 
5023  ALLOCATE(waves_forcing_comments(4))
5024  waves_forcing_comments(1) = "FVCOM variable surface wave forcing:"
5025  waves_forcing_comments(2) = "FILE NAME:"//trim(wave_file)
5026 
5027  waves_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
5028 
5029  att_date => find_att(waves_file,"START_DATE",found)
5030  IF (found) THEN
5031  waves_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
5032  ELSE
5033  waves_forcing_comments(4) = "Unknown start date meta data format"
5034  END IF
5035 
5036  ! LOOK FOR THE DIMENSIONS
5037  dim => find_unlimited(waves_file,found)
5038  IF(.not. found) CALL fatal_error &
5039  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
5040  & "FILE NAME: "//trim(wave_file),&
5041  &"COULD NOT FIND THE UNLIMITED DIMENSION")
5042 
5043  ntimes = dim%DIM
5044 
5045  ! CHECK THE FILE TIME AND COMPARE WITH MODEL RUN TIME
5046  timetest = get_file_time(waves_file,1)
5047  IF(timetest > starttime) CALL fatal_error &
5048  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
5049  & "FILE NAME: "//trim(wave_file),&
5050  &"THE MODEL RUN STARTS BEFORE THE FORCING TIME SERIES")
5051 
5052  timetest = get_file_time(waves_file,ntimes)
5053  IF(timetest < endtime) CALL fatal_error &
5054  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
5055  & "FILE NAME: "//trim(wave_file),&
5056  &"THE MODEL RUN ENDS AFTER THE FORCING TIME SERIES")
5057 
5058  CASE DEFAULT
5059  CALL fatal_error("SURFACE_WAVE: UNKNOWN WAVE KIND?")
5060  END SELECT
5061 
5062 !==============================================================
5063  SELECT CASE(waves_forcing_type)
5064 !==============================================================
5065  CASE(waves_are_wrfgrid)
5066 !==============================================================
5067 
5068  CALL fatal_error("WAVE based on WRF grid Not Set Up Yet")
5069 
5070 !==============================================================
5071  CASE(waves_are_fvcomgrid)
5072 !==============================================================
5073  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
5074  & "! SETTING UP WAVE FORCING FROM A 'FVCOM GRID' FILE"
5075 
5076  dim => find_dim(waves_file,'node',found)
5077  IF(.not. found) CALL fatal_error &
5078  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
5079  & "FILE NAME: "//trim(wave_file),&
5080  & "COULD NOT FIND DIMENSION 'node'")
5081 
5082  if (mgl /= dim%dim) CALL fatal_error&
5083  &("Surface Wave: the number of nodes in the file does not match the fvcom grid?")
5084 
5085 
5086  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
5087 
5088 
5089 
5090  ! WAVE HEIGHT
5091  var => find_var(waves_file,"hs",found)
5092  IF(.not. found) CALL fatal_error &
5093  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
5094  & "FILE NAME: "//trim(wave_file),&
5095  & "COULD NOT FIND VARIABLE 'hs' ")
5096 
5097 
5098  ! MAKE SPACE FOR THE DATA FROM THE FILE
5099  waves_height_n => reference_var(var)
5100  ALLOCATE(storage_vec(0:mt), stat = status)
5101  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN WAVE HEIGHT")
5102  CALL nc_connect_pvar(waves_height_n,storage_vec)
5103  NULLIFY(storage_vec)
5104 
5105 
5106  ! MAKE SPACE FOR THE DATA FROM THE FILE
5107  waves_height_p => reference_var(var)
5108  ALLOCATE(storage_vec(0:mt), stat = status)
5109  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN WAVE HEIGHT")
5110  CALL nc_connect_pvar(waves_height_p,storage_vec)
5111  NULLIFY(storage_vec)
5112 
5113 
5114  ! WAVE LENGTH
5115  var => find_var(waves_file,"wlen",found)
5116  IF(.not. found) CALL fatal_error &
5117  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
5118  & "FILE NAME: "//trim(wave_file),&
5119  & "COULD NOT FIND VARIABLE 'wlen' ")
5120 
5121 
5122  ! MAKE SPACE FOR THE DATA FROM THE FILE
5123  waves_length_n => reference_var(var)
5124  ALLOCATE(storage_vec(0:mt), stat = status)
5125  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN WAVE LENGTH")
5126  CALL nc_connect_pvar(waves_length_n,storage_vec)
5127  NULLIFY(storage_vec)
5128 
5129 
5130  ! MAKE SPACE FOR THE DATA FROM THE FILE
5131  waves_length_p => reference_var(var)
5132  ALLOCATE(storage_vec(0:mt), stat = status)
5133  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN WAVE LENGTH")
5134  CALL nc_connect_pvar(waves_length_p,storage_vec)
5135  NULLIFY(storage_vec)
5136 
5137  ! WAVE DIRECTION
5138  var => find_var(waves_file,"dirm",found)
5139  IF(.not. found) var => find_var(waves_file,"wdir",found)
5140  IF(.not. found) CALL fatal_error &
5141  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
5142  & "FILE NAME: "//trim(wave_file),&
5143  & "COULD NOT FIND VARIABLE 'dirm' or 'wdir' ")
5144 
5145  ! MAKE SPACE FOR THE DATA FROM THE FILE
5146  waves_direction_n => reference_var(var)
5147  ALLOCATE(storage_vec(0:mt), stat = status)
5148  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN WAVE DIRECTION")
5149  CALL nc_connect_pvar(waves_direction_n,storage_vec)
5150  NULLIFY(storage_vec)
5151 
5152  ! MAKE SPACE FOR THE DATA FROM THE FILE
5153  waves_direction_p => reference_var(var)
5154  ALLOCATE(storage_vec(0:mt), stat = status)
5155  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN WAVE DIRECTION")
5156  CALL nc_connect_pvar(waves_direction_p,storage_vec)
5157  NULLIFY(storage_vec)
5158 
5159  ! WAVE PERIOD
5160  var => find_var(waves_file,"tpeak",found)
5161  IF(.not. found) CALL fatal_error &
5162  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
5163  & "FILE NAME: "//trim(wave_file),&
5164  & "COULD NOT FIND VARIABLE 'tpeak' ")
5165 
5166 
5167  ! MAKE SPACE FOR THE DATA FROM THE FILE
5168  waves_period_n => reference_var(var)
5169  ALLOCATE(storage_vec(0:mt), stat = status)
5170  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN WAVE PERIOD")
5171  CALL nc_connect_pvar(waves_period_n,storage_vec)
5172  NULLIFY(storage_vec)
5173 
5174 
5175  ! MAKE SPACE FOR THE DATA FROM THE FILE
5176  waves_period_p => reference_var(var)
5177  ALLOCATE(storage_vec(0:mt), stat = status)
5178  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN WAVE PERIOD")
5179  CALL nc_connect_pvar(waves_period_p,storage_vec)
5180  NULLIFY(storage_vec)
5181 
5182 
5183  ! BOTTOM WAVE PERIOD
5184  var => find_var(waves_file,"pwave_bot",found)
5185  IF(.not. found) var => find_var(waves_file,"tmbot",found)
5186  IF(.not. found) CALL fatal_error &
5187  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
5188  & "FILE NAME: "//trim(wave_file),&
5189  & "COULD NOT FIND VARIABLE 'pwave_bot' or 'tmbot' ")
5190 
5191 
5192  ! MAKE SPACE FOR THE DATA FROM THE FILE
5193  waves_per_bot_n => reference_var(var)
5194  ALLOCATE(storage_vec(0:mt), stat = status)
5195  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN BOTTOM WAVE PERIOD")
5196  CALL nc_connect_pvar(waves_per_bot_n,storage_vec)
5197  NULLIFY(storage_vec)
5198 
5199 
5200  ! MAKE SPACE FOR THE DATA FROM THE FILE
5201  waves_per_bot_p => reference_var(var)
5202  ALLOCATE(storage_vec(0:mt), stat = status)
5203  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN BOTTOM WAVE PERIOD")
5204  CALL nc_connect_pvar(waves_per_bot_p,storage_vec)
5205  NULLIFY(storage_vec)
5206 
5207 
5208  ! BOTTOM ORBITAL VELOCITY
5209  var => find_var(waves_file,"ub_bot",found)
5210  IF(.not. found) var => find_var(waves_file,"ubot",found)
5211  IF(.not. found) CALL fatal_error &
5212  & ("IN SURFACE WAVE BOUNDARY CONDITION FILE OBJECT",&
5213  & "FILE NAME: "//trim(wave_file),&
5214  & "COULD NOT FIND VARIABLE 'ub_bot' or 'ubot' ")
5215 
5216 
5217  ! MAKE SPACE FOR THE DATA FROM THE FILE
5218  waves_ub_bot_n => reference_var(var)
5219  ALLOCATE(storage_vec(0:mt), stat = status)
5220  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN BOTTOM WAVE ORBITAL VELOCITY")
5221  CALL nc_connect_pvar(waves_ub_bot_n,storage_vec)
5222  NULLIFY(storage_vec)
5223 
5224 
5225  ! MAKE SPACE FOR THE DATA FROM THE FILE
5226  waves_ub_bot_p => reference_var(var)
5227  ALLOCATE(storage_vec(0:mt), stat = status)
5228  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN BOTTOM WAVE ORBITAL VELOCITY")
5229  CALL nc_connect_pvar(waves_ub_bot_p,storage_vec)
5230  NULLIFY(storage_vec)
5231 
5232 
5233 
5234 !==============================================================
5235  CASE DEFAULT
5236 !==============================================================
5237  CALL fatal_error("CAN NOT RECOGNIZE WAVE FILE TYPE!")
5238 !==============================================================
5239  END SELECT
5240 !==============================================================
5241 
5242  IF(dbg_set(dbg_sbr)) write(ipt,*) "END SURFACE_WAVE"
5243  END SUBROUTINE surface_wave
5244 
5245 !================================================================
5246 
5247 
5248 
5249 !================================================================
5250  SUBROUTINE surface_airpressure
5251  IMPLICIT NONE
5252  ! SOME NC POINTERS
5253  TYPE(ncatt), POINTER :: att, att_date
5254  TYPE(ncdim), POINTER :: dim
5255  TYPE(ncvar), POINTER :: var
5256  LOGICAL :: found
5257  REAL(sp), POINTER :: storage_arr(:,:), storage_vec(:)
5258  TYPE(time) :: timetest
5259  INTEGER :: lats, lons, i, ntimes
5260  INTEGER :: status
5261  CHARACTER(len=60) :: airpressurestr
5262 
5263  IF(dbg_set(dbg_sbr)) write(ipt,*) "START SURFACE_AIRPRESSURE"
5264 
5265  NULLIFY(att,dim,var,storage_arr,storage_vec)
5266 
5267 
5268  IF (.NOT. airpressure_on ) THEN
5269  IF(dbg_set(dbg_log)) write(ipt,*) "! SURFACE AIR PRESSURE FORCING IS OFF!"
5270  ALLOCATE(airpressure_forcing_comments(1))
5271  airpressure_forcing_comments(1) = "SURFACE AIR PRESSURE FORCING IS OFF"
5272  RETURN
5273  END IF
5274 
5275 
5276 ! DETERMINE HOW TO LOAD THE DATA
5277  SELECT CASE(airpressure_kind)
5278  CASE (cnstnt)
5279 
5280  write(airpressurestr,'(f8.4)') airpressure_value
5281 
5282 
5283  IF(dbg_set(dbg_log)) THEN
5284  WRITE(ipt,*)"! SETTING UP CONSTANT AIR PRESSURE FORCING: "
5285  WRITE(ipt,*)" Air pressure: "//trim(airpressurestr)
5286  END IF
5287 
5288  ALLOCATE(airpressure_forcing_comments(3))
5289  airpressure_forcing_comments(1) = "Using constant air pressure from run file:"
5290  airpressure_forcing_comments(2) = "Air pressure:"//trim(airpressurestr)
5291  RETURN
5292 
5293  CASE(sttc)
5294 
5295  CALL fatal_error("STATIC AIR PRESSURE Not Set Up Yet")
5296 
5297  CASE(tmdpndnt)
5298 
5299  CALL fatal_error("TIME DEPENDANT AIR PRESSURE Not Set Up Yet")
5300 
5301  CASE(prdc)
5302 
5303  airpressure_p_file => find_file(filehead,trim(airpressure_file),found)
5304  IF(.not. found) CALL fatal_error &
5305  & ("COULD NOT FIND SURFACE AIR PRESSURE FILE OBJECT",&
5306  & "FILE NAME: "//trim(airpressure_file))
5307 
5308  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
5309  att => find_att(airpressure_p_file,"source",found)
5310  IF(.not. found) att => find_att(airpressure_p_file,"Source",found)
5311  IF(.not. found) CALL fatal_error &
5312  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5313  & "FILE NAME: "//trim(airpressure_file),&
5314  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
5315 
5316 
5317  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
5318  & trim(wrf2fvcom_source)) THEN
5319  airpressure_forcing_type = airpressure_is_wrfgrid
5320 
5321  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
5322  & trim(fvcom_grid_source)) THEN
5323  airpressure_forcing_type = airpressure_is_fvcomgrid
5324 
5325  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
5326  & trim(fvcom_cap_grid_source)) THEN
5327  airpressure_forcing_type = airpressure_is_fvcomgrid
5328 
5329  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
5330  & trim(wrf_grid_source)) THEN
5331  airpressure_forcing_type = airpressure_is_wrfgrid
5332 
5333  ELSE
5334  CALL print_file(airpressure_p_file)
5335  CALL fatal_error("CAN NOT RECOGNIZE AIR PRESSURE FILE!",&
5336  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
5337  END IF
5338  ! GOT GRID TYPE
5339 
5340  ALLOCATE(airpressure_forcing_comments(4))
5341  airpressure_forcing_comments(1) = "FVCOM periodic surface Air Pressure forcing:"
5342  airpressure_forcing_comments(2) = "FILE NAME:"//trim(airpressure_file)
5343 
5344  airpressure_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
5345 
5346  att_date => find_att(airpressure_p_file,"START_DATE",found)
5347  IF (found) THEN
5348  airpressure_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
5349  ELSE
5350  airpressure_forcing_comments(4) = "Unknown start date meta data format"
5351  END IF
5352 
5353 
5354  ! GET THE FILES LENGTH OF TIME AND SAVE FOR PERIODIC FORCING
5355 
5356  ! LOOK FOR THE DIMENSIONS
5357  dim => find_unlimited(airpressure_p_file,found)
5358  IF(.not. found) CALL fatal_error &
5359  & ("IN AIR PRESSURE FILE OBJECT",&
5360  & "FILE NAME: "//trim(airpressure_file),&
5361  &"COULD NOT FIND THE UNLMITIED DIMENSION")
5362 
5363  ntimes = dim%DIM
5364 
5365  airpressure_period = get_file_time(airpressure_p_file,ntimes)
5366 
5367  airpressure_period = airpressure_period - get_file_time(airpressure_p_file,1)
5368 
5369  IF (airpressure_period /= get_file_time(airpressure_p_file,ntimes)) THEN
5370 
5371  CALL print_real_time(get_file_time(airpressure_p_file,1),ipt,"FIRST FILE TIME",timezone)
5372  CALL print_real_time(get_file_time(airpressure_p_file,ntimes),ipt,"LAST FILE TIME",timezone)
5373 
5374  CALL fatal_error&
5375  &("TO USE PERIODIC FORCING THE FILE TIME MUST COUNT FROM ZERO",&
5376  & "THE DIFFERENCE BETWEEN THE CURRENT MODEL TIME AND THE START TIME,",&
5377  & "MODULO THE FORCING PERIOD, DETERMINES THE CURRENT FORCING")
5378  END IF
5379 
5380 
5381  IF(dbg_set(dbg_log)) THEN
5382  WRITE(ipt,*) "! USING PERIODIC AIR PRESSURE FORCING:"
5383  CALL print_time(airpressure_period,ipt,"PERIOD")
5384  END IF
5385 
5386 
5387  CASE(vrbl)
5388 
5389  airpressure_p_file => find_file(filehead,trim(airpressure_file),found)
5390  IF(.not. found) CALL fatal_error &
5391  & ("COULD NOT FIND SURFACE AIR PRESSURE FILE OBJECT",&
5392  & "FILE NAME: "//trim(airpressure_file))
5393 
5394  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
5395  att => find_att(airpressure_p_file,"source",found)
5396  IF(.not. found) att => find_att(airpressure_p_file,"Source",found)
5397  IF(.not. found) CALL fatal_error &
5398  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5399  & "FILE NAME: "//trim(airpressure_file),&
5400  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
5401 
5402  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
5403  & trim(wrf2fvcom_source)) THEN
5404  airpressure_forcing_type = airpressure_is_wrfgrid
5405 
5406  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
5407  & trim(fvcom_grid_source)) THEN
5408  airpressure_forcing_type = airpressure_is_fvcomgrid
5409 
5410  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
5411  & trim(fvcom_cap_grid_source)) THEN
5412  airpressure_forcing_type = airpressure_is_fvcomgrid
5413 
5414  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
5415  & trim(wrf_grid_source)) THEN
5416  airpressure_forcing_type = airpressure_is_wrfgrid
5417 
5418  ELSE
5419  CALL print_file(airpressure_p_file)
5420  CALL fatal_error("CAN NOT RECOGNIZE AIR PRESSURE FILE!",&
5421  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
5422  END IF
5423  ! GOT GRID TYPE
5424 
5425  ALLOCATE(airpressure_forcing_comments(4))
5426  airpressure_forcing_comments(1) = "FVCOM variable surface Air Pressure:"
5427  airpressure_forcing_comments(2) = "FILE NAME:"//trim(airpressure_file)
5428 
5429  airpressure_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
5430 
5431  att_date => find_att(airpressure_p_file,"START_DATE",found)
5432  IF (found) THEN
5433  airpressure_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
5434  ELSE
5435  airpressure_forcing_comments(4) = "Unknown start date meta data format"
5436  END IF
5437 
5438  ! LOOK FOR THE DIMENSIONS
5439  dim => find_unlimited(airpressure_p_file,found)
5440  IF(.not. found) CALL fatal_error &
5441  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5442  & "FILE NAME: "//trim(airpressure_file),&
5443  &"COULD NOT FIND THE UNLIMITED DIMENSION")
5444 
5445  ntimes = dim%DIM
5446 
5447  ! CHECK THE FILE TIME AND COMPARE WITH MODEL RUN TIME
5448  timetest = get_file_time(airpressure_p_file,1)
5449  IF(timetest > starttime) CALL fatal_error &
5450  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5451  & "FILE NAME: "//trim(airpressure_file),&
5452  &"THE MODEL RUN STARTS BEFORE THE FORCING TIME SERIES")
5453 
5454  timetest = get_file_time(airpressure_p_file,ntimes)
5455  IF(timetest < endtime) CALL fatal_error &
5456  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5457  & "FILE NAME: "//trim(airpressure_file),&
5458  &"THE MODEL RUN ENDS AFTER THE FORCING TIME SERIES")
5459 
5460  CASE DEFAULT
5461  CALL fatal_error("SURFACE_AIRPRESSURE: UNKNOWN ARE PRESSURE KIND?")
5462  END SELECT
5463 
5464 !==============================================================
5465  SELECT CASE(airpressure_forcing_type)
5466 !==============================================================
5467  CASE(airpressure_is_wrfgrid)
5468 !==============================================================
5469 
5470 
5471  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
5472  & "! SETTING UP AIR PRESSURE FORCING FROM A 'wrf grid' FILE"
5473 
5474  dim => find_dim(airpressure_p_file,'south_north',found)
5475  IF(.not. found) CALL fatal_error &
5476  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5477  & "FILE NAME: "//trim(airpressure_file),&
5478  & "COULD NOT FIND DIMENSION 'south_north'")
5479 
5480  lats = dim%DIM
5481 
5482  dim => find_dim(airpressure_p_file,'west_east',found)
5483  IF(.not. found) CALL fatal_error &
5484  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5485  & "FILE NAME: "//trim(airpressure_file),&
5486  & "COULD NOT FIND DIMENSION 'west_east'")
5487  lons = dim%DIM
5488 
5489  CALL set_file_interp_bilinear(airpressure_p_file,airpressure_intp_n,airpressure_intp_c)
5490 
5491  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
5492 
5493  ! AIR PRESSURE
5494  var => find_var(airpressure_p_file,"air_pressure",found)
5495  IF(.not. found) var => find_var(airpressure_p_file,"pressure_air",found)
5496  IF(.not. found) CALL fatal_error &
5497  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5498  & "FILE NAME: "//trim(airpressure_file),&
5499  & "COULD NOT FIND VARIABLE 'air_pressure'")
5500 
5501  ! MAKE SPACE FOR THE DATA FROM THE FILE
5502  ALLOCATE(storage_arr(lons,lats), stat = status)
5503  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE AIR PRESSURE")
5504  air_pressure_n => reference_var(var)
5505  CALL nc_connect_pvar(air_pressure_n,storage_arr)
5506  NULLIFY(storage_arr)
5507 
5508  ! MAKE SPACE FOR THE INTERPOLATED DATA
5509  ALLOCATE(storage_vec(0:mt), stat = status)
5510  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE AIR PRESSURE")
5511  CALL nc_connect_pvar(air_pressure_n,storage_vec)
5512  NULLIFY(storage_vec)
5513 
5514 
5515  ! MAKE SPACE FOR THE DATA FROM THE FILE
5516  ALLOCATE(storage_arr(lons,lats), stat = status)
5517  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE AIR PRESSURE")
5518  air_pressure_p => reference_var(var)
5519  CALL nc_connect_pvar(air_pressure_p,storage_arr)
5520  NULLIFY(storage_arr)
5521 
5522  ! MAKE SPACE FOR THE INTERPOLATED DATA
5523  ALLOCATE(storage_vec(0:mt), stat = status)
5524  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE AIR PRESSURE")
5525  CALL nc_connect_pvar(air_pressure_p,storage_vec)
5526  NULLIFY(storage_vec)
5527 
5528 !==============================================================
5529  CASE(airpressure_is_fvcomgrid)
5530 !==============================================================
5531  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
5532  & "! SETTING UP AIR PRESSURE FORCING FROM A 'FVCOM GRID' FILE"
5533 
5534  dim => find_dim(airpressure_p_file,'node',found)
5535  IF(.not. found) CALL fatal_error &
5536  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5537  & "FILE NAME: "//trim(airpressure_file),&
5538  & "COULD NOT FIND DIMENSION 'node'")
5539 
5540  if (mgl /= dim%dim) CALL fatal_error&
5541  &("Surface Air Pressure: the number of nodes in the file does not match the fvcom grid?")
5542 
5543  dim => find_dim(airpressure_p_file,'nele',found)
5544  IF(.not. found) CALL fatal_error &
5545  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5546  & "FILE NAME: "//trim(airpressure_file),&
5547  & "COULD NOT FIND DIMENSION 'nele'")
5548 
5549  if (ngl /= dim%dim) CALL fatal_error&
5550  &("Surface Air Pressure: the number of elements in the file does not match the fvcom grid?")
5551 
5552 
5553  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
5554 
5555  ! AIR PRESSURE
5556  var => find_var(airpressure_p_file,"air_pressure",found)
5557  IF(.not. found) var => find_var(airpressure_p_file,"SLP",found)
5558  IF(.not. found) CALL fatal_error &
5559  & ("IN SURFACE AIR PRESSURE FILE OBJECT",&
5560  & "FILE NAME: "//trim(airpressure_file),&
5561  & "COULD NOT FIND VARIABLE 'air_pressure' or 'SLP'")
5562 
5563  ! MAKE SPACE FOR THE DATA FROM THE FILE
5564  air_pressure_n => reference_var(var)
5565  ALLOCATE(storage_vec(0:mt), stat = status)
5566  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN AIR PRESSURE")
5567  CALL nc_connect_pvar(air_pressure_n,storage_vec)
5568  NULLIFY(storage_vec)
5569 
5570 
5571  ! MAKE SPACE FOR THE DATA FROM THE FILE
5572  air_pressure_p => reference_var(var)
5573  ALLOCATE(storage_vec(0:mt), stat = status)
5574  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN AIR PRESSURE")
5575  CALL nc_connect_pvar(air_pressure_p,storage_vec)
5576  NULLIFY(storage_vec)
5577 
5578 !==============================================================
5579  CASE DEFAULT
5580 !==============================================================
5581  CALL fatal_error("CAN NOT RECOGNIZE AIR PRESSURE FILE TYPE!")
5582 !==============================================================
5583  END SELECT
5584 !==============================================================
5585 
5586  ! ---------- new: 2016 , april, after Hint by Qi and ayumi.fujisaki@noaa.gov------
5587  ! Initialize some variables
5588  ! afm 20150914
5589  ! Need initialization. Otherwise, random values are asigned
5590  ! and cause a hanging problem of MPI job in UPDATE_VAR_BRACKET
5591  ! This problem reported with Intel15.0.3.
5592  ! PRECIPITATION
5593  air_pressure_p%curr_stkcnt = 0 ; air_pressure_n%curr_stkcnt = 0
5594  ! --------- end new ----------------------------------------------------------------
5595 
5596 
5597 
5598  IF(dbg_set(dbg_sbr)) write(ipt,*) "END SURFACE_AIRPRESSURE"
5599  END SUBROUTINE surface_airpressure
5600 
5601 !================================================================
5602 !================================================================
5603 
5604  SUBROUTINE surface_precipitation
5605  IMPLICIT NONE
5606  ! SOME NC POINTERS
5607  TYPE(ncatt), POINTER :: att, att_date
5608  TYPE(ncdim), POINTER :: dim
5609  TYPE(ncvar), POINTER :: var
5610  LOGICAL :: found
5611  REAL(sp), POINTER :: storage_arr(:,:), storage_vec(:)
5612  TYPE(time) :: timetest
5613  INTEGER :: lats, lons, i, ntimes
5614  INTEGER :: status
5615  CHARACTER(len=60) :: evpstr, prcstr
5616 
5617  IF(dbg_set(dbg_sbr)) write(ipt,*) "START SURFACE_PRECIPITATION"
5618 
5619  IF (.NOT. precipitation_on ) THEN
5620  IF(dbg_set(dbg_log)) write(ipt,*) "! SURFACE PRECIPITATION FORCING IS OFF!"
5621  ALLOCATE(precip_forcing_comments(1))
5622  precip_forcing_comments(1) = "SURFACE PRECIPITATION FORCING IS OFF"
5623  RETURN
5624  END IF
5625 
5626  NULLIFY(att,dim,var,storage_arr,storage_vec)
5627 
5628 ! DETERMINE HOW TO LOAD THE DATA
5629  SELECT CASE(precipitation_kind)
5630  CASE (cnstnt)
5631 
5632  write(evpstr,'(f8.4)') precipitation_evp
5633  write(prcstr,'(f8.4)') precipitation_prc
5634 
5635  IF(dbg_set(dbg_log)) THEN
5636  WRITE(ipt,*)"! SETTING UP CONSTANT PRECIPITATION FORCING: "
5637  WRITE(ipt,*)" EVAPORATION: "//trim(evpstr)
5638  WRITE(ipt,*)" PRECIPITATION: "//trim(prcstr)
5639  END IF
5640 
5641  ALLOCATE(precip_forcing_comments(3))
5642  precip_forcing_comments(1) = "Using constant precipitation from run file:"
5643  precip_forcing_comments(2) = "Precipitation:"//trim(prcstr)
5644  precip_forcing_comments(3) = "Evaporation:"//trim(evpstr)
5645  RETURN
5646 
5647  CASE(sttc)
5648 
5649  CALL fatal_error("STATIC PRECIP Not Set Up Yet")
5650 
5651  CASE(tmdpndnt)
5652 
5653  CALL fatal_error("TIME DEPENDANT PRECIP Not Set Up Yet")
5654 
5655  CASE(prdc)
5656 
5657 
5658  precip_file => find_file(filehead,trim(precipitation_file),found)
5659  IF(.not. found) CALL fatal_error &
5660  & ("COULD NOT FIND SURFACE WIND BOUNDARY CONDINTION FILE OBJECT",&
5661  & "FILE NAME: "//trim(precipitation_file))
5662 
5663  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
5664  att => find_att(precip_file,"source",found)
5665  IF(.not. found) att => find_att(precip_file,"Source",found)
5666  IF(.not. found) CALL fatal_error &
5667  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
5668  & "FILE NAME: "//trim(precipitation_file),&
5669  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
5670 
5671 
5672  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
5673  & trim(wrf2fvcom_source)) THEN
5674  precip_forcing_type = precip_is_wrfgrid
5675 
5676  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
5677  & trim(fvcom_grid_source)) THEN
5678  precip_forcing_type = precip_is_fvcomgrid
5679 
5680  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
5681  & trim(fvcom_cap_grid_source)) THEN
5682  precip_forcing_type = precip_is_fvcomgrid
5683 
5684  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
5685  & trim(wrf_grid_source)) THEN
5686  precip_forcing_type = precip_is_wrfgrid
5687 
5688  ELSE
5689  CALL print_file(precip_file)
5690  CALL fatal_error("CAN NOT RECOGNIZE PRECIP FILE!",&
5691  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
5692  END IF
5693  ! GOT GRID TYPE
5694 
5695  ALLOCATE(precip_forcing_comments(4))
5696  precip_forcing_comments(1) = "FVCOM periodic surface precip forcing:"
5697  precip_forcing_comments(2) = "FILE NAME:"//trim(precipitation_file)
5698 
5699  precip_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
5700 
5701  att_date => find_att(precip_file,"START_DATE",found)
5702  IF (found) THEN
5703  precip_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
5704  ELSE
5705  precip_forcing_comments(4) = "Unknown start date meta data format"
5706  END IF
5707 
5708  ! GET THE FILES LENGTH OF TIME AND SAVE FOR PERIODIC FORCING
5709 
5710  ! LOOK FOR THE DIMENSIONS
5711  dim => find_unlimited(precip_file,found)
5712  IF(.not. found) CALL fatal_error &
5713  & ("IN SURFACE PRECIPITATION BOUNDARY CONDITION FILE OBJECT",&
5714  & "FILE NAME: "//trim(wind_file),&
5715  &"COULD NOT FIND THE UNLIMITED DIMENSION")
5716 
5717  ntimes = dim%DIM
5718 
5719  precip_period = get_file_time(precip_file,ntimes)
5720 
5721  precip_period = precip_period - get_file_time(precip_file,1)
5722 
5723  IF (precip_period /= get_file_time(precip_file,ntimes)) THEN
5724 
5725  CALL print_real_time(get_file_time(precip_file,1),ipt,"FIRST FILE TIME",timezone)
5726  CALL print_real_time(get_file_time(precip_file,ntimes),ipt,"LAST FILE TIME",timezone)
5727 
5728  CALL fatal_error&
5729  &("TO USE PERIODIC FORCING THE FILE TIME MUST COUNT FROM ZERO",&
5730  & "THE DIFFERENCE BETWEEN THE CURRENT MODEL TIME AND THE START TIME,",&
5731  & "MODULO THE FORCING PERIOD, DETERMINES THE CURRENT FORCING")
5732  END IF
5733 
5734 
5735  IF(dbg_set(dbg_log)) THEN
5736  WRITE(ipt,*) "! USING PERIODIC PRECIP FORCING:"
5737  CALL print_time(precip_period,ipt,"PERIOD")
5738  END IF
5739 
5740 
5741  CASE(vrbl)
5742 
5743 
5744  precip_file => find_file(filehead,trim(precipitation_file),found)
5745  IF(.not. found) CALL fatal_error &
5746  & ("COULD NOT FIND SURFACE WIND BOUNDARY CONDINTION FILE OBJECT",&
5747  & "FILE NAME: "//trim(precipitation_file))
5748 
5749  ! DETERMINE GRID TYPE BASED ON SOURCE ATTRIBUTE
5750  att => find_att(precip_file,"source",found)
5751  IF(.not. found) att => find_att(precip_file,"Source",found)
5752  IF(.not. found) CALL fatal_error &
5753  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
5754  & "FILE NAME: "//trim(precipitation_file),&
5755  &"COULD NOT FIND GLOBAL ATTRIBURE: 'source'")
5756 
5757  IF (att%CHR(1)(1:len_trim(wrf2fvcom_source)) ==&
5758  & trim(wrf2fvcom_source)) THEN
5759  precip_forcing_type = precip_is_wrfgrid
5760 
5761  ELSE IF (att%CHR(1)(1:len_trim(fvcom_grid_source)) ==&
5762  & trim(fvcom_grid_source)) THEN
5763  precip_forcing_type = precip_is_fvcomgrid
5764 
5765  ELSE IF (att%CHR(1)(1:len_trim(fvcom_cap_grid_source)) ==&
5766  & trim(fvcom_cap_grid_source)) THEN
5767  precip_forcing_type = precip_is_fvcomgrid
5768 
5769  ELSE IF (att%CHR(1)(1:len_trim(wrf_grid_source)) ==&
5770  & trim(wrf_grid_source)) THEN
5771  precip_forcing_type = precip_is_wrfgrid
5772 
5773  ELSE
5774  CALL print_file(precip_file)
5775  CALL fatal_error("CAN NOT RECOGNIZE PRECIP FILE!",&
5776  & "UNKNOWN SOURCE STRING:",trim(att%CHR(1)))
5777  END IF
5778  ! GOT GRID TYPE
5779 
5780  ALLOCATE(precip_forcing_comments(4))
5781  precip_forcing_comments(1) = "FVCOM periodic surface precip forcing:"
5782  precip_forcing_comments(2) = "FILE NAME:"//trim(precipitation_file)
5783 
5784  precip_forcing_comments(3) = "SOURCE:"//trim(att%CHR(1))
5785 
5786  att_date => find_att(precip_file,"START_DATE",found)
5787  IF (found) THEN
5788  precip_forcing_comments(4) ="MET DATA START DATE:"//trim(att_date%CHR(1))
5789  ELSE
5790  precip_forcing_comments(4) = "Unknown start date meta data format"
5791  END IF
5792 
5793  dim => find_unlimited(precip_file,found)
5794  IF(.not. found) CALL fatal_error &
5795  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
5796  & "FILE NAME: "//trim(precipitation_file),&
5797  &"COULD NOT FIND THE UNLIMITED DIMENSION")
5798 
5799  ntimes = dim%DIM
5800 
5801  ! CHECK THE FILE TIME AND COMPARE WITH MODEL RUN TIME
5802  timetest = get_file_time(precip_file,1)
5803  IF(timetest > starttime) CALL fatal_error &
5804  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
5805  & "FILE NAME: "//trim(precipitation_file),&
5806  &"THE MODEL RUN STARTS BEFORE THE FORCING TIME SERIES")
5807 
5808  timetest = get_file_time(precip_file,ntimes)
5809  IF(timetest < endtime) CALL fatal_error &
5810  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
5811  & "FILE NAME: "//trim(precipitation_file),&
5812  &"THE MODEL RUN ENDS AFTER THE FORCING TIME SERIES")
5813 
5814 
5815 
5816  CASE DEFAULT
5817  CALL fatal_error("SURFACE_PRECIP: UNKNOWN WIND KIND?")
5818  END SELECT
5819 
5820 
5821 ! DEAL WITH DATA SET UP
5822 !=====================================================================
5823  SELECT CASE(precip_forcing_type)
5824 !=====================================================================
5825  CASE(precip_is_wrfgrid)
5826 !=====================================================================
5827 
5828  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
5829  & "! SETTING UP WIND STRESS FORCING FROM A 'wrf grid' FILE"
5830 
5831  ! LOOK FOR THE DIMENSIONS
5832 
5833 
5834  dim => find_dim(precip_file,'south_north',found)
5835  IF(.not. found) CALL fatal_error &
5836  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
5837  & "FILE NAME: "//trim(precipitation_file),&
5838  & "COULD NOT FIND DIMENSION 'south_north'")
5839 
5840  lats = dim%DIM
5841 
5842 
5843  dim => find_dim(precip_file,'west_east',found)
5844  IF(.not. found) CALL fatal_error &
5845  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
5846  & "FILE NAME: "//trim(precipitation_file),&
5847  & "COULD NOT FIND DIMENSION 'west_east'")
5848  lons = dim%DIM
5849 
5850 
5851 
5852  CALL set_file_interp_bilinear(precip_file,precip_intp_n,precip_intp_c)
5853 
5854  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
5855 
5856  ! WIND STRESS IN THE X or EAST-WEST DIRECTION
5857  var => find_var(precip_file,"Precipitation",found)
5858  IF(.not. found) CALL fatal_error &
5859  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
5860  & "FILE NAME: "//trim(precipitation_file),&
5861  & "COULD NOT FIND VARIABLE 'PRECIPITATION'")
5862 
5863  ! MAKE SPACE FOR THE DATA FROM THE FILE
5864  ALLOCATE(storage_arr(lons,lats), stat = status)
5865  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5866  precip_pre_n => reference_var(var)
5867  CALL nc_connect_pvar(precip_pre_n,storage_arr)
5868  NULLIFY(storage_arr)
5869 
5870  ! MAKE SPACE FOR THE INTERPOLATED DATA
5871  ALLOCATE(storage_vec(0:mt), stat = status)
5872  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5873  CALL nc_connect_pvar(precip_pre_n,storage_vec)
5874  NULLIFY(storage_vec)
5875 
5876 
5877  ! MAKE SPACE FOR THE DATA FROM THE FILE
5878  ALLOCATE(storage_arr(lons,lats), stat = status)
5879  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5880  precip_pre_p => reference_var(var)
5881  CALL nc_connect_pvar(precip_pre_p,storage_arr)
5882  NULLIFY(storage_arr)
5883 
5884  ! MAKE SPACE FOR THE INTERPOLATED DATA
5885  ALLOCATE(storage_vec(0:mt), stat = status)
5886  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5887  CALL nc_connect_pvar(precip_pre_p,storage_vec)
5888  NULLIFY(storage_vec)
5889 
5890  ! WIND STRESS IN THE X or EAST-WEST DIRECTION
5891  var => find_var(precip_file,"Evaporation",found)
5892  IF(.not. found) CALL fatal_error &
5893  & ("IN SURFACE WIND BOUNDARY CONDITION FILE OBJECT",&
5894  & "FILE NAME: "//trim(precipitation_file),&
5895  & "COULD NOT FIND VARIABLE 'Evaporation'")
5896 
5897  ! MAKE SPACE FOR THE DATA FROM THE FILE
5898  ALLOCATE(storage_arr(lons,lats), stat = status)
5899  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5900  precip_evp_n => reference_var(var)
5901  CALL nc_connect_pvar(precip_evp_n,storage_arr)
5902  NULLIFY(storage_arr)
5903 
5904  ! MAKE SPACE FOR THE INTERPOLATED DATA
5905  ALLOCATE(storage_vec(0:mt), stat = status)
5906  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5907  CALL nc_connect_pvar(precip_evp_n,storage_vec)
5908  NULLIFY(storage_vec)
5909 
5910 
5911  ! MAKE SPACE FOR THE DATA FROM THE FILE
5912  ALLOCATE(storage_arr(lons,lats), stat = status)
5913  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5914  precip_evp_p => reference_var(var)
5915  CALL nc_connect_pvar(precip_evp_p,storage_arr)
5916  NULLIFY(storage_arr)
5917 
5918  ! MAKE SPACE FOR THE INTERPOLATED DATA
5919  ALLOCATE(storage_vec(0:mt), stat = status)
5920  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5921  CALL nc_connect_pvar(precip_evp_p,storage_vec)
5922  NULLIFY(storage_vec)
5923 
5924 !=====================================================================
5925  CASE(precip_is_fvcomgrid)
5926 !=====================================================================
5927 
5928 
5929  IF(dbg_set(dbg_log)) WRITE(ipt,*) &
5930  & "! SETTING UP PRECIPITATION FORCING FROM A 'FVCOM grid' FILE"
5931 
5932  ! LOOK FOR THE DIMENSIONS
5933 
5934 
5935  dim => find_dim(precip_file,'node',found)
5936  IF(.not. found) CALL fatal_error &
5937  & ("IN PRECIPITATION BOUNDARY CONDITION FILE OBJECT",&
5938  & "FILE NAME: "//trim(precipitation_file),&
5939  & "COULD NOT FIND DIMENSION 'node'")
5940 
5941  if (mgl /= dim%dim) CALL fatal_error&
5942  &("Surface PRECIP: the number of nodes in the file does not match the fvcom grid?")
5943 
5944 
5945  dim => find_dim(precip_file,'nele',found)
5946  IF(.not. found) CALL fatal_error &
5947  & ("IN PRECIPITATION BOUNDARY CONDITION FILE OBJECT",&
5948  & "FILE NAME: "//trim(precipitation_file),&
5949  & "COULD NOT FIND DIMENSION 'nele'")
5950 
5951  if (ngl /= dim%dim) CALL fatal_error&
5952  &("Surface PRECIP: the number of elements in the file does not match the fvcom grid?")
5953 
5954 
5955 
5956  ! SETUP THE ACTUAL VARIABLES USED TO LOAD DATA!
5957 
5958  ! WIND STRESS IN THE X or EAST-WEST DIRECTION
5959  var => find_var(precip_file,"precip",found)
5960  IF(.not. found) CALL fatal_error &
5961  & ("IN PRECIPITATION BOUNDARY CONDITION FILE OBJECT",&
5962  & "FILE NAME: "//trim(precipitation_file),&
5963  & "COULD NOT FIND VARIABLE 'precip'")
5964 
5965  ! MAKE SPACE FOR THE DATA FROM THE FILE
5966  precip_pre_n => reference_var(var)
5967  ALLOCATE(storage_vec(0:mt), stat = status)
5968  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5969  CALL nc_connect_pvar(precip_pre_n,storage_vec)
5970  NULLIFY(storage_vec)
5971 
5972 
5973  ! MAKE SPACE FOR THE DATA FROM THE FILE
5974  precip_pre_p => reference_var(var)
5975  ALLOCATE(storage_vec(0:mt), stat = status)
5976  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5977  CALL nc_connect_pvar(precip_pre_p,storage_vec)
5978  NULLIFY(storage_vec)
5979 
5980  ! EVAP
5981  var => find_var(precip_file,"evap",found)
5982  IF(.not. found) CALL fatal_error &
5983  & ("IN PRECIPITATION BOUNDARY CONDITION FILE OBJECT",&
5984  & "FILE NAME: "//trim(precipitation_file),&
5985  & "COULD NOT FIND VARIABLE 'evap'")
5986 
5987  ! MAKE SPACE FOR THE DATA FROM THE FILE
5988  precip_evp_n => reference_var(var)
5989  ALLOCATE(storage_vec(0:mt), stat = status)
5990  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5991  CALL nc_connect_pvar(precip_evp_n,storage_vec)
5992  NULLIFY(storage_vec)
5993 
5994 
5995  ! MAKE SPACE FOR THE DATA FROM THE FILE
5996  precip_evp_p => reference_var(var)
5997  ALLOCATE(storage_vec(0:mt), stat = status)
5998  IF(status /= 0) CALL fatal_error("ALLOCATION ERROR IN SURFACE PRECIPITATION")
5999  CALL nc_connect_pvar(precip_evp_p,storage_vec)
6000  NULLIFY(storage_vec)
6001 
6002 !=====================================================================
6003  CASE DEFAULT
6004 !=====================================================================
6005  CALL fatal_error("CAN NOT RECOGNIZE PRECIPITATION FILE TYPE")
6006 !=====================================================================
6007  END SELECT
6008 !=====================================================================
6009 
6010 
6011  ! ---------- new: 2016 , april, after Hint by Qi and ayumi.fujisaki@noaa.gov------
6012  ! Initialize some variables
6013  ! afm 20150914
6014  ! Need initialization. Otherwise, random values are asigned
6015  ! and cause a hanging problem of MPI job in UPDATE_VAR_BRACKET
6016  ! This problem reported with Intel15.0.3.
6017  ! PRECIPITATION
6018  precip_pre_p%curr_stkcnt = 0
6019  precip_pre_n%curr_stkcnt = 0
6020  ! EVAPORATION
6021  precip_evp_n%curr_stkcnt = 0
6022  precip_evp_p%curr_stkcnt = 0
6023  ! --------- end new ----------------------------------------------------------------
6024 
6025 
6026 
6027 
6028  IF(dbg_set(dbg_sbr)) write(ipt,*) "END SURFACE_PRECIPITATION"
6029  END SUBROUTINE surface_precipitation
6030  !==============================================================================|
6031  SUBROUTINE update_rivers(NOW,FLUX,TEMP,SALT,WQM,SED,BIO)
6032  IMPLICIT NONE
6033  TYPE(time), INTENT(IN) :: now
6034  REAL(sp), ALLOCATABLE :: flux(:)
6035  REAL(sp), ALLOCATABLE, OPTIONAL :: temp(:)
6036  REAL(sp), ALLOCATABLE, OPTIONAL :: salt(:)
6037  REAL(sp), ALLOCATABLE, OPTIONAL :: wqm(:,:)
6038  REAL(sp), ALLOCATABLE, OPTIONAL :: sed(:,:)
6039  REAL(sp), ALLOCATABLE, OPTIONAL :: bio(:,:)
6040 
6041  REAL(sp), POINTER :: vnp(:), vpp(:)
6042 
6043  REAL(sp), ALLOCATABLE :: current(:)
6044  TYPE(time) :: rivtime
6045 
6046  TYPE(ncfile), POINTER :: ncf
6047  TYPE(ncvar), POINTER :: var_n
6048  TYPE(ncvar), POINTER :: var_p
6049  TYPE(ncftime), POINTER :: ftm
6050  INTEGER :: status, i, j, nrsf,ind,ns
6051 
6052  IF(.NOT. ALLOCATED(flux)) CALL fatal_error &
6053  &("THE RIVER FLUX VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6054 
6055  IF(PRESENT(temp)) THEN
6056  IF(.NOT. ALLOCATED(temp)) CALL fatal_error &
6057  &("THE RIVER TEMP VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6058  END IF
6059 
6060  IF(PRESENT(salt)) THEN
6061  IF(.NOT. ALLOCATED(salt)) CALL fatal_error &
6062  &("THE RIVER SALT VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6063  END IF
6064 
6065 
6066  DO i = 1, SIZE(river_forcing) ! (NUMBER OF FILES)
6067 
6068  SELECT CASE (river_kind)
6069  CASE(prdc)
6070 
6071  ! TO SET ZERO TIME PHASE USING RUNFILE START TIME
6072 ! RIVTIME= NOW - RUNFILE_StartTime
6073 
6074  ! TO USE ZERO AS THE PHASE OF THE FORCING
6075  rivtime= now
6076 
6077 
6078  rivtime = mod(rivtime,river_forcing(i)%RIVER_PERIOD)
6079 
6080  CASE(vrbl)
6081 
6082 
6083  rivtime = now
6084  END SELECT
6085 
6086 
6087  ncf => river_forcing(i)%NCF
6088  ftm => ncf%FTIME
6089 
6090  nrsf = river_forcing(i)%RIVERS_IN_FILE
6091 
6092  ! RIVER FLUX
6093  var_n => river_forcing(i)%FLUX_N
6094  var_p => river_forcing(i)%FLUX_P
6095  CALL update_var_bracket(ncf,var_p,var_n,rivtime,status)
6096  IF (status /= 0) THEN
6097  CALL fatal_error("COULD NOT UPATE RIVER_FILE TIME BRACKET: BOUNDS EXCEEDED?")
6098  end if
6099 
6100  ALLOCATE(current(nrsf))
6101 
6102  CALL nc_point_var(var_n,vnp)
6103  CALL nc_point_var(var_p,vpp)
6104 
6105  !====================================================
6106  ! Linear interpolation between time points
6107  !CURRENT = FTM%NEXT_WGHT * VNP + FTM%PREV_WGHT * VPP
6108  !
6109  ! OR
6110  !
6111  ! Nearest time sets the value
6112  current = vnp
6113  if (ftm%PREV_WGHT .gt. 0.5_sp) current = vpp
6114  !====================================================
6115 
6116  DO j =1,nrsf
6117  ind = river_forcing(i)%RIV_FILE2LOC(j)
6118  IF(ind /= 0) flux(ind) = current(j)
6119  END DO
6120 
6121  DEALLOCATE(current)
6122 
6123  IF(PRESENT(salt)) THEN
6124 
6125  ! RIVER SALT
6126  var_n => river_forcing(i)%SALT_N
6127  var_p => river_forcing(i)%SALT_P
6128  CALL update_var_bracket(ncf,var_p,var_n,rivtime,status)
6129  IF (status /= 0) THEN
6130  CALL fatal_error("COULD NOT UPATE RIVER_FILE TIME BRACKET: BOUNDS EXCEEDED?")
6131  end if
6132 
6133  ALLOCATE(current(nrsf))
6134 
6135  CALL nc_point_var(var_n,vnp)
6136  CALL nc_point_var(var_p,vpp)
6137 
6138  !====================================================
6139  ! Linear interpolation between time points
6140  !CURRENT = FTM%NEXT_WGHT * VNP + FTM%PREV_WGHT * VPP
6141  !
6142  ! OR
6143  !
6144  ! Nearest time sets the value
6145  current = vnp
6146  if (ftm%PREV_WGHT .gt. 0.5_sp) current = vpp
6147  !====================================================
6148 
6149 
6150  DO j =1,nrsf
6151  ind = river_forcing(i)%RIV_FILE2LOC(j)
6152  IF(ind /= 0) salt(ind) = current(j)
6153  END DO
6154 
6155  DEALLOCATE(current)
6156  END IF
6157 
6158  IF(PRESENT(temp)) THEN
6159 
6160  ! RIVER TEMP
6161  var_n => river_forcing(i)%TEMP_N
6162  var_p => river_forcing(i)%TEMP_P
6163  CALL update_var_bracket(ncf,var_p,var_n,rivtime,status)
6164  IF (status /= 0) THEN
6165  CALL fatal_error("COULD NOT UPATE RIVER_FILE TIME BRACKET: BOUNDS EXCEEDED?")
6166  end if
6167 
6168  ALLOCATE(current(nrsf))
6169 
6170  CALL nc_point_var(var_n,vnp)
6171  CALL nc_point_var(var_p,vpp)
6172 
6173  !====================================================
6174  ! Linear interpolation between time points
6175  !CURRENT = FTM%NEXT_WGHT * VNP + FTM%PREV_WGHT * VPP
6176  !
6177  ! OR
6178  !
6179  ! Nearest time sets the value
6180  current = vnp
6181  if (ftm%PREV_WGHT .gt. 0.5_sp) current = vpp
6182  !====================================================
6183 
6184  DO j =1,nrsf
6185  ind = river_forcing(i)%RIV_FILE2LOC(j)
6186  IF(ind /= 0) temp(ind) = current(j)
6187  END DO
6188 
6189  DEALLOCATE(current)
6190  END IF
6191 
6192 
6193 
6194 
6195  END DO ! FOR EACH FILE
6196 
6197  END SUBROUTINE update_rivers
6198  !==============================================================================|
6199  SUBROUTINE update_groundwater(NOW,GW_FLUX,GW_TEMP,GW_SALT)
6200  IMPLICIT NONE
6201  TYPE(time), INTENT(IN) :: now
6202  TYPE(time) :: gwtime
6203  REAL(sp), ALLOCATABLE :: gw_flux(:)
6204  REAL(sp), ALLOCATABLE, OPTIONAL :: gw_salt(:)
6205  REAL(sp), ALLOCATABLE, OPTIONAL :: gw_temp(:)
6206  TYPE(ncftime), POINTER :: ftm
6207  INTEGER :: status
6208  REAL(sp), POINTER :: vnp(:), vpp(:)
6209 
6210  IF(.NOT. ALLOCATED(gw_flux)) CALL fatal_error &
6211  &("THE GROUNDWATER FLUX VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6212 
6213 
6214 !===================================================
6215  SELECT CASE(groundwater_kind)
6216 !===================================================
6217  CASE (cnstnt)
6218 
6219  ! CONSTANT GROUND WATER FORCING IS ALWAYS A FLOW RATE (M/S)...
6220  ! CONVERT TO A FLUX
6221  gw_flux(1:mt) = groundwater_flow*art1(1:mt)
6222 
6223  IF(groundwater_temp_on .and. PRESENT(gw_temp)) THEN
6224  IF(.NOT. ALLOCATED(gw_temp)) CALL fatal_error &
6225  &("THE GROUNDWATER TEMPERATURE VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6226  gw_temp(1:mt) = groundwater_temp
6227  END IF
6228 
6229  IF(groundwater_salt_on .and. PRESENT(gw_salt)) THEN
6230  IF(.NOT. ALLOCATED(gw_salt)) CALL fatal_error &
6231  &("THE GROUNDWATER SALINITY VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6232  gw_salt(1:mt) = groundwater_salt
6233  END IF
6234 
6235  RETURN
6236 
6237  CASE(sttc)
6238 
6239  CALL fatal_error("STATIC HEATING Not Set Up Yet")
6240 
6241  CASE(tmdpndnt)
6242 
6243  CALL fatal_error("TIME DEPENDANT HEATING Not Set Up Yet")
6244 
6245  CASE(prdc)
6246 
6247  ! TO SET ZERO TIME PHASE USING RUNFILE START TIME
6248 ! GWTIME= NOW - RUNFILE_StartTime
6249 
6250  ! TO USE ZERO AS THE PHASE OF THE FORCING
6251  gwtime= now
6252 
6253 
6254  gwtime = mod(gwtime,gwater_period)
6255 
6256  CASE(vrbl)
6257 
6258 
6259  gwtime = now
6260  END SELECT
6261 !===================================================
6262 !===================================================
6263 
6264 !===================================================
6265  SELECT CASE(gwater_forcing_type)
6266 !===================================================
6267  CASE(gwater_is_fvcomgrid)
6268 
6269  ftm => gwater_file%FTIME
6270 
6271  ! GROUND WATER FLUX
6272  CALL update_var_bracket(gwater_file,gwater_flux_p,gwater_flux_n,gwtime,status)
6273  IF (status /= 0) THEN
6274  CALL fatal_error("COULD NOT UPATE GROUNDWATER_FILE TIME BRACKET: BOUNDS EXCEEDED?")
6275  end if
6276 
6277  CALL nc_point_var(gwater_flux_n,vnp)
6278  CALL nc_point_var(gwater_flux_p,vpp)
6279 
6280  gw_flux = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6281 
6282  ! IF THE GROUND WATER IS A FLOW RATE CONVERT TO A FLUX
6283  IF(gwater_units == gwater_ms_1 ) gw_flux = gw_flux *art1
6284 
6285 
6286  ! GROUND WATER TEMP
6287  IF(groundwater_temp_on .and. PRESENT(gw_temp)) THEN
6288 
6289  IF(.NOT. ALLOCATED(gw_temp)) CALL fatal_error &
6290  &("THE GROUNDWATER TEMPERATURE VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6291 
6292  CALL update_var_bracket(gwater_file,gwater_temp_p,gwater_temp_n,gwtime,status)
6293  IF (status /= 0) THEN
6294  CALL fatal_error("COULD NOT UPATE GROUNDWATER_FILE TIME BRACKET: BOUNDS EXCEEDED?")
6295  end if
6296 
6297  CALL nc_point_var(gwater_temp_n,vnp)
6298  CALL nc_point_var(gwater_temp_p,vpp)
6299 
6300  gw_temp = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6301  END IF
6302 
6303  ! GROUND WATER SALT
6304  IF(groundwater_salt_on .and. PRESENT(gw_salt)) THEN
6305 
6306  IF(.NOT. ALLOCATED(gw_salt)) CALL fatal_error &
6307  &("THE GROUNDWATER SALINITY VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6308 
6309  CALL update_var_bracket(gwater_file,gwater_salt_p,gwater_salt_n,gwtime,status)
6310  IF (status /= 0) THEN
6311  CALL fatal_error("COULD NOT UPATE GROUNDWATER_FILE TIME BRACKET: BOUNDS EXCEEDED?")
6312  end if
6313 
6314  CALL nc_point_var(gwater_salt_n,vnp)
6315  CALL nc_point_var(gwater_salt_p,vpp)
6316 
6317  gw_salt = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6318  END IF
6319 
6320 
6321 
6322  CASE DEFAULT
6323  CALL fatal_error("UNKNOWN GROUNDWATER_FORCING_TYPE IN UPDATE GROUNDWATER")
6324  END SELECT
6325 
6326 
6327  END SUBROUTINE update_groundwater
6328  !==============================================================================|
6329  SUBROUTINE update_heat(NOW,HEAT_SWV,HEAT_NET)
6330  IMPLICIT NONE
6331  TYPE(time), INTENT(IN) :: now
6332  TYPE(time) :: htime
6333  REAL(sp), ALLOCATABLE :: heat_swv(:), heat_net(:)
6334  TYPE(ncftime), POINTER :: ftm
6335  INTEGER :: status
6336  REAL(sp), POINTER :: vnp(:), vpp(:)
6337 
6338  IF(.NOT. ALLOCATED(heat_swv)) CALL fatal_error &
6339  &("THE HEAT SHORTWAVE VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6340 
6341  IF(.NOT. ALLOCATED(heat_net)) CALL fatal_error &
6342  &("THE NET HEAT VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6343 
6344 !===================================================
6345  SELECT CASE(heating_kind)
6346 !===================================================
6347  CASE (cnstnt)
6348 
6349  heat_swv(1:mt) = heating_radiation
6350  heat_net(1:mt) = heating_netflux
6351 
6352  RETURN
6353 
6354  CASE(sttc)
6355 
6356  CALL fatal_error("STATIC HEATING Not Set Up Yet")
6357 
6358  CASE(tmdpndnt)
6359 
6360  CALL fatal_error("TIME DEPENDANT HEATING Not Set Up Yet")
6361 
6362  CASE(prdc)
6363 
6364  ! TO SET ZERO TIME PHASE USING RUNFILE START TIME
6365 ! HTIME= NOW - RUNFILE_StartTime
6366 
6367  ! TO USE ZERO AS THE PHASE OF THE FORCING
6368  htime= now
6369 
6370 
6371  htime = mod(htime,heat_period)
6372 
6373  CASE(vrbl)
6374 
6375 
6376  htime = now
6377  END SELECT
6378 !===================================================
6379 !===================================================
6380 
6381 
6382 !===================================================
6383  SELECT CASE(heat_forcing_type)
6384 !===================================================
6385  CASE(heat_is_wrfgrid)
6386 
6387  ftm => heat_file%FTIME
6388 
6389  ! SHORT WAVE RADIATION
6390  CALL update_var_bracket(heat_file,heat_swv_p,heat_swv_n,htime,status,heat_intp_n)
6391  IF (status /= 0) THEN
6392  CALL fatal_error("COULD NOT UPATE HEAT_FILE TIME BRACKET: BOUNDS EXCEEDED?")
6393  end if
6394 
6395  CALL nc_point_var(heat_swv_n,vnp)
6396  CALL nc_point_var(heat_swv_p,vpp)
6397 
6398  heat_swv = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6399 
6400  ! NET HEAT FLUX
6401  CALL update_var_bracket(heat_file,heat_net_p,heat_net_n,htime,status,heat_intp_n)
6402  IF (status /= 0) THEN
6403  CALL fatal_error("COULD NOT UPATE HEAT_FILE TIME BRACKET: BOUNDS EXCEEDED?")
6404  end if
6405 
6406  CALL nc_point_var(heat_net_n,vnp)
6407  CALL nc_point_var(heat_net_p,vpp)
6408  heat_net = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6409 
6410  CASE(heat_is_fvcomgrid)
6411 
6412  ftm => heat_file%FTIME
6413 
6414  ! SHORT WAVE RADIATION
6415  CALL update_var_bracket(heat_file,heat_swv_p,heat_swv_n,htime,status)
6416  IF (status /= 0) THEN
6417  CALL fatal_error("COULD NOT UPATE HEAT_FILE TIME BRACKET: BOUNDS EXCEEDED?")
6418  end if
6419 
6420  CALL nc_point_var(heat_swv_n,vnp)
6421  CALL nc_point_var(heat_swv_p,vpp)
6422 
6423  heat_swv = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6424 
6425  ! NET HEAT FLUX
6426  CALL update_var_bracket(heat_file,heat_net_p,heat_net_n,htime,status)
6427  IF (status /= 0) THEN
6428  CALL fatal_error("COULD NOT UPATE HEAT_FILE TIME BRACKET: BOUNDS EXCEEDED?")
6429  end if
6430 
6431  CALL nc_point_var(heat_net_n,vnp)
6432  CALL nc_point_var(heat_net_p,vpp)
6433  heat_net = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6434 
6435 
6436  CASE DEFAULT
6437  CALL fatal_error("UNKNOWN HEAT_FORCING_TYPE IN UPDATE HEAT")
6438  END SELECT
6439 
6440 
6441  END SUBROUTINE update_heat
6442  !==============================================================================|
6443  !==============================================================================|
6444  !==============================================================================|
6445  !==============================================================================|
6446  !==============================================================================|
6447 
6448  SUBROUTINE update_wind(NOW,wstrx,wstry)
6449  IMPLICIT NONE
6450  TYPE(time), INTENT(IN) :: now
6451  TYPE(time) :: wtime
6452  REAL(sp), ALLOCATABLE :: wstrx(:),wstry(:)
6453  REAL(sp), POINTER :: vnp(:), vpp(:)
6454  TYPE(ncftime), POINTER :: ftm
6455  INTEGER :: status
6456 
6457 
6458  IF(.NOT. ALLOCATED(wstrx)) CALL fatal_error &
6459  &("THE WIND VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6460  IF(.NOT. ALLOCATED(wstry)) CALL fatal_error &
6461  &("THE WIND VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6462 
6463 
6464 !===================================================
6465  SELECT CASE(wind_kind)
6466 !===================================================
6467  CASE (cnstnt)
6468 
6469  wstrx(1:nt) = wind_x
6470  wstry(1:nt) = wind_y
6471 
6472  RETURN
6473 
6474  CASE(sttc)
6475 
6476  CALL fatal_error("STATIC WIND Not Set Up Yet")
6477 
6478  CASE(tmdpndnt)
6479 
6480  CALL fatal_error("TIME DEPENDANT WIND Not Set Up Yet")
6481 
6482  CASE(prdc)
6483 
6484  ! TO SET ZERO TIME PHASE USING RUNFILE START TIME
6485 ! WTIME= NOW - RUNFILE_StartTime
6486 
6487  ! TO USE ZERO AS THE PHASE OF THE FORCING
6488  wtime= now
6489 
6490 
6491  wtime = mod(wtime,winds_period)
6492 
6493  CASE(vrbl)
6494 
6495  wtime = now
6496  END SELECT
6497 !===================================================
6498 !===================================================
6499 
6500 
6501 !===================================================
6502  SELECT CASE(winds_forcing_type)
6503 !===================================================
6504  CASE(winds_are_wrfgrid)
6505 
6506  ftm => winds_file%FTIME
6507 
6508  ! THE X DIRECTION WIND STRESS
6509  CALL update_var_bracket(winds_file,winds_strx_p,winds_strx_n,wtime,status,winds_intp_c)
6510  IF (status /= 0) THEN
6511  CALL fatal_error("COULD NOT UPATE WIND X BRACKET: BOUNDS EXCEEDED?")
6512  end if
6513 
6514  CALL nc_point_var(winds_strx_n,vnp)
6515  CALL nc_point_var(winds_strx_p,vpp)
6516  wstrx = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6517 
6518  ! THE Y DIRECTION WIND STRESS
6519  CALL update_var_bracket(winds_file,winds_stry_p,winds_stry_n,wtime,status,winds_intp_c)
6520  IF (status /= 0) THEN
6521  CALL fatal_error("COULD NOT UPATE WIND Y BRACKET: BOUNDS EXCEEDED?")
6522  end if
6523 
6524  CALL nc_point_var(winds_stry_n,vnp)
6525  CALL nc_point_var(winds_stry_p,vpp)
6526  wstry = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6527 !===================================================
6528  CASE(winds_are_fvcomgrid)
6529 !===================================================
6530  ftm => winds_file%FTIME
6531 
6532  ! THE X DIRECTION WIND STRESS
6533  CALL update_var_bracket(winds_file,winds_strx_p,winds_strx_n,wtime,status)
6534  IF (status /= 0) THEN
6535  CALL fatal_error("COULD NOT UPATE WIND X BRACKET: BOUNDS EXCEEDED?")
6536  end if
6537 
6538  CALL nc_point_var(winds_strx_n,vnp)
6539  CALL nc_point_var(winds_strx_p,vpp)
6540  wstrx = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6541 
6542  ! THE Y DIRECTION WIND STRESS
6543  CALL update_var_bracket(winds_file,winds_stry_p,winds_stry_n,wtime,status)
6544  IF (status /= 0) THEN
6545  CALL fatal_error("COULD NOT UPATE WIND Y BRACKET: BOUNDS EXCEEDED?")
6546  end if
6547 
6548  CALL nc_point_var(winds_stry_n,vnp)
6549  CALL nc_point_var(winds_stry_p,vpp)
6550  wstry = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6551 
6552 !===================================================
6553  CASE(winds_are_pt_source)
6554 !===================================================
6555  ftm => winds_file%FTIME
6556 
6557  ! THE X DIRECTION WIND STRESS
6558  CALL update_var_bracket(winds_file,winds_strx_p,winds_strx_n,wtime,status)
6559  IF (status /= 0) THEN
6560  CALL fatal_error("COULD NOT UPATE WIND X BRACKET: BOUNDS EXCEEDED?")
6561  end if
6562 
6563  CALL nc_point_var(winds_strx_n,vnp)
6564  CALL nc_point_var(winds_strx_p,vpp)
6565  wstrx(1:nt) = ftm%NEXT_WGHT * vnp(1) + ftm%PREV_WGHT * vpp(1)
6566 
6567  ! THE Y DIRECTION WIND STRESS
6568  CALL update_var_bracket(winds_file,winds_stry_p,winds_stry_n,wtime,status)
6569  IF (status /= 0) THEN
6570  CALL fatal_error("COULD NOT UPATE WIND Y BRACKET: BOUNDS EXCEEDED?")
6571  end if
6572 
6573  CALL nc_point_var(winds_stry_n,vnp)
6574  CALL nc_point_var(winds_stry_p,vpp)
6575  wstry(1:nt) = ftm%NEXT_WGHT * vnp(1) + ftm%PREV_WGHT * vpp(1)
6576 
6577 !===================================================
6578  CASE DEFAULT
6579  CALL fatal_error("UNKNOWN WINDS_FORCING_TYPE IN UPDATE WIND")
6580  END SELECT
6581 !===================================================
6582 
6583  END SUBROUTINE update_wind
6584 
6585 
6586 
6587 
6588 
6589 
6590 
6591 !==============================================================================|
6592  SUBROUTINE update_precipitation(NOW,Qprec,Qevap)
6593  IMPLICIT NONE
6594  TYPE(time), INTENT(IN) :: now
6595  TYPE(time) :: ptime
6596  REAL(sp), ALLOCATABLE :: qevap(:),qprec(:)
6597  REAL(sp), POINTER :: vnp(:), vpp(:)
6598  TYPE(ncftime), POINTER :: ftm
6599  INTEGER :: status
6600 
6601  IF(.NOT. ALLOCATED(qprec)) CALL fatal_error &
6602  &("THE PRECIPITATION VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6603  IF(.NOT. ALLOCATED(qevap)) CALL fatal_error &
6604  &("THE EVAPORATION VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6605 
6606 !===================================================
6607  SELECT CASE(precipitation_kind)
6608 !===================================================
6609  CASE (cnstnt)
6610 
6611  qprec(1:mt) = precipitation_prc
6612  qevap(1:mt) = precipitation_evp
6613 
6614  RETURN
6615 
6616  CASE(sttc)
6617 
6618  CALL fatal_error("STATIC PRECIP Not Set Up Yet")
6619 
6620  CASE(tmdpndnt)
6621 
6622  CALL fatal_error("TIME DEPENDANT PRECIP Not Set Up Yet")
6623 
6624  CASE(prdc)
6625 
6626  ! TO SET ZERO TIME PHASE USING RUNFILE START TIME
6627 ! PTIME= NOW - RUNFILE_StartTime
6628 
6629  ! TO USE ZERO AS THE PHASE OF THE FORCING
6630  ptime= now
6631 
6632 
6633  ptime = mod(ptime,precip_period)
6634 
6635  CASE(vrbl)
6636 
6637  ptime = now
6638  END SELECT
6639 !===================================================
6640 !===================================================
6641 
6642 
6643 
6644 
6645 !===================================================
6646  SELECT CASE(precip_forcing_type)
6647 !===================================================
6648  CASE(precip_is_wrfgrid)
6649 
6650  ftm => precip_file%FTIME
6651 
6652  ! PRECIPITATION
6653  CALL update_var_bracket(precip_file,precip_pre_p,precip_pre_n,ptime,status,precip_intp_n)
6654  IF (status /= 0) THEN
6655  CALL fatal_error("COULD NOT UPATE PRECIP BRACKET: BOUNDS EXCEEDED?")
6656  end if
6657 
6658  CALL nc_point_var(precip_pre_n,vnp)
6659  CALL nc_point_var(precip_pre_p,vpp)
6660  qprec = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6661 
6662  ! EVAPORATION
6663  CALL update_var_bracket(precip_file,precip_evp_p,precip_evp_n,ptime,status,precip_intp_n)
6664  IF (status /= 0) THEN
6665  CALL fatal_error("COULD NOT UPATE EVAP BRACKET: BOUNDS EXCEEDED?")
6666  end if
6667 
6668  CALL nc_point_var(precip_evp_n,vnp)
6669  CALL nc_point_var(precip_evp_p,vpp)
6670  qevap = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6671 !===================================================
6672  CASE(precip_is_fvcomgrid)
6673 !===================================================
6674 
6675  ftm => precip_file%FTIME
6676 
6677  ! PRECIPITATION
6678  CALL update_var_bracket(precip_file,precip_pre_p,precip_pre_n,ptime,status)
6679  IF (status /= 0) THEN
6680  CALL fatal_error("COULD NOT UPATE PRECIP BRACKET: BOUNDS EXCEEDED?")
6681  end if
6682 
6683  CALL nc_point_var(precip_pre_n,vnp)
6684  CALL nc_point_var(precip_pre_p,vpp)
6685  qprec = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6686 
6687  ! EVAPORATION
6688  CALL update_var_bracket(precip_file,precip_evp_p,precip_evp_n,ptime,status)
6689  IF (status /= 0) THEN
6690  CALL fatal_error("COULD NOT UPATE EVAP BRACKET: BOUNDS EXCEEDED?")
6691  end if
6692 
6693  CALL nc_point_var(precip_evp_n,vnp)
6694  CALL nc_point_var(precip_evp_p,vpp)
6695  qevap = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6696 
6697  CASE DEFAULT
6698  CALL fatal_error("UNKNOWN WINDS_FORCING_TYPE IN UPDATE PRECIPITATION")
6699  END SELECT
6700 
6701 
6702  END SUBROUTINE update_precipitation
6703  !==============================================================================|
6704 
6705 
6706 !==============================================================================|
6707  SUBROUTINE update_wave(NOW,WHS,WDIR,WPER,WLENGTH,WPER_BOT,WUB_BOT)
6708  IMPLICIT NONE
6709  TYPE(time), INTENT(IN) :: now
6710  TYPE(time) :: ptime
6711  REAL(sp), ALLOCATABLE :: whs(:),wdir(:),wper(:),wlength(:),wper_bot(:),wub_bot(:)
6712  REAL(sp), POINTER :: vnp(:), vpp(:)
6713  TYPE(ncftime), POINTER :: ftm
6714  INTEGER :: status
6715 
6716  REAL :: x1,x2,y1,y2,x0,y0,angle
6717  INTEGER :: i
6718 
6719  real:: a2, k2,h2,t2,ub2,w2
6720 
6721  IF(.NOT. ALLOCATED(whs)) CALL fatal_error &
6722  &("THE WAVE HEIGHT VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6723  IF(.NOT. ALLOCATED(wdir)) CALL fatal_error &
6724  &("THE WAVE DIRECTION VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6725  IF(.NOT. ALLOCATED(wper)) CALL fatal_error &
6726  &("THE WAVE PERIOD VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6727  IF(.NOT. ALLOCATED(wlength)) CALL fatal_error &
6728  &("THE WAVE LENGTH VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6729  IF(.NOT. ALLOCATED(wper_bot)) CALL fatal_error &
6730  &("THE BOTTOM WAVE PERIOD VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6731  IF(.NOT. ALLOCATED(wub_bot)) CALL fatal_error &
6732  &("THE BOTTOM WAVE ORBITAL VELOCITY VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6733 
6734 !===================================================
6735  SELECT CASE(wave_kind)
6736 !===================================================
6737  CASE (cnstnt)
6738 
6739  whs(1:mt) = wave_height
6740  wdir(1:mt) = wave_direction
6741  wper(1:mt) = wave_period
6742  wlength(1:mt) = wave_length
6743  wper_bot(1:mt) = wave_per_bot
6744  wub_bot(1:mt) = wave_ub_bot
6745 
6746  RETURN
6747 
6748  CASE(sttc)
6749 
6750  CALL fatal_error("STATIC PRECIP Not Set Up Yet")
6751 
6752  CASE(tmdpndnt)
6753 
6754  CALL fatal_error("TIME DEPENDANT PRECIP Not Set Up Yet")
6755 
6756  CASE(prdc)
6757 
6758  ! TO SET ZERO TIME PHASE USING RUNFILE START TIME
6759 ! PTIME= NOW - RUNFILE_StartTime
6760 
6761  ! TO USE ZERO AS THE PHASE OF THE FORCING
6762  ptime= now
6763 
6764 
6765  ptime = mod(ptime,precip_period)
6766 
6767  CASE(vrbl)
6768 
6769  ptime = now
6770  END SELECT
6771 !===================================================
6772 !===================================================
6773 
6774 
6775 
6776 
6777 !===================================================
6778  SELECT CASE(waves_forcing_type)
6779 !===================================================
6780  CASE(waves_are_wrfgrid)
6781 
6782 !===================================================
6783  CASE(waves_are_fvcomgrid)
6784 !===================================================
6785 
6786  ftm => waves_file%FTIME
6787 
6788  ! WAVE HEIGHT
6789  CALL update_var_bracket(waves_file,waves_height_p,waves_height_n,ptime,status)
6790  IF (status /= 0) THEN
6791  CALL fatal_error("COULD NOT UPATE WAVE HEIGHT BRACKET: BOUNDS EXCEEDED?")
6792  end if
6793 
6794  CALL nc_point_var(waves_height_n,vnp)
6795  CALL nc_point_var(waves_height_p,vpp)
6796  whs = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6797 
6798  ! WAVE DIRECTIION
6799  CALL update_var_bracket(waves_file,waves_direction_p,waves_direction_n,ptime,status)
6800  IF (status /= 0) THEN
6801  CALL fatal_error("COULD NOT UPATE WAVE DIRECTION BRACKET: BOUNDS EXCEEDED?")
6802  end if
6803 
6804  CALL nc_point_var(waves_direction_n,vnp)
6805  CALL nc_point_var(waves_direction_p,vpp)
6806  wdir = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6807 
6808  DO i=1,mt
6809  x1 = cos(vnp(i)*3.1415926/180.0)
6810  x2 = cos(vpp(i)*3.1415926/180.0)
6811  y1 = sin(vnp(i)*3.1415926/180.0)
6812  y2 = sin(vpp(i)*3.1415926/180.0)
6813  x0 = ftm%NEXT_WGHT * x1 + ftm%PREV_WGHT * x2
6814  y0 = ftm%NEXT_WGHT * y1 + ftm%PREV_WGHT * y2
6815  angle = atan2(y0,x0)
6816  IF(angle<0)angle = angle + 3.1415926*2.0
6817  wdir(i) = angle*180.0/3.1415926
6818  END DO
6819 
6820 
6821  ! WAVE LENGTH
6822  CALL update_var_bracket(waves_file,waves_length_p,waves_length_n,ptime,status)
6823  IF (status /= 0) THEN
6824  CALL fatal_error("COULD NOT UPATE WAVE LENGTH BRACKET: BOUNDS EXCEEDED?")
6825  end if
6826 
6827  CALL nc_point_var(waves_length_n,vnp)
6828  CALL nc_point_var(waves_length_p,vpp)
6829  wlength = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6830 
6831 
6832  ! WAVE PERIOD
6833  CALL update_var_bracket(waves_file,waves_period_p,waves_period_n,ptime,status)
6834  IF (status /= 0) THEN
6835  CALL fatal_error("COULD NOT UPATE WAVE PERIOD BRACKET: BOUNDS EXCEEDED?")
6836  end if
6837 
6838  CALL nc_point_var(waves_period_n,vnp)
6839  CALL nc_point_var(waves_period_p,vpp)
6840  wper = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6841 
6842 
6843  ! BOTTOM WAVE PERIOD
6844  CALL update_var_bracket(waves_file,waves_per_bot_p,waves_per_bot_n,ptime,status)
6845  IF (status /= 0) THEN
6846  CALL fatal_error("COULD NOT UPATE BOTTOM WAVE PERIOD BRACKET: BOUNDS EXCEEDED?")
6847  end if
6848 
6849  CALL nc_point_var(waves_per_bot_n,vnp)
6850  CALL nc_point_var(waves_per_bot_p,vpp)
6851  wper_bot = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6852 
6853 
6854  ! BOTTOM ORBITAL VELOCITY
6855  CALL update_var_bracket(waves_file,waves_ub_bot_p,waves_ub_bot_n,ptime,status)
6856  IF (status /= 0) THEN
6857  CALL fatal_error("COULD NOT UPATE BOTTOM ORBITAL VELOCITY BRACKET: BOUNDS EXCEEDED?")
6858  end if
6859 
6860  CALL nc_point_var(waves_ub_bot_n,vnp)
6861  CALL nc_point_var(waves_ub_bot_p,vpp)
6862  wub_bot = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6863 ! print*,whs(36),wper(36),wlength(36)
6864 !---------------------------------------------------------------------!
6865 ! Test bottom orbital velocity
6866 !---------------------------------------------------------------------!
6867 ! a2=0.5*whs(159)
6868 ! K2=2.0*3.1415926/wlength(159)
6869 ! H2=10.0
6870 ! T2=wper(159)
6871 ! w2=sqrt(9.8*K2*SINH(K2*H2)/COSH(K2*H2))
6872 ! Ub2=a2*W2/sinh(H2*K2)
6873 ! print*,whs(159),ub2
6874 
6875 
6876  CASE DEFAULT
6877  CALL fatal_error("UNKNOWN WAVES_FORCING_TYPE IN UPDATE WAVE")
6878  END SELECT
6879 
6880 
6881  END SUBROUTINE update_wave
6882  !==============================================================================|
6883 
6884 
6885 
6886 
6887 !==============================================================================|
6888  SUBROUTINE update_airpressure(NOW,PA_AIR)
6889  IMPLICIT NONE
6890  TYPE(time), INTENT(IN) :: now
6891  TYPE(time) :: atime
6892  REAL(sp), ALLOCATABLE :: pa_air(:)
6893  REAL(sp), POINTER :: vnp(:), vpp(:)
6894  TYPE(ncftime), POINTER :: ftm
6895  INTEGER :: status
6896 
6897  IF(.NOT. ALLOCATED(pa_air)) CALL fatal_error &
6898  &("THE AIR PRESSURE VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6899 
6900 !===================================================
6901  SELECT CASE(airpressure_kind)
6902 !===================================================
6903  CASE (cnstnt)
6904 
6905  pa_air(1:mt) = airpressure_value
6906 
6907  RETURN
6908 
6909  CASE(sttc)
6910 
6911  CALL fatal_error("STATIC AIR PRESSURE Not Set Up Yet")
6912 
6913  CASE(tmdpndnt)
6914 
6915  CALL fatal_error("TIME DEPENDANT AIR PRESSURE Not Set Up Yet")
6916 
6917  CASE(prdc)
6918 
6919  ! TO SET ZERO TIME PHASE USING RUNFILE START TIME
6920 ! ATIME= NOW - RUNFILE_StartTime
6921 
6922  ! TO USE ZERO AS THE PHASE OF THE FORCING
6923  atime= now
6924 
6925 
6926  atime = mod(atime,airpressure_period)
6927 
6928  CASE(vrbl)
6929 
6930  atime = now
6931  END SELECT
6932 !===================================================
6933 !===================================================
6934 
6935 
6936 
6937 
6938 !===================================================
6939  SELECT CASE(airpressure_forcing_type)
6940 !===================================================
6941  CASE(airpressure_is_wrfgrid)
6942 
6943  ftm => airpressure_p_file%FTIME
6944 
6945  ! AIR PRESSURE
6946  CALL update_var_bracket(airpressure_p_file,air_pressure_p,air_pressure_n,atime,status,airpressure_intp_n)
6947  IF (status /= 0) THEN
6948  CALL fatal_error("COULD NOT UPATE AIR PRESSURE BRACKET: BOUNDS EXCEEDED?")
6949  end if
6950 
6951  CALL nc_point_var(air_pressure_n,vnp)
6952  CALL nc_point_var(air_pressure_p,vpp)
6953  pa_air = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6954 
6955 !===================================================
6956  CASE(airpressure_is_fvcomgrid)
6957 !===================================================
6958 
6959  ftm => airpressure_p_file%FTIME
6960 
6961  ! AIR PRESSURE
6962  CALL update_var_bracket(airpressure_p_file,air_pressure_p,air_pressure_n,atime,status)
6963  IF (status /= 0) THEN
6964  CALL fatal_error("COULD NOT UPATE AIR PRESSURE BRACKET: BOUNDS EXCEEDED?")
6965  end if
6966 
6967  CALL nc_point_var(air_pressure_n,vnp)
6968  CALL nc_point_var(air_pressure_p,vpp)
6969  pa_air = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
6970 
6971  CASE DEFAULT
6972  CALL fatal_error("UNKNOWN AIRPRESSURE_FORCING_TYPE IN UPDATE AIR PRESSURE")
6973  END SELECT
6974 
6975 
6976  END SUBROUTINE update_airpressure
6977  !==============================================================================|
6978  SUBROUTINE update_tide(NOW,BND_ELV)
6979  IMPLICIT NONE
6980  TYPE(time), INTENT(IN) :: now
6981  REAL(sp), ALLOCATABLE :: bnd_elv(:)
6982  REAL(sp), POINTER :: vnp(:), vpp(:)
6983  TYPE(ncftime), POINTER :: ftm
6984  INTEGER :: status
6985 
6986  IF(.NOT. ALLOCATED(bnd_elv)) CALL fatal_error &
6987  &("THE BOUNDARY ELEVATION VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
6988 
6989 
6990  SELECT CASE(tide_forcing_type)
6991  CASE(tide_forcing_timeseries)
6992 
6993  ftm => tide_file%FTIME
6994 
6995  ! PRECIPITATION
6996  CALL update_var_bracket(tide_file,tide_elv_p,tide_elv_n,now,status)
6997  IF (status /= 0) THEN
6998  CALL fatal_error("COULD NOT UPATE TIDE ELVATION BRACKET: BOUNDS EXCEEDED?")
6999  end if
7000 
7001  CALL nc_point_var(tide_elv_n,vnp)
7002  CALL nc_point_var(tide_elv_p,vpp)
7003  bnd_elv = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7004 
7005  CASE DEFAULT
7006  CALL fatal_error("UNKNOWN TIDAL FORCING FILE TYPE IN UPDATE_TIDE")
7007  END SELECT
7008 
7009 
7010  END SUBROUTINE update_tide
7011  !==============================================================================|
7012  SUBROUTINE update_obc_salt(NOW,SALT)
7013  IMPLICIT NONE
7014  TYPE(time), INTENT(IN) :: now
7015  REAL(sp), ALLOCATABLE :: salt(:,:)
7016  REAL(sp), POINTER :: vnp(:,:), vpp(:,:)
7017  TYPE(ncftime), POINTER :: ftm
7018  INTEGER :: status
7019 
7020  IF(.NOT. ALLOCATED(salt)) CALL fatal_error &
7021  &("THE BOUNDARY SALINITY VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
7022 
7023  SELECT CASE(obc_s_type)
7024  CASE(obc_s_sigma)
7025 
7026  ftm => obc_s_file%FTIME
7027 
7028  ! OBC_SALT
7029  CALL update_var_bracket(obc_s_file,obc_s_p,obc_s_n,now,status)
7030  IF (status /= 0) THEN
7031  CALL fatal_error("COULD NOT UPATE OBC SALINITY BRACKET: BOUNDS EXCEEDED?")
7032  end if
7033 
7034  CALL nc_point_var(obc_s_n,vnp)
7035  CALL nc_point_var(obc_s_p,vpp)
7036  salt = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7037 
7038  CASE DEFAULT
7039  CALL fatal_error("UNKNOWN OBC SALINITY FILE TYPE IN UPDATE_OBC_SALT")
7040  END SELECT
7041 
7042 
7043  END SUBROUTINE update_obc_salt
7044  !==============================================================================|
7045  SUBROUTINE update_obc_temp(NOW,TEMP)
7046  IMPLICIT NONE
7047  TYPE(time), INTENT(IN) :: now
7048  REAL(sp), ALLOCATABLE :: temp(:,:)
7049  REAL(sp), POINTER :: vnp(:,:), vpp(:,:)
7050  TYPE(ncftime), POINTER :: ftm
7051  INTEGER :: status
7052 
7053  IF(.NOT. ALLOCATED(temp)) CALL fatal_error &
7054  &("THE BOUNDARY TEMPERATURE VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
7055 
7056  SELECT CASE(obc_t_type)
7057  CASE(obc_t_sigma)
7058 
7059  ftm => obc_t_file%FTIME
7060 
7061  ! PRECIPITATION
7062  CALL update_var_bracket(obc_t_file,obc_t_p,obc_t_n,now,status)
7063  IF (status /= 0) THEN
7064  CALL fatal_error("COULD NOT UPATE OBC TEMPERATURE BRACKET: BOUNDS EXCEEDED?")
7065  end if
7066 
7067  CALL nc_point_var(obc_t_n,vnp)
7068  CALL nc_point_var(obc_t_p,vpp)
7069  temp = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7070 
7071  CASE DEFAULT
7072  CALL fatal_error("UNKNOWN OBC TEMPERATURE FILE TYPE IN UPDATE_OBC_TEMP")
7073  END SELECT
7074 
7075 
7076  END SUBROUTINE update_obc_temp
7077  !==============================================================================|
7078  !==============================================================================|
7079  !==============================================================================|
7080  !==============================================================================|
7081  SUBROUTINE update_ice(NOW,SAT,SWV,SPQ,CLD)
7082  IMPLICIT NONE
7083  TYPE(time), INTENT(IN) :: now
7084  TYPE(time) :: wtime
7085  REAL(sp), ALLOCATABLE :: sat(:)
7086  REAL(sp), ALLOCATABLE :: swv(:)
7087  REAL(sp), ALLOCATABLE :: slp(:)
7088  REAL(sp), ALLOCATABLE :: spq(:)
7089  REAL(sp), ALLOCATABLE :: cld(:)
7090  REAL(sp), POINTER :: vnp(:), vpp(:)
7091  TYPE(ncftime), POINTER :: ftm
7092  INTEGER :: status
7093 
7094  IF(.NOT. ALLOCATED(sat)) CALL fatal_error &
7095  &("THE Sea Surface Air Temperature VARIABLE PASSED TO UPDATE ICE IS NOT ALLOCATED")
7096  IF(.NOT. ALLOCATED(swv)) CALL fatal_error &
7097  &("THE SHORTWAVE RADIATION VARIABLE PASSED TO UPDATE ICE IS NOT ALLOCATED")
7098  IF(.NOT. ALLOCATED(spq)) CALL fatal_error &
7099  &("THE SPECIFIC HUMIDIY VARIABLE PASSED TO UPDATE ICE IS NOT ALLOCATED")
7100  IF(.NOT. ALLOCATED(cld)) CALL fatal_error &
7101  &("THE CLOUD COVER VARIABLE PASSED TO UPDATE ICE IS NOT ALLOCATED")
7102 
7103 !===================================================
7104  SELECT CASE(ice_forcing_kind)
7105 !===================================================
7106  CASE (cnstnt)
7107 
7108  sat(1:mt) = ice_air_temp
7109  spq(1:mt) = ice_spec_humidity
7110  cld(1:mt) = ice_cloud_cover
7111  swv(1:mt) = ice_shortwave
7112 
7113  RETURN
7114 
7115  CASE(sttc)
7116 
7117  CALL fatal_error("STATIC ICE FORCING Not Set Up Yet")
7118 
7119  CASE(tmdpndnt)
7120 
7121  CALL fatal_error("TIME DEPENDANT ICE FORCING Not Set Up Yet")
7122 
7123  CASE(prdc)
7124 
7125  ! TO SET ZERO TIME PHASE USING RUNFILE START TIME
7126 ! WTIME= NOW - RUNFILE_StartTime
7127 
7128  ! TO USE ZERO AS THE PHASE OF THE FORCING
7129  wtime= now
7130 
7131 
7132  wtime = mod(wtime,ice_period)
7133 
7134  CASE(vrbl)
7135 
7136  wtime = now
7137  END SELECT
7138 
7139 !===================================================
7140  SELECT CASE(ice_forcing_type)
7141 !===================================================
7142  CASE(ice_is_wrfgrid)
7143 !===================================================
7144 
7145  ftm => ice_file%FTIME
7146 
7147  ! THE SEA SURFACE AIR TEMP
7148  CALL update_var_bracket(ice_file,ice_sat_p,ice_sat_n,wtime,status,ice_intp_n)
7149  IF (status /= 0) THEN
7150  CALL fatal_error("COULD NOT UPATE ICE Surface Air Temp BRACKET: BOUNDS EXCEEDED?")
7151  end if
7152 
7153  CALL nc_point_var(ice_sat_n,vnp)
7154  CALL nc_point_var(ice_sat_p,vpp)
7155  sat = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7156 
7157  ! SHORT WAVE
7158 ! CALL UPDATE_VAR_BRACKET(ICE_FILE,ICE_SWV_P,ICE_SWV_N,WTIME,STATUS,ICE_INTP_N)
7159  CALL update_var_bracket(heat_file,ice_swv_p,ice_swv_n,wtime,status,ice_intp_n)
7160  IF (status /= 0) THEN
7161  CALL fatal_error("COULD NOT UPDATE ICE SHORTWAVE BRACKET: BOUNDS EXCEEDED?")
7162  end if
7163 
7164  CALL nc_point_var(ice_swv_n,vnp)
7165  CALL nc_point_var(ice_swv_p,vpp)
7166  swv = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7167 
7168  ! THE SPECIFIC HUMIDITY
7169  CALL update_var_bracket(ice_file,ice_spq_p,ice_spq_n,wtime,status,ice_intp_n)
7170  IF (status /= 0) THEN
7171  CALL fatal_error("COULD NOT UPATE ICE SPECIFIC HUMIDITY BRACKET: BOUNDS EXCEEDED?")
7172  end if
7173 
7174  CALL nc_point_var(ice_spq_n,vnp)
7175  CALL nc_point_var(ice_spq_p,vpp)
7176  spq = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7177 
7178 
7179  ! THE CLOUD COVER
7180  CALL update_var_bracket(ice_file,ice_cld_p,ice_cld_n,wtime,status,ice_intp_n)
7181  IF (status /= 0) THEN
7182  CALL fatal_error("COULD NOT UPATE ICE CLOUD COVER BRACKET: BOUNDS EXCEEDED?")
7183  end if
7184 
7185  CALL nc_point_var(ice_cld_n,vnp)
7186  CALL nc_point_var(ice_cld_p,vpp)
7187  cld = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7188 
7189 
7190 
7191 !===================================================
7192 !JQI CASE(ICING_IS_FVCOMGRID)
7193  CASE(ice_is_fvcomgrid)
7194 !===================================================
7195 !JQI FTM => ICING_FILE%FTIME
7196  ftm => ice_file%FTIME
7197 
7198 
7199  ! THE SEA SURFACE AIR TEMP
7200  CALL update_var_bracket(ice_file,ice_sat_p,ice_sat_n,wtime,status)
7201  IF (status /= 0) THEN
7202  CALL fatal_error("COULD NOT UPATE ICE Surface Air Temp BRACKET: BOUNDS EXCEEDED?")
7203  end if
7204 
7205  CALL nc_point_var(ice_sat_n,vnp)
7206  CALL nc_point_var(ice_sat_p,vpp)
7207  sat = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7208 
7209  ! SHORT WAVE
7210 ! CALL UPDATE_VAR_BRACKET(ICE_FILE,ICE_SWV_P,ICE_SWV_N,WTIME,STATUS)
7211  CALL update_var_bracket(heat_file,ice_swv_p,ice_swv_n,wtime,status)
7212  IF (status /= 0) THEN
7213  CALL fatal_error("COULD NOT UPDATE ICE SHORTWAVE BRACKET: BOUNDS EXCEEDED?")
7214  end if
7215 
7216  CALL nc_point_var(ice_swv_n,vnp)
7217  CALL nc_point_var(ice_swv_p,vpp)
7218  swv = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7219 
7220 
7221  ! THE SPECIFIC HUMIDITY
7222  CALL update_var_bracket(ice_file,ice_spq_p,ice_spq_n,wtime,status)
7223  IF (status /= 0) THEN
7224  CALL fatal_error("COULD NOT UPATE ICE SPECIFIC HUMIDITY BRACKET: BOUNDS EXCEEDED?")
7225  end if
7226 
7227  CALL nc_point_var(ice_spq_n,vnp)
7228  CALL nc_point_var(ice_spq_p,vpp)
7229  spq = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7230 
7231 
7232  ! THE CLOUD COVER
7233  CALL update_var_bracket(ice_file,ice_cld_p,ice_cld_n,wtime,status)
7234  IF (status /= 0) THEN
7235  CALL fatal_error("COULD NOT UPATE ICE CLOUD COVER BRACKET: BOUNDS EXCEEDED?")
7236  end if
7237 
7238  CALL nc_point_var(ice_cld_n,vnp)
7239  CALL nc_point_var(ice_cld_p,vpp)
7240  cld = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7241 
7242 !===================================================
7243  CASE DEFAULT
7244  CALL fatal_error("UNKNOWN ICING_FORCING_TYPE IN UPDATE ICING")
7245  END SELECT
7246 !===================================================
7247  END SUBROUTINE update_ice
7248 
7249 !==============================================================================|
7250 !==============================================================================|
7251  SUBROUTINE update_icing(NOW,SAT,WSPDX,WSPDY)
7252  IMPLICIT NONE
7253  TYPE(time), INTENT(IN) :: now
7254  TYPE(time) :: wtime
7255  REAL(sp), ALLOCATABLE :: sat(:)
7256  REAL(sp), ALLOCATABLE :: wspdx(:)
7257  REAL(sp), ALLOCATABLE :: wspdy(:)
7258  REAL(sp), POINTER :: vnp(:), vpp(:)
7259  TYPE(ncftime), POINTER :: ftm
7260  INTEGER :: status
7261  REAL(sp), PARAMETER :: k2c = 273.15_sp
7262 
7263  IF(.NOT. ALLOCATED(sat)) CALL fatal_error &
7264  &("THE Sea Surface Air Temperature VARIABLE PASSED TO UPDATE IS NOT ALLOCATED")
7265  IF(.NOT. ALLOCATED(wspdx) .or. .NOT.ALLOCATED(wspdy)) CALL fatal_error &
7266  &("THE WIND SPEED VARIABLES PASSED TO UPDATE ARE NOT ALLOCATED")
7267 
7268 !===================================================
7269  SELECT CASE(icing_forcing_kind)
7270 !===================================================
7271  CASE (cnstnt)
7272 
7273  wspdx(1:mt) = icing_wspd
7274  wspdy=0.0_sp
7275  ! WEATHER DATA NEEDS TO HAVE WIND VELOCITY, MUST USE RECORD
7276  ! VECTOR BUT THE MODEL ONLY NEEDS A MAGNITUDE.
7277 
7278  sat(1:mt) = icing_air_temp
7279 
7280  RETURN
7281 
7282  CASE(sttc)
7283 
7284  CALL fatal_error("STATIC ICING Not Set Up Yet")
7285 
7286  CASE(tmdpndnt)
7287 
7288  CALL fatal_error("TIME DEPENDANT ICING Not Set Up Yet")
7289 
7290  CASE(prdc)
7291 
7292  ! TO SET ZERO TIME PHASE USING RUNFILE START TIME
7293 ! WTIME= NOW - RUNFILE_StartTime
7294 
7295  ! TO USE ZERO AS THE PHASE OF THE FORCING
7296  wtime= now
7297 
7298 
7299  wtime = mod(wtime,icing_period)
7300 
7301  CASE(vrbl)
7302 
7303  wtime = now
7304  END SELECT
7305 
7306 
7307 !===================================================
7308  SELECT CASE(icing_forcing_type)
7309 !===================================================
7310  CASE(icing_is_wrfgrid)
7311 !===================================================
7312 
7313  ftm => icing_file%FTIME
7314 
7315  ! THE X DIRECTION WIND SPEED
7316  CALL update_var_bracket(icing_file,icing_wspx_p,icing_wspx_n,wtime,status,icing_intp_n)
7317  IF (status /= 0) THEN
7318  CALL fatal_error("COULD NOT UPATE WIND SPEED X BRACKET: BOUNDS EXCEEDED?")
7319  end if
7320 
7321  CALL nc_point_var(icing_wspx_n,vnp)
7322  CALL nc_point_var(icing_wspx_p,vpp)
7323 ! ALLOCATE(WSPDX(0:MT))
7324  wspdx = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7325 
7326  ! THE Y DIRECTION WIND SPEED
7327  CALL update_var_bracket(icing_file,icing_wspy_p,icing_wspy_n,wtime,status,icing_intp_n)
7328  IF (status /= 0) THEN
7329  CALL fatal_error("COULD NOT UPATE WIND SPEED Y BRACKET: BOUNDS EXCEEDED?")
7330  end if
7331 
7332  CALL nc_point_var(icing_wspy_n,vnp)
7333  CALL nc_point_var(icing_wspy_p,vpp)
7334 ! ALLOCATE(WSPDY(0:MT))
7335  wspdy = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7336 
7337 ! WSPD = sqrt(wspdy**2 + wspdx**2)
7338 ! wspd(0) = 0.0_sp
7339 ! deallocate(wspdy,wspdx)
7340 
7341  ! THE SEA SURFACE AIR TEMP
7342  CALL update_var_bracket(icing_file,icing_sat_p,icing_sat_n,wtime,status,icing_intp_n)
7343  IF (status /= 0) THEN
7344  CALL fatal_error("COULD NOT UPATE Surface Air Temp BRACKET: BOUNDS EXCEEDED?")
7345  end if
7346 
7347  CALL nc_point_var(icing_sat_n,vnp)
7348  CALL nc_point_var(icing_sat_p,vpp)
7349  sat = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp - k2c
7350 
7351 !===================================================
7352  CASE(icing_is_fvcomgrid)
7353 !===================================================
7354  ftm => icing_file%FTIME
7355 
7356  ! THE X DIRECTION WIND SPEED
7357  CALL update_var_bracket(icing_file,icing_wspx_p,icing_wspx_n,wtime,status)
7358  IF (status /= 0) THEN
7359  CALL fatal_error("COULD NOT UPATE WIND SPEED X BRACKET: BOUNDS EXCEEDED?")
7360  end if
7361 
7362  CALL nc_point_var(icing_wspx_n,vnp)
7363  CALL nc_point_var(icing_wspx_p,vpp)
7364 ! ALLOCATE(WSPDX(0:MT))
7365  wspdx = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7366 
7367  ! THE Y DIRECTION WIND SPEED
7368  CALL update_var_bracket(icing_file,icing_wspy_p,icing_wspy_n,wtime,status)
7369  IF (status /= 0) THEN
7370  CALL fatal_error("COULD NOT UPATE WIND SPEED Y BRACKET: BOUNDS EXCEEDED?")
7371  end if
7372 
7373  CALL nc_point_var(icing_wspy_n,vnp)
7374  CALL nc_point_var(icing_wspy_p,vpp)
7375 ! ALLOCATE(WSPDY(0:MT))
7376  wspdy = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp
7377 
7378 ! WSPD = sqrt(wspdy**2 + wspdx**2)
7379 ! wspd(0) = 0.0_sp
7380 ! deallocate(wspdy,wspdx)
7381 
7382  ! THE SEA SURFACE AIR TEMP
7383  CALL update_var_bracket(icing_file,icing_sat_p,icing_sat_n,wtime,status)
7384  IF (status /= 0) THEN
7385  CALL fatal_error("COULD NOT UPATE Surface Air Temp BRACKET: BOUNDS EXCEEDED?")
7386  end if
7387 
7388  CALL nc_point_var(icing_sat_n,vnp)
7389  CALL nc_point_var(icing_sat_p,vpp)
7390  sat = ftm%NEXT_WGHT * vnp + ftm%PREV_WGHT * vpp -k2c
7391 
7392 !===================================================
7393  CASE DEFAULT
7394  CALL fatal_error("UNKNOWN ICING_FORCING_TYPE IN UPDATE ICING")
7395  END SELECT
7396 !===================================================
7397 
7398 
7399  END SUBROUTINE update_icing
7400 
7401 !=====================================================================
7402 !
7403 !=====================================================================
7404 
7405 
7406 !==============================================================================|
7407  !========================================================================
7408 
7409  SUBROUTINE gday2(IDD,IMM,IYY,ICC,KD)
7410 !
7411 ! given day,month,year and century(each 2 digits), gday returns
7412 ! the day#, kd based on the gregorian calendar.
7413 ! the gregorian calendar, currently 'universally' in use was
7414 ! initiated in europe in the sixteenth century. note that gday
7415 ! is valid only for gregorian calendar dates.
7416 !
7417 ! kd=1 corresponds to january 1, 0000
7418 !
7419 ! note that the gregorian reform of the julian calendar
7420 ! omitted 10 days in 1582 in order to restore the date
7421 ! of the vernal equinox to march 21 (the day after
7422 ! oct 4, 1582 became oct 15, 1582), and revised the leap
7423 ! year rule so that centurial years not divisible by 400
7424 ! were not leap years.
7425 !
7426 ! this routine was written by eugene neufeld, at ios, in june 1990.
7427 !
7428  integer idd, imm, iyy, icc, kd
7429  integer ndp(13)
7430  integer ndm(12)
7431  data ndp/0,31,59,90,120,151,181,212,243,273,304,334,365/
7432  data ndm/31,28,31,30,31,30,31,31,30,31,30,31/
7433 !
7434 ! test for invalid input:
7435  if(icc.lt.0)then
7436 ! write(11,5000)icc
7437  call pstop
7438  endif
7439  if(iyy.lt.0.or.iyy.gt.99)then
7440 ! write(11,5010)iyy
7441  call pstop
7442  endif
7443  if(imm.le.0.or.imm.gt.12)then
7444 ! write(11,5020)imm
7445  call pstop
7446  endif
7447  if(idd.le.0)then
7448 ! write(11,5030)idd
7449  call pstop
7450  endif
7451  if(imm.ne.2.and.idd.gt.ndm(imm))then
7452 ! write(11,5030)idd
7453  call pstop
7454  endif
7455  if(imm.eq.2.and.idd.gt.29)then
7456 ! write(11,5030)idd
7457  call pstop
7458  endif
7459  if(imm.eq.2.and.idd.gt.28.and.((iyy/4)*4-iyy.ne.0.or.(iyy.eq.0.and.(icc/4)*4-icc.ne.0)))then
7460 ! write(11,5030)idd
7461  call pstop
7462  endif
7463 5000 format(' input error. icc = ',i7)
7464 5010 format(' input error. iyy = ',i7)
7465 5020 format(' input error. imm = ',i7)
7466 5030 format(' input error. idd = ',i7)
7467 !
7468 ! calculate day# of last day of last century:
7469  kd = icc*36524 + (icc+3)/4
7470 !
7471 ! calculate day# of last day of last year:
7472  kd = kd + iyy*365 + (iyy+3)/4
7473 !
7474 ! adjust for century rule:
7475 ! (viz. no leap-years on centurys except when the 2-digit
7476 ! century is divisible by 4.)
7477  if(iyy.gt.0.and.(icc-(icc/4)*4).ne.0) kd=kd-1
7478 ! kd now truly represents the day# of the last day of last year.
7479 !
7480 ! calculate day# of last day of last month:
7481  kd = kd + ndp(imm)
7482 !
7483 ! adjust for leap years:
7484  if(imm.gt.2.and.((iyy/4)*4-iyy).eq.0.and.((iyy.ne.0).or.(((icc/4)*4-icc).eq.0))) kd=kd+1
7485 ! kd now truly represents the day# of the last day of the last
7486 ! month.
7487 !
7488 ! calculate the current day#:
7489  kd = kd + idd
7490 
7491  RETURN
7492  END SUBROUTINE gday2
7493 
7494 
7495 
7496 
7497 END MODULE mod_force
7498 
all_vars::ntsn
integer, dimension(:), allocatable, target ntsn
Definition: mod_main.f90:1023
mod_interp::interp_weights
Definition: mod_interp.f90:76
mod_input::load_julian_obc
subroutine load_julian_obc(NTC, NAMES, PRD, EQ_AMP, EQ_BETA, EQ_TYPE, MPTD, PHS, RF, TORG)
Definition: mod_input.f90:2580
mod_force::update_ice
subroutine, public update_ice(NOW, SAT, SWV, SPQ, CLD)
Definition: mod_force.f90:7082
all_vars::qprec
real(sp), dimension(:), allocatable, target qprec
Definition: mod_main.f90:1239
all_vars::t2
real(sp), dimension(:,:), allocatable, target t2
Definition: mod_main.f90:1314
mod_utils
Definition: mod_utils.f90:40
all_vars::h
real(sp), dimension(:), allocatable, target h
Definition: mod_main.f90:1131
mod_force::update_airpressure
subroutine, public update_airpressure(NOW, PA_AIR)
Definition: mod_force.f90:6889
mod_par::elid
integer, dimension(:), pointer elid
Definition: mod_par.f90:53
mod_force::precip_forcing_comments
character(len=char_max_attlen), dimension(:), allocatable, public precip_forcing_comments
Definition: mod_force.f90:222
mod_force::fvcom_cap_grid_source
character(len=80), parameter, public fvcom_cap_grid_source
Definition: mod_force.f90:67
bcs::emean
real(sp), dimension(:), allocatable emean
Definition: mod_main.f90:1798
mod_ncll
Definition: mod_ncll.f90:40
mod_spherical
Definition: mod_spherical.f90:45
mod_utils::dbg_scl
integer, parameter dbg_scl
Definition: mod_utils.f90:67
all_vars::el
real(sp), dimension(:), allocatable, target el
Definition: mod_main.f90:1134
mod_ncll::find_file
Definition: mod_ncll.f90:205
all_vars::vqdist
real(sp), dimension(:,:), allocatable, target vqdist
Definition: mod_main.f90:1217
all_vars::wper
real(sp), dimension(:), allocatable, target wper
Definition: mod_main.f90:1244
mod_ncll::find_att
Definition: mod_ncll.f90:262
all_vars::wub_bot
real(sp), dimension(:), allocatable, target wub_bot
Definition: mod_main.f90:1247
bcs::tide_type
character(len=80), dimension(:), allocatable tide_type
Definition: mod_main.f90:1803
mod_utils::dbg_set
logical function dbg_set(vrb)
Definition: mod_utils.f90:182
mod_utils::get_value
subroutine get_value(LNUM, NUMCHAR, TEXT_LINE, VARNAME, VARTYPE, LOGVAL, STRINGVAL, REALVAL, INTVAL, NVAL)
Definition: mod_utils.f90:1677
all_vars::qdis2
real(sp), dimension(:), allocatable, target qdis2
Definition: mod_main.f90:1222
mod_force::surf_forcing_pt_source
character(len=80), parameter, public surf_forcing_pt_source
Definition: mod_force.f90:73
mod_nctools::is_valid_datetime
logical function is_valid_datetime(VAR, tzone)
Definition: mod_nctools.f90:6772
mod_ncll::ncvar
Definition: mod_ncll.f90:88
mod_force::update_wave
subroutine, public update_wave(NOW, WHS, WDIR, WPER, WLENGTH, WPER_BOT, WUB_BOT)
Definition: mod_force.f90:6708
all_vars::art1
real(sp), dimension(:), allocatable, target art1
Definition: mod_main.f90:1010
all_vars::qdis
real(sp), dimension(:), allocatable, target qdis
Definition: mod_main.f90:1220
all_vars::yc
real(sp), dimension(:), allocatable, target yc
Definition: mod_main.f90:1004
mod_force::tide_forcing_type
integer, public tide_forcing_type
Definition: mod_force.f90:78
mod_force::update_obc_temp
subroutine, public update_obc_temp(NOW, TEMP)
Definition: mod_force.f90:7046
mod_time::print_real_time
subroutine print_real_time(mjd, IPT, char, TZONE)
Definition: mod_time.f90:1201
mod_interp
Definition: mod_interp.f90:40
mod_par
Definition: mod_par.f90:40
mod_force::tide_forcing_timeseries
integer, parameter, public tide_forcing_timeseries
Definition: mod_force.f90:80
mod_force::update_icing
subroutine, public update_icing(NOW, SAT, WSPDX, WSPDY)
Definition: mod_force.f90:7252
all_vars::vymin
real(sp) vymin
Definition: mod_main.f90:989
mod_ncll::print_file
subroutine print_file(NCF)
Definition: mod_ncll.f90:857
bcs::apt
real(sp), dimension(:,:), allocatable apt
Definition: mod_main.f90:1796
mod_nctools::nc_read_var
subroutine nc_read_var(VAR, STKCNT, STKRNG, IOSTART, IOCOUNT, IOSTRIDE, DEALERID, PARALLEL)
Definition: mod_nctools.f90:5385
all_vars::angleq
real(sp), dimension(:), allocatable, target angleq
Definition: mod_main.f90:1228
all_vars::wlength
real(sp), dimension(:), allocatable, target wlength
Definition: mod_main.f90:1245
mod_time::mod
Definition: mod_time.f90:69
mod_force::update_obc_salt
subroutine, public update_obc_salt(NOW, SALT)
Definition: mod_force.f90:7013
mod_ncll::ncatt
Definition: mod_ncll.f90:70
mod_force::airpressure_forcing_comments
character(len=char_max_attlen), dimension(:), allocatable, public airpressure_forcing_comments
Definition: mod_force.f90:238
all_vars::sdis
real(sp), dimension(:), allocatable, target sdis
Definition: mod_main.f90:1225
mod_force::tide_forcing_spectral
integer, parameter, public tide_forcing_spectral
Definition: mod_force.f90:79
mod_par::nlid
integer, dimension(:), pointer nlid
Definition: mod_par.f90:54
all_vars::riv_gl2loc
integer, dimension(:), allocatable, target riv_gl2loc
Definition: mod_main.f90:1218
all_vars::el1
real(sp), dimension(:), allocatable, target el1
Definition: mod_main.f90:1118
bcs::beta_eqi
real(sp), dimension(:), allocatable beta_eqi
Definition: mod_main.f90:1802
bcs::period
real(sp), dimension(:), allocatable period
Definition: mod_main.f90:1795
all_vars::rdisq
real(sp), dimension(:,:), allocatable, target rdisq
Definition: mod_main.f90:1227
all_vars::wdir
real(sp), dimension(:), allocatable, target wdir
Definition: mod_main.f90:1243
all_vars::vx
real(sp), dimension(:), allocatable, target vx
Definition: mod_main.f90:1001
mod_force::gwater_forcing_comments
character(len=char_max_attlen), dimension(:), allocatable, public gwater_forcing_comments
Definition: mod_force.f90:121
mod_force::heat_calculate_comments
character(len=char_max_attlen), dimension(:), allocatable, public heat_calculate_comments
Definition: mod_force.f90:160
mod_ncll::find_unlimited
Definition: mod_ncll.f90:310
mod_nctools::is_valid_float_seconds
logical function is_valid_float_seconds(VAR, tzone)
Definition: mod_nctools.f90:7159
mod_time
Definition: mod_time.f90:40
bcs::iobcn
integer iobcn
Definition: mod_main.f90:1777
bcs::ntidecomps
integer ntidecomps
Definition: mod_main.f90:1794
all_vars::wper_bot
real(sp), dimension(:), allocatable, target wper_bot
Definition: mod_main.f90:1246
mod_utils::pstop
subroutine pstop
Definition: mod_utils.f90:273
mod_force::wrf_grid_source
character(len=80), parameter, public wrf_grid_source
Definition: mod_force.f90:70
mod_force::setup_forcing
subroutine, public setup_forcing
Definition: mod_force.f90:301
all_vars::vy
real(sp), dimension(:), allocatable, target vy
Definition: mod_main.f90:1002
mod_force::update_groundwater
subroutine, public update_groundwater(NOW, GW_FLUX, GW_TEMP, GW_SALT)
Definition: mod_force.f90:6200
mod_force::update_tide
subroutine, public update_tide(NOW, BND_ELV)
Definition: mod_force.f90:6979
mod_time::read_datetime
type(time) function read_datetime(timestr, frmt, TZONE, status)
Definition: mod_time.f90:640
all_vars::nbe
integer, dimension(:,:), allocatable, target nbe
Definition: mod_main.f90:1020
bcs::i_obc_n
integer, dimension(:), allocatable i_obc_n
Definition: mod_main.f90:1779
mod_force
Definition: mod_force.f90:40
mod_utils::dbg_sbrio
integer, parameter dbg_sbrio
Definition: mod_utils.f90:70
mod_utils::warning
subroutine warning(ER1, ER2, ER3, ER4)
Definition: mod_utils.f90:251
mod_utils::degrees2meters
Definition: mod_utils.f90:88
mod_time::time
Definition: mod_time.f90:59
mod_force::heat_forcing_comments
character(len=char_max_attlen), dimension(:), allocatable, public heat_forcing_comments
Definition: mod_force.f90:159
mod_nctools::nc_point_var
Definition: mod_nctools.f90:173
all_vars::nv
integer, dimension(:,:), allocatable, target nv
Definition: mod_main.f90:1018
mod_nctools::update_var_bracket
subroutine update_var_bracket(NCF, VPREV, VNEXT, NOW, status, INTERP)
Definition: mod_nctools.f90:7690
mod_force::icing_forcing_comments
character(len=char_max_attlen), dimension(:), allocatable, public icing_forcing_comments
Definition: mod_force.f90:272
mod_force::obc_s_comments
character(len=char_max_attlen), public obc_s_comments
Definition: mod_force.f90:131
all_vars::n_icellq
integer, dimension(:,:), allocatable, target n_icellq
Definition: mod_main.f90:1216
mod_nctools::is_valid_float_days
logical function is_valid_float_days(VAR, tzone)
Definition: mod_nctools.f90:7099
all_vars::zz1
real(sp), dimension(:,:), allocatable, target zz1
Definition: mod_main.f90:1095
all_vars::qarea
real(sp), dimension(:), allocatable, target qarea
Definition: mod_main.f90:1226
mod_force::fvcom_grid_source
character(len=80), parameter, public fvcom_grid_source
Definition: mod_force.f90:64
mod_force::tide_forcing_comments
character(len=char_max_attlen), dimension(:), allocatable, public tide_forcing_comments
Definition: mod_force.f90:83
bcs::apt_eqi
real(sp), dimension(:), allocatable apt_eqi
Definition: mod_main.f90:1801
all_vars::qevap
real(sp), dimension(:), allocatable, target qevap
Definition: mod_main.f90:1240
mod_force::update_precipitation
subroutine, public update_precipitation(NOW, Qprec, Qevap)
Definition: mod_force.f90:6593
mod_force::winds_forcing_comments
character(len=char_max_attlen), dimension(:), allocatable, public winds_forcing_comments
Definition: mod_force.f90:181
all_vars::dz
real(sp), dimension(:,:), allocatable, target dz
Definition: mod_main.f90:1092
all_vars
Definition: mod_main.f90:959
mod_force::obc_t_comments
character(len=char_max_attlen), public obc_t_comments
Definition: mod_force.f90:139
all_vars::icellq
integer, dimension(:), allocatable, target icellq
Definition: mod_main.f90:1215
mod_force::update_wind
subroutine, public update_wind(NOW, wstrx, wstry)
Definition: mod_force.f90:6449
mod_interp::setup_interp_bilinear_p
subroutine setup_interp_bilinear_p(Xin, Yin, Xout, Yout, WEIGHTS, land_mask)
Definition: mod_interp.f90:676
mod_utils::fatal_error
subroutine fatal_error(ER1, ER2, ER3, ER4)
Definition: mod_utils.f90:230
all_vars::h1
real(sp), dimension(:), allocatable, target h1
Definition: mod_main.f90:1115
all_vars::xc
real(sp), dimension(:), allocatable, target xc
Definition: mod_main.f90:1003
bcs::phai
real(sp), dimension(:,:), allocatable phai
Definition: mod_main.f90:1797
all_vars::dz1
real(sp), dimension(:,:), allocatable, target dz1
Definition: mod_main.f90:1096
all_vars::whs
real(sp), dimension(:), allocatable, target whs
Definition: mod_main.f90:1242
mod_force::ice_forcing_comments
character(len=char_max_attlen), dimension(:), allocatable, public ice_forcing_comments
Definition: mod_force.f90:254
mod_nctools::nc_connect_avar
Definition: mod_nctools.f90:127
mod_ncll::ncdim
Definition: mod_ncll.f90:56
mod_nctools::nc_connect_pvar
Definition: mod_nctools.f90:150
all_vars::isbce
integer, dimension(:), allocatable, target isbce
Definition: mod_main.f90:1027
mod_nctools::get_file_time
Definition: mod_nctools.f90:197
mod_ncll::find_var
Definition: mod_ncll.f90:229
mod_nctools::filehead
type(ncfilelist), pointer, save filehead
Definition: mod_nctools.f90:203
bcs::iobcn_gl
integer iobcn_gl
Definition: mod_main.f90:1775
mod_force::river_forcing_comments
character(len=char_max_attlen), dimension(:), allocatable, public river_forcing_comments
Definition: mod_force.f90:88
mod_force::wrf2fvcom_source
character(len=80), parameter, public wrf2fvcom_source
Definition: mod_force.f90:61
mod_ncll::ncfile
Definition: mod_ncll.f90:153
mod_force::update_rivers
subroutine, public update_rivers(NOW, FLUX, TEMP, SALT, WQM, SED, BIO)
Definition: mod_force.f90:6032
all_vars::nbsn
integer, dimension(:,:), allocatable, target nbsn
Definition: mod_main.f90:1030
mod_ncll::reference_var
type(ncvar) function, pointer reference_var(VARIN)
Definition: mod_ncll.f90:1056
mod_force::update_heat
subroutine, public update_heat(NOW, HEAT_SWV, HEAT_NET)
Definition: mod_force.f90:6330
mod_utils::dbg_io
integer, parameter dbg_io
Definition: mod_utils.f90:66
mod_time::days2time
Definition: mod_time.f90:143
all_vars::tdis
real(sp), dimension(:), allocatable, target tdis
Definition: mod_main.f90:1224
all_vars::vlctyq
real(sp), dimension(:), allocatable, target vlctyq
Definition: mod_main.f90:1229
mod_par::ngid
integer, dimension(:), pointer ngid
Definition: mod_par.f90:61
mod_ncll::find_dim
Definition: mod_ncll.f90:303
mod_utils::dbg_sbr
integer, parameter dbg_sbr
Definition: mod_utils.f90:69
mod_force::waves_forcing_comments
character(len=char_max_attlen), dimension(:), allocatable, public waves_forcing_comments
Definition: mod_force.f90:203
all_vars::inodeq
integer, dimension(:), allocatable, target inodeq
Definition: mod_main.f90:1214
all_vars::isonb
integer, dimension(:), allocatable, target isonb
Definition: mod_main.f90:1024
all_vars::zz
real(sp), dimension(:,:), allocatable, target zz
Definition: mod_main.f90:1091
mod_nctools
Definition: mod_nctools.f90:40
mod_par::egid
integer, dimension(:), pointer egid
Definition: mod_par.f90:60
mod_time::seconds2time
Definition: mod_time.f90:149
mod_force::heat_solar_comments
character(len=char_max_attlen), dimension(:), allocatable, public heat_solar_comments
Definition: mod_force.f90:161
mod_time::print_time
subroutine print_time(mjd, IPT, char)
Definition: mod_time.f90:1166
mod_utils::dbg_log
integer, parameter dbg_log
Definition: mod_utils.f90:65
mod_input
Definition: mod_input.f90:40
all_vars::vxmin
real(sp) vxmin
Definition: mod_main.f90:989
mod_ncll::ncftime
Definition: mod_ncll.f90:132
Generated by   doxygen 1.8.15