!====================================================================== ! Description: ALMA output module ! Sep. 2002 Zhichang Guo ! $Log: drv_output_mod.f90,v $ ! Revision 1.1 2002/09/17 17:12:26 guo ! Initial revision ! !====================================================================== module drv_output_mod use netcdf use drv_writenf_mod use drv_table_mod contains subroutine drv_almagen(x_len, z_len, time_int_f, time_int_m, att_user, title, & iyrbeg, mthbeg, ndybeg, nhrbeg, minbeg, secbeg, & gvarid, ncid_gout, gout_file, gout_num, gout_lat, gout_lon, & fvarid, ncid_fout, fout_file, fout_flag, & mvarid, ncid_mout, mout_file, mout_flag) ! implicit none ! integer, parameter:: max_var = 200 integer, parameter:: max_gph = 200 integer, parameter:: max_rowlen = 120 integer, parameter:: max_collen = 45 integer :: fvarid(max_var) ! I/O populated variable id integer :: mvarid(max_var) ! I/O populated variable id integer :: gvarid(max_var) ! I/O populated variable id integer :: x_len ! IN Length of spatial vector integer :: z_len ! IN Length of spatial vector real :: time_int_f ! IN Length of spatial vector real :: time_int_m ! IN Length of spatial vector character(len=32) :: att_user ! IN Name of creator integer :: ncid_gout ! the netcdf id for gph output integer :: gout_num ! total number of grid points in gph table real :: gout_lat(max_gph) ! OUT true latitude of grid points real :: gout_lon(max_gph) ! OUT true longitude of grid points character(len=128):: gout_file ! IN GPH file name integer :: ncid_fout ! OUT the netcdf id for output variables integer :: ncid_mout ! OUT the netcdf id for output variables logical :: fout_flag(max_var)! OUT output or not for variables logical :: mout_flag(max_var)! OUT output or not for variables character(len=128):: fout_file ! IN file name for output variables character(len=128):: mout_file ! IN file name for output variables character(len=48) :: title ! IN Title of output variable file integer :: iyrbeg integer :: mthbeg integer :: ndybeg integer :: nhrbeg integer :: minbeg integer :: secbeg ! ! Local arguments ! character(len=max_rowlen):: row ! string which stores a row in a table integer :: ioval ! i/o error code integer :: ncid ! netcdf id integer :: iret ! netcdf handling error code integer :: ov_num ! total number of output variables integer :: ov_id ! ID for output variables character(len=max_collen) :: ov_name ! variable name character(len=1) :: ov_mode ! OUT output mode integer :: one_dim, two_dims(2), three_dims(3) integer :: rows_cnt ! counter for rows in a table integer :: x_dim, gp_xdim, ovf_xdim, ovm_xdim integer :: z_dim, gp_zdim, ovf_zdim, ovm_zdim integer :: tstep_dim, gp_tstepdim, ovf_tstepdim, ovm_tstepdim integer :: varid character(len=max_collen) :: gp_name, gp_note integer :: gp_unit ! the unit for reading gph information from a file integer :: ov_type ! total number of output variables integer :: ov_unit ! the unit for reading output variable information from a file real :: time_int ! IN Length of spatial vector real :: ov_range(2), ov_miss integer :: namelen, unitslen, axislen, lnamelen integer :: cols_num, strlen integer :: i, ii, imax character(len=max_collen) :: ov_units, ov_axis, ov_lname character(len=max_collen) :: cols(15) character(len=20) :: beg_origin character(len=10) :: beg_date character(len=8) :: beg_time character(len=35) :: unit_timestep character(len=33) :: unit_time character(len=4) :: a4 character(len=2) :: a2,a2_2,a2_3 character(len=64) :: ovtitle_f, ovtitle_m character(len=20) :: formt logical :: flag ! output or not for variables ! fout_flag = .false. mout_flag = .false. flag = .false. ! ovtitle_f = get_title(title, time_int_f) ovtitle_m = get_title(title, time_int_m) ! write(a4,"(i4)") iyrbeg write(a2,"(i2.2)") mthbeg write(a2_2,"(i2.2)") ndybeg beg_date = a4 // "-" // a2 // "-" // a2_2 write(a2,"(i2.2)") nhrbeg write(a2_2,"(i2.2)") minbeg write(a2_3,"(i2.2)") secbeg beg_time = a2 // ":" // a2_2 // ":" // a2_3 beg_origin = " " // beg_date // " " // beg_time unit_time = "seconds since" // beg_origin unit_timestep = "timesteps since" // beg_origin ! ! read in GPH and output variable information ! ! gph.tbl ! gp_unit = 60 ov_unit = 61 open(gp_unit,file='gph.tbl',form='formatted',status='old') rows_cnt = 0 ioval = 0 cols_num = 5 if(max_rowlen > 0 .and. max_rowlen < 10) then write(formt,'(2h(A,i1,1h))') max_rowlen else if(max_rowlen > 9 .and. max_rowlen < 100) then write(formt,'(2h(A,i2,1h))') max_rowlen else if(max_rowlen > 99 .and. max_rowlen < 1000) then write(formt,'(2h(A,i3,1h))') max_rowlen endif do while (ioval == 0) row = '!' read(gp_unit, fmt=formt, iostat = ioval) row if(row(1:1) /= '!') then rows_cnt = rows_cnt + 1 call tbl_get_columns(row, max_rowlen, max_collen, '|', cols, cols_num) ! gph name call tbl_nblank(1, cols(2), max_collen, strlen) gp_name = cols(2)(1:strlen) ! gph latitude call tbl_nblank(2, cols(3), max_collen, strlen) gout_lat(rows_cnt) = tbl_c2f(cols(3), max_collen, strlen-1) if(cols(3)(strlen:strlen) == 'S' .or. cols(3)(strlen:strlen) == 's') then gout_lat(rows_cnt) = -gout_lat(rows_cnt) else if(cols(3)(strlen:strlen) /= 'N' .and. cols(3)(strlen:strlen) == 'n') then print*, 'S/N is not correctly set in GPH for ', gp_name stop endif ! gph longitude call tbl_nblank(2, cols(4), max_collen, strlen) gout_lon(rows_cnt) = tbl_c2f(cols(4), max_collen, strlen-1) if(cols(4)(strlen:strlen) == 'W' .or. cols(4)(strlen:strlen) == 'w') then gout_lon(rows_cnt) = -gout_lon(rows_cnt) else if(cols(4)(strlen:strlen) /= 'E' .and. cols(4)(strlen:strlen) == 'e') then print*, 'W/E is not correctly set in GPH for ', gp_name stop endif ! gph notes call tbl_nblank(1, cols(5), max_collen, strlen) gp_note = cols(5)(1:strlen) endif enddo gout_num = rows_cnt close(gp_unit) ! ! enter define mode ! if(gout_num > 0) then iret = NF90_CREATE(gout_file, NF90_CLOBBER, ncid_gout) call check_err(iret) iret = NF90_DEF_DIM(ncid_gout, 'x', gout_num, gp_xdim) call check_err(iret) iret = NF90_DEF_DIM(ncid_gout, 'z', z_len, gp_zdim) call check_err(iret) iret = NF90_DEF_DIM(ncid_gout, 'tstep', NF90_UNLIMITED, gp_tstepdim) call check_err(iret) endif iret = NF90_CREATE(fout_file, NF90_CLOBBER, ncid_fout) call check_err(iret) iret = NF90_DEF_DIM(ncid_fout, 'x', x_len, ovf_xdim) call check_err(iret) iret = NF90_DEF_DIM(ncid_fout, 'z', z_len, ovf_zdim) call check_err(iret) iret = NF90_DEF_DIM(ncid_fout, 'tstep', NF90_UNLIMITED, ovf_tstepdim) call check_err(iret) iret = NF90_CREATE(mout_file, NF90_CLOBBER, ncid_mout) call check_err(iret) iret = NF90_DEF_DIM(ncid_mout, 'x', x_len, ovm_xdim) call check_err(iret) iret = NF90_DEF_DIM(ncid_mout, 'z', z_len, ovm_zdim) call check_err(iret) iret = NF90_DEF_DIM(ncid_mout, 'tstep', NF90_UNLIMITED, ovm_tstepdim) call check_err(iret) ! ! outvar.tbl ! open(ov_unit,file='outvar.tbl',form='formatted',status='old') rows_cnt = 0 ioval = 0 cols_num = 10 do while (ioval == 0) row = '!' read(ov_unit, fmt=formt, iostat = ioval) row if(row(1:1) /= '!') then rows_cnt = rows_cnt + 1 call tbl_get_columns(row, max_rowlen, max_collen, '|', cols, cols_num) ! name call tbl_nblank(1, cols(2), max_collen, strlen) namelen = strlen if(strlen > 0) ov_name = cols(2)(1:strlen) ! type call tbl_nblank(1, cols(3), max_collen, strlen) if(strlen > 0) then if(cols(3)(1:strlen) == 'REAL' .or. cols(3)(1:strlen) == 'real') then ov_type = NF90_FLOAT else if(cols(3)(1:strlen) == 'INT' .or. cols(3)(1:strlen) == 'int') then ov_type = NF90_INT else print*, 'Invalid data type for the variable ', ov_name(1:namelen) endif endif ! range call tbl_nblank(2, cols(4), max_collen, strlen) if(strlen > 0) ov_range(1) = tbl_c2f(cols(4), max_collen, strlen) call tbl_nblank(2, cols(5), max_collen, strlen) if(strlen > 0) ov_range(2) = tbl_c2f(cols(5), max_collen, strlen) ! units call tbl_nblank(1, cols(6), max_collen, strlen) unitslen = strlen if(strlen > 0) ov_units = cols(6)(1:strlen) ! missing value call tbl_nblank(2, cols(7), max_collen, strlen) if(strlen > 0) ov_miss = tbl_c2f(cols(7), max_collen, strlen) ! axis call tbl_nblank(1, cols(8), max_collen, strlen) axislen = strlen if(strlen > 0) ov_axis = cols(8)(1:strlen) ! long name call tbl_nblank(1, cols(9), max_collen, strlen) lnamelen = strlen if(strlen > 0) ov_lname = cols(9)(1:strlen) ! write mode call tbl_nblank(2, cols(10), max_collen, strlen) ov_mode = cols(10)(1:1) ! id ov_id = drv_get_namelist(ov_name, namelen, ov_mode) ! define variables imax = 2 if(gout_num > 0) imax = 3 do ii = 1,imax if(ii == 1) then if(ov_mode == 'F' .or. ov_mode == 'f') then fout_flag(ov_id) = .true. flag = fout_flag(ov_id) else flag = .false. endif ncid = ncid_fout tstep_dim = ovf_tstepdim z_dim = ovf_zdim x_dim = ovf_xdim time_int = time_int_f else if(ii == 2) then if(ov_mode == 'M' .or. ov_mode == 'm') then mout_flag(ov_id) = .true. flag = mout_flag(ov_id) else flag = .false. endif ncid = ncid_mout tstep_dim = ovm_tstepdim z_dim = ovm_zdim x_dim = ovm_xdim flag = mout_flag(ov_id) time_int = time_int_m else if(ii == 3) then if(ov_mode == 'F' .or. ov_mode == 'f') then flag = .true. else flag = .false. endif ncid = ncid_gout tstep_dim = gp_tstepdim z_dim = gp_zdim x_dim = gp_xdim time_int = time_int_f endif if(flag) then if(ov_axis(1:axislen) == 'T' .or. ov_axis(1:axislen) == 't') then one_dim = tstep_dim iret = NF90_DEF_VAR(ncid, ov_name(1:namelen), ov_type, one_dim, varid) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'long_name', ov_lname(1:lnamelen)) call check_err(iret) if( ov_name(1:namelen) == 'time') then iret = NF90_PUT_ATT(ncid, varid, 'units', unit_time) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'calendar', 'gregorian') call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'title', 'Time') call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'time_origin',beg_origin) call check_err(iret) else if( ov_name(1:namelen) == 'timestep') then iret = NF90_PUT_ATT(ncid, varid, 'units', unit_timestep) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'title', 'Time steps') call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'title', 'Time steps') call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'tstep_sec', time_int) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'time_origin', beg_origin) call check_err(iret) endif else if(ov_axis(1:axislen) == 'X' .or. ov_axis(1:axislen) == 'x') then one_dim = x_dim iret = NF90_DEF_VAR(ncid, ov_name(1:namelen), ov_type, one_dim, varid) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'valid_range', ov_range) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'units', ov_units(1:unitslen)) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'long_name', ov_lname(1:lnamelen)) call check_err(iret) else if(ov_axis(1:axislen) == 'Z' .or. ov_axis(1:axislen) == 'z') then one_dim = z_dim iret = NF90_DEF_VAR(ncid, ov_name(1:namelen), ov_type, one_dim, varid) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'valid_range', ov_range) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'units', ov_units(1:unitslen)) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'long_name', ov_lname(1:lnamelen)) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'orientation', 'index increases download') call check_err(iret) else if(ov_axis(1:axislen) == 'TX' .or. ov_axis(1:axislen) == 'tx') then two_dims(2) = tstep_dim two_dims(1) = x_dim iret = NF90_DEF_VAR(ncid, ov_name(1:namelen), ov_type, two_dims, varid) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'valid_range', ov_range) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'axis', ov_axis(1:axislen)) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'units', ov_units(1:unitslen)) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'long_name', ov_lname(1:lnamelen)) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'associate', 'time x') call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'missing_value', ov_miss) call check_err(iret) else if(ov_axis(1:axislen) == 'TZX' .or. ov_axis(1:axislen) == 'tzx') then three_dims(3) = tstep_dim three_dims(2) = z_dim three_dims(1) = x_dim iret = NF90_DEF_VAR(ncid, ov_name(1:namelen), ov_type, three_dims, varid) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'valid_range', ov_range) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'axis', ov_axis(1:axislen)) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'units', ov_units(1:unitslen)) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'long_name', ov_lname(1:lnamelen)) call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'associate', 'time z x') call check_err(iret) iret = NF90_PUT_ATT(ncid, varid, 'missing_value', ov_miss) call check_err(iret) else stop 'Does not work for other dimensions, modification is needed' endif if(ii == 1) then fvarid(ov_id) = varid else if(ii == 2) then mvarid(ov_id) = varid else if(ii == 3) then gvarid(ov_id) = varid endif endif enddo endif enddo ov_num = rows_cnt close(ov_unit) if(gout_num > 0) then iret = NF90_PUT_ATT(ncid_gout, NF90_GLOBAL, 'Conventions', 'GDT 1.2') call check_err(iret) iret = NF90_PUT_ATT(ncid_gout, NF90_GLOBAL, 'file_name', gout_file) call check_err(iret) iret = NF90_PUT_ATT(ncid_gout, NF90_GLOBAL, 'CreatedBy', att_user) call check_err(iret) iret = NF90_PUT_ATT(ncid_gout, NF90_GLOBAL, 'SurfSgn_convention','Traditional') call check_err(iret) iret = NF90_PUT_ATT(ncid_gout, NF90_GLOBAL, 'title', ovtitle_f) call check_err(iret) iret = NF90_ENDDEF(ncid_gout) call check_err(iret) endif ! iret = NF90_PUT_ATT(ncid_fout, NF90_GLOBAL, 'Conventions', 'GDT 1.2') call check_err(iret) iret = NF90_PUT_ATT(ncid_fout, NF90_GLOBAL, 'file_name', fout_file) call check_err(iret) iret = NF90_PUT_ATT(ncid_fout, NF90_GLOBAL, 'CreatedBy', att_user) call check_err(iret) iret = NF90_PUT_ATT(ncid_fout, NF90_GLOBAL, 'SurfSgn_convention','Traditional') call check_err(iret) iret = NF90_PUT_ATT(ncid_fout, NF90_GLOBAL, 'title', ovtitle_f) call check_err(iret) iret = NF90_ENDDEF(ncid_fout) call check_err(iret) ! iret = NF90_PUT_ATT(ncid_mout, NF90_GLOBAL, 'Conventions', 'GDT 1.2') call check_err(iret) iret = NF90_PUT_ATT(ncid_mout, NF90_GLOBAL, 'file_name', mout_file) call check_err(iret) iret = NF90_PUT_ATT(ncid_mout, NF90_GLOBAL, 'CreatedBy', att_user) call check_err(iret) iret = NF90_PUT_ATT(ncid_mout, NF90_GLOBAL, 'SurfSgn_convention','Traditional') call check_err(iret) iret = NF90_PUT_ATT(ncid_mout, NF90_GLOBAL, 'title', ovtitle_m) call check_err(iret) iret = NF90_ENDDEF(ncid_mout) call check_err(iret) end subroutine drv_almagen !--------------------------------------------------------------------- subroutine drv_almaout(flag, record, tmstep) ! use drv_dat_mod implicit none ! ! Purpose: Output model results at prescribed time interval. ! integer, parameter :: max_var = 200 integer, intent(in) :: record,tmstep character(len=1 ) :: flag ! IN output mode ! integer :: ov_ncid integer,dimension(200) :: ovarid ! Variable id vector for NetCDF outputs logical :: ov_flag(max_var), gp_flag character(len=10) :: c10 character(len=8 ) :: c8 integer :: i, ip, iv real :: secs real, allocatable :: tmpVar(:) real, allocatable :: tmpVar2d(:,:) WRITE(c10,1060) nymdh 1060 FORMAT(i10.10) c8 = c10(3:10) write(6,*) 'Writing ALMA output at FORCING time interval ',c10 write(*,*) 'Writing ALMA output at FORCING time interval ',c10 ! ! Means over the forcing interval for all (ip) elements of vector ! if(flag == 'F') then ov_flag = fout_flag ov_ncid = ncid_fout ovarid = fvarid gp_flag = .true. A_SWdown = A_SWdown / float(madtt) A_LWdown = A_LWdown / float(madtt) A_RainfF = A_RainfF / float(madtt) A_SnowfF = A_SnowfF / float(madtt) A_Wind = A_Wind / float(madtt) A_Tair = A_Tair / float(madtt) A_Qair = A_Qair / float(madtt) A_Psurf = A_Psurf / float(madtt) A_SWnet = A_SWnet / float(madtt) A_LWnet = A_LWnet / float(madtt) A_Qle = A_Qle / float(madtt) A_Qh = A_Qh / float(madtt) A_Qg = A_Qg / float(madtt) A_Qf = A_Qf / float(madtt) A_Qv = A_Qv / float(madtt) A_Qa = A_Qa / float(madtt) A_SnowT = A_SnowT A_VegT = A_VegT A_BareSoilT = A_BareSoilT A_AvgSurfT = A_AvgSurfT A_RadT = A_RadT ! Open the straight GrADS output file for this time interval ! OPEN (42,FILE=droot//'/alma/grid/ALMA_F'//c8//'.grd', & ! FORM='UNFORMATTED',RECORDTYPE='STREAM', & ! CONVERT='BIG_ENDIAN',STATUS='UNKNOWN') else if(flag == 'M') then ov_flag = mout_flag ov_ncid = ncid_mout ovarid = mvarid gp_flag = .false. A_Rainf = A_Rainf / float(idein*madtt) A_Snowf = A_Snowf / float(idein*madtt) A_Evap = A_Evap / float(idein*madtt) A_Qs = A_Qs / float(idein*madtt) A_Qsb = A_Qsb / float(idein*madtt) A_Qsm = A_Qsm / float(idein*madtt) A_Qfz = A_Qfz / float(idein*madtt) A_Qst = A_Qst / float(idein*madtt) A_Albedo = A_Albedo / A_Alb_SWdown A_PotEvap = A_PotEvap / float(idein*madtt) A_ECanop = A_ECanop / float(idein*madtt) A_TVeg = A_TVeg / float(idein*madtt) A_ESoil = A_ESoil / float(idein*madtt) A_EWater = A_EWater / float(idein*madtt) A_EvapSnow= A_EvapSnow/ float(idein*madtt) A_SubSnow = A_SubSnow / float(idein*madtt) A_SubSurf = A_SubSurf / float(idein*madtt) ! Open the straight GrADS output file for this time interval ! OPEN (43,FILE=droot//'/alma/grid/ALMA_M'//c8//'.grd', & ! FORM='UNFORMATTED',RECORDTYPE='STREAM', & ! CONVERT='BIG_ENDIAN',STATUS='UNKNOWN') endif ! ! Write out the fields ! secs = seconds if(gout_num > 0 .and. gp_flag) then ALLOCATE(tmpVar(gout_num)) ALLOCATE(tmpVar2d(gout_num,idp)) endif ! if(ov_flag(120)) then CALL drv_writetime(ov_ncid, record, ovarid(120), secs) if(gout_num > 0 .and. gp_flag) CALL drv_writetime(ncid_gout, record, gvarid(120), secs) endif if(ov_flag(121)) then CALL drv_writetime(ov_ncid, record, ovarid(121), tmstep) if(gout_num > 0 .and. gp_flag) CALL drv_writetime(ncid_gout, record, gvarid(121), tmstep) endif if(flag == 'F') CALL drv_datout(42,A_SWdown) if(flag == 'F') CALL drv_datout(42,A_LWdown) if(flag == 'F') CALL drv_datout(42,A_RainfF) if(ov_flag(111)) then CALL drv_writenf2(ov_ncid,ovarid(111),record,A_RainfF,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_RainfF, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(111),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_SnowfF) if(ov_flag(112)) then CALL drv_writenf2(ov_ncid,ovarid(112),record,A_SnowfF,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SnowfF, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(112),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_Wind ) if(flag == 'F') CALL drv_datout(42,A_Tair ) if(flag == 'F') CALL drv_datout(42,A_Qair ) if(flag == 'F') CALL drv_datout(42,A_Psurf ) !ALMA O.1 if(flag == 'F') CALL drv_datout(42,A_SWnet) if(ov_flag(1)) then CALL drv_writenf2(ov_ncid,ovarid(1),record,A_SWnet,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SWnet, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(1),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_LWnet) if(ov_flag(2)) then CALL drv_writenf2(ov_ncid,ovarid(2),record,A_LWnet,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_LWnet, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(2),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_Qle) if(ov_flag(3)) then CALL drv_writenf2(ov_ncid,ovarid(3),record,A_Qle,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qle, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(3),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_Qh) if(ov_flag(4)) then CALL drv_writenf2(ov_ncid,ovarid(4),record,A_Qh,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qh, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(4),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_Qg) if(ov_flag(5)) then CALL drv_writenf2(ov_ncid,ovarid(5),record,A_Qg,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qg, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(5),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_Qf) if(ov_flag(6)) then CALL drv_writenf2(ov_ncid,ovarid(6),record,A_Qf,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qf, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(6),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_Qv) if(ov_flag(7)) then CALL drv_writenf2(ov_ncid,ovarid(7),record,A_Qv,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qv, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(7),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_Qa) if(ov_flag(8)) then CALL drv_writenf2(ov_ncid,ovarid(8),record,A_Qa,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qa, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(8),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_DelSurfHeat) if(ov_flag(9)) then CALL drv_writenf2(ov_ncid,ovarid(9),record,A_DelSurfHeat,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_DelSurfHeat, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(9),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_DelColdCont) if(ov_flag(10)) then CALL drv_writenf2(ov_ncid,ovarid(10),record,A_DelColdCont,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_DelColdCont, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(10),record,tmpVar,gout_num) endif endif !ALMA O.2 if(flag == 'M') CALL drv_datout(43,A_Snowf ) if(ov_flag(11)) then CALL drv_writenf2(ov_ncid,ovarid(11),record,A_Snowf,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Snowf, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(11),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_Rainf ) if(ov_flag(12)) then CALL drv_writenf2(ov_ncid,ovarid(12),record,A_Rainf,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Rainf, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(12),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_Evap ) if(ov_flag(13)) then CALL drv_writenf2(ov_ncid,ovarid(13),record,A_Evap,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Evap, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(13),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_Qs ) if(ov_flag(14)) then CALL drv_writenf2(ov_ncid,ovarid(14),record,A_Qs,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qs, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(14),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_Qsb ) if(ov_flag(15)) then CALL drv_writenf2(ov_ncid,ovarid(15),record,A_Qsb,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qsb, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(15),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_Qsm ) if(ov_flag(16)) then CALL drv_writenf2(ov_ncid,ovarid(16),record,A_Qsm,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qsm, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(16),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_Qfz ) if(ov_flag(17)) then CALL drv_writenf2(ov_ncid,ovarid(17),record,A_Qfz,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qfz, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(17),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_Qst ) if(ov_flag(18)) then CALL drv_writenf2(ov_ncid,ovarid(18),record,A_Qst,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Qst, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(18),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_DelSoilMoist) if(ov_flag(19)) then CALL drv_writenf2(ov_ncid,ovarid(19),record,A_DelSoilMoist,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_DelSoilMoist, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(19),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_DelSWE) if(ov_flag(20)) then CALL drv_writenf2(ov_ncid,ovarid(20),record,A_DelSWE,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_DelSWE, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(20),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_DelSurfStor) if(ov_flag(21)) then CALL drv_writenf2(ov_ncid,ovarid(21),record,A_DelSurfStor,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_DelSurfStor, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(21),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_DelIntercept) if(ov_flag(22)) then CALL drv_writenf2(ov_ncid,ovarid(22),record,A_DelIntercept,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_DelIntercept, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(22),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_SnowT) if(ov_flag(23)) then CALL drv_writenf2(ov_ncid,ovarid(23),record,A_SnowT,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SnowT, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(23),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_VegT) if(ov_flag(24)) then CALL drv_writenf2(ov_ncid,ovarid(24),record,A_VegT,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_VegT, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(24),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_BareSoilT) if(ov_flag(25)) then CALL drv_writenf2(ov_ncid,ovarid(25),record,A_BareSoilT,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_BareSoilT, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(25),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_AvgSurfT) if(ov_flag(26)) then CALL drv_writenf2(ov_ncid,ovarid(26),record,A_AvgSurfT,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_AvgSurfT, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(26),record,tmpVar,gout_num) endif endif if(flag == 'F') CALL drv_datout(42,A_RadT) if(ov_flag(27)) then CALL drv_writenf2(ov_ncid,ovarid(27),record,A_RadT,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_RadT, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(27),record,tmpVar,gout_num) endif endif !ALMA O.3 if(flag == 'M') CALL drv_datout(43,A_Albedo) if(ov_flag(28)) then CALL drv_writenf2(ov_ncid,ovarid(28),record,A_Albedo,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Albedo, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(28),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_SWE ) if(ov_flag(29)) then CALL drv_writenf2(ov_ncid,ovarid(29),record,A_SWE,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SWE, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(29),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_SurfStor) if(ov_flag(30)) then CALL drv_writenf2(ov_ncid,ovarid(30),record,A_SurfStor,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SurfStor, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(30),record,tmpVar,gout_num) endif endif !ALMA O.4 do i=1,idp if(flag == 'M') CALL drv_datout(43,A_SoilMoist(1,i)) enddo if(ov_flag(31)) then CALL drv_writenf3(ov_ncid,ovarid(31),record,A_SoilMoist,lpnts,idp) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar2d(lpnts, idp, A_SoilMoist, gout_num, tmpVar2d, gout_index) CALL drv_writenf3(ncid_gout,gvarid(31),record,tmpVar2d,gout_num,idp) endif endif do i=1,idp if(flag == 'M') CALL drv_datout(43,A_SMLiqFrac(1,i)) enddo if(ov_flag(32)) then CALL drv_writenf3(ov_ncid,ovarid(32),record,A_SMLiqFrac,lpnts,idp) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar2d(lpnts, idp, A_SMLiqFrac, gout_num, tmpVar2d, gout_index) CALL drv_writenf3(ncid_gout,gvarid(32),record,tmpVar2d,gout_num,idp) endif endif do i=1,idp if(flag == 'M') CALL drv_datout(43,A_SMFrozFrac(1,i)) enddo if(ov_flag(33)) then CALL drv_writenf3(ov_ncid,ovarid(33),record,A_SMFrozFrac,lpnts,idp) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar2d(lpnts, idp, A_SMFrozFrac, gout_num, tmpVar2d, gout_index) CALL drv_writenf3(ncid_gout,gvarid(33),record,tmpVar2d,gout_num,idp) endif endif if(flag == 'M') CALL drv_datout(43,A_SoilWet) if(ov_flag(34)) then CALL drv_writenf2(ov_ncid,ovarid(34),record,A_SoilWet,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SoilWet, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(34),record,tmpVar,gout_num) endif endif do i=1,idp if(flag == 'M') CALL drv_datout(43,A_SoilTemp (1,i)) enddo if(ov_flag(35)) then CALL drv_writenf3(ov_ncid,ovarid(35),record,A_SoilTemp,lpnts,idp) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar2d(lpnts, idp, A_SoilTemp, gout_num, tmpVar2d, gout_index) CALL drv_writenf3(ncid_gout,gvarid(35),record,tmpVar2d,gout_num,idp) endif endif !ALMA O.5 if(flag == 'M') CALL drv_datout(43,A_PotEvap) if(ov_flag(36)) then CALL drv_writenf2(ov_ncid,ovarid(36),record,A_PotEvap,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_PotEvap, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(36),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_ECanop) if(ov_flag(37)) then CALL drv_writenf2(ov_ncid,ovarid(37),record,A_ECanop,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_ECanop, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(37),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_TVeg ) if(ov_flag(38)) then CALL drv_writenf2(ov_ncid,ovarid(38),record,A_TVeg,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_TVeg, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(38),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_ESoil ) if(ov_flag(39)) then CALL drv_writenf2(ov_ncid,ovarid(39),record,A_ESoil,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_ESoil, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(39),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_EWater) if(ov_flag(40)) then CALL drv_writenf2(ov_ncid,ovarid(40),record,A_EWater,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_EWater, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(40),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_RootMoist) if(ov_flag(41)) then CALL drv_writenf2(ov_ncid,ovarid(41),record,A_RootMoist,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_RootMoist, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(41),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_CanopInt) !nf not in the list CALL drv_writenf2(ncid_gout,ovarid(??),record,A_CanopInt,lpnts) if(flag == 'M') CALL drv_datout(43,A_SubSnow) if(ov_flag(42)) then CALL drv_writenf2(ov_ncid,ovarid(42),record,A_SubSnow,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SubSnow, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(42),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_EvapSnow) if(ov_flag(43)) then CALL drv_writenf2(ov_ncid,ovarid(43),record,A_EvapSnow,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_EvapSnow, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(43),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_SubSurf) if(ov_flag(44)) then CALL drv_writenf2(ov_ncid,ovarid(44),record,A_SubSurf,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SubSurf, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(44),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_ACond) if(ov_flag(45)) then CALL drv_writenf2(ov_ncid,ovarid(45),record,A_ACond,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_ACond, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(45),record,tmpVar,gout_num) endif endif !ALMA O.7 if(flag == 'M') CALL drv_datout(43,A_SnowFrac) if(ov_flag(46)) then CALL drv_writenf2(ov_ncid,ovarid(46),record,A_SnowFrac,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SnowFrac, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(46),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_SAlbedo) if(ov_flag(51)) then CALL drv_writenf2(ov_ncid,ovarid(51),record,A_Salbedo,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SAlbedo, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(51),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_SnowTProf) if(ov_flag(52)) then CALL drv_writenf2(ov_ncid,ovarid(52),record,A_SnowTProf,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SnowTProf, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(52),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_SnowDepth) if(ov_flag(53)) then CALL drv_writenf2(ov_ncid,ovarid(53),record,A_SnowDepth,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SnowDepth, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(53),record,tmpVar,gout_num) endif endif if(flag == 'M') CALL drv_datout(43,A_SliqFrac) if(ov_flag(54)) then CALL drv_writenf2(ov_ncid,ovarid(54),record,A_SliqFrac,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_SliqFrac, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(54),record,tmpVar,gout_num) endif endif if(ov_flag(47)) then CALL drv_writenf2(ov_ncid,ovarid(47),record,A_Missing,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Missing, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(47),record,tmpVar,gout_num) endif endif if(ov_flag(48)) then CALL drv_writenf2(ov_ncid,ovarid(48),record,A_Missing,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Missing, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(48),record,tmpVar,gout_num) endif endif if(ov_flag(49)) then CALL drv_writenf2(ov_ncid,ovarid(49),record,A_Missing,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Missing, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(49),record,tmpVar,gout_num) endif endif if(ov_flag(50)) then CALL drv_writenf2(ov_ncid,ovarid(50),record,A_Missing,lpnts) if(gout_num > 0 .and. gp_flag) then CALL drv_extvar(lpnts, A_Missing, gout_num, tmpVar, gout_index) CALL drv_writenf2(ncid_gout,gvarid(50),record,tmpVar,gout_num) endif endif ! ! Zero out the ALMA accumulators for all (ip) elements of vector ! if(flag == 'F') then A_SWdown = 0.0 A_LWdown = 0.0 A_RainfF = 0.0 A_SnowfF = 0.0 A_Wind = 0.0 A_Tair = 0.0 A_Qair = 0.0 A_Psurf = 0.0 A_SWnet = 0.0 A_LWnet = 0.0 A_Qle = 0.0 A_Qh = 0.0 A_Qg = 0.0 A_Qf = 0.0 A_Qv = 0.0 A_Qa = 0.0 A_DelSurfHeat = 0.0 A_DelColdCont = 0.0 A_SnowT = 0.0 A_VegT = 0.0 A_BareSoilT = 0.0 A_AvgSurfT = 0.0 A_RadT = 0.0 else if(flag == 'M') then !ALMA O.2 A_Evap = 0.0 A_Qs = 0.0 A_Qsb = 0.0 A_Qsm = 0.0 A_Qfz = 0.0 A_Qst = 0.0 A_DelSoilMoist = 0.0 A_DelSWE = 0.0 A_DelSurfStor = 0.0 A_DelIntercept = 0.0 !ALMA O.3 A_Albedo = 0.0 A_SWE = 0.0 A_SurfStor = 0.0 !ALMA O.4 A_SoilMoist = 0.0 A_SoilTemp = 0.0 A_SMLiqFrac = 0.0 A_SMFrozFrac= 0.0 A_SoilWet = 0.0 !ALMA O.5 A_PotEvap = 0.0 A_ECanop = 0.0 A_TVeg = 0.0 A_Esoil = 0.0 A_Ewater = 0.0 A_RootMoist = 0.0 A_CanopInt = 0.0 A_EvapSnow = 0.0 A_SubSnow = 0.0 A_SubSurf = 0.0 A_ACond = 0.0 !ALMA O.7 A_SnowFrac = 0.0 A_SAlbedo = 0.0 A_SnowTProf = 0.0 A_SnowDepth = 0.0 A_SliqFrac = 0.0 endif ! CLOSE(42) ! CLOSE(43) if(gout_num > 0 .and. gp_flag) then DEALLOCATE(tmpVar) DEALLOCATE(tmpVar2d) endif end subroutine drv_almaout !--------------------------------------------------------------------- subroutine drv_outinvar use drv_dat_mod implicit none real,allocatable :: lon(:), lat(:) integer :: i ! if(gout_num > 0) then allocate(lon(gout_num)) allocate(lat(gout_num)) do i = 1,gout_num gout_index(i) = get_index(lpnts, glon, glat, gout_lon(i), gout_lat(i)) lon(i) = glon(gout_index(i)) lat(i) = glat(gout_index(i)) enddo if(fout_flag(122)) then call drv_writenf1(ncid_gout, gvarid(122), lon, gout_num) endif if(fout_flag(123)) then call drv_writenf1(ncid_gout, gvarid(123), lat, gout_num) endif if(fout_flag(124)) then call drv_writenf1(ncid_gout, gvarid(124), glev, idp) endif deallocate(lon) deallocate(lat) endif if(fout_flag(122)) then call drv_writenf1(ncid_fout, fvarid(122), glon, lpnts) endif if(fout_flag(123)) then call drv_writenf1(ncid_fout, fvarid(123), glat, lpnts) endif if(mout_flag(122)) then call drv_writenf1(ncid_mout, mvarid(122), glon, lpnts) endif if(mout_flag(123)) then call drv_writenf1(ncid_mout, mvarid(123), glat, lpnts) endif if(mout_flag(124)) then call drv_writenf1(ncid_mout, mvarid(124), glev, idp) endif end subroutine drv_outinvar !--------------------------------------------------------------------- subroutine drv_almaclose(ncid) ! ! Purpose: Close opened NetCDF files ! P. Dirmeyer 8/2001 ! USE netcdf IMPLICIT NONE ! INTEGER :: ncid, iret ! iret = NF90_CLOSE(ncid) IF (iret .NE. NF90_NOERR ) THEN WRITE (6,*) ' Could not properly close NetCDF file ',ncid STOP 'drv_almaclose' ENDIF ! END SUBROUTINE drv_almaclose !--------------------------------------------------------------------- subroutine drv_extvar(x_len, Var, gp_len, tmpVar, gout_index) ! ! Purpose: extract 1-D data for GPH with their index ! Zhichang Guo 9/2002 implicit none integer :: x_len ! IN Length of spatial vector integer :: gp_len ! IN Length of spatial vector integer :: gout_index(gp_len) real :: Var(x_len) real :: tmpVar(gp_len) ! integer :: i do i = 1,gp_len tmpVar(i) = Var(gout_index(i)) enddo end subroutine drv_extvar !--------------------------------------------------------------------- subroutine drv_extvar2d(x_len, z_len, Var, gp_len, tmpVar, gout_index) ! ! Purpose: extract 2-D data for GPH with their index ! Zhichang Guo 9/2002 implicit none integer :: x_len ! IN Length of spatial vector integer :: z_len ! IN Length of spatial vector integer :: gp_len ! IN Length of spatial vector integer :: gout_index(gp_len) real :: Var(x_len, z_len) real :: tmpVar(gp_len, z_len) ! integer :: i, k do k = 1,z_len do i = 1,gp_len tmpVar(i,k) = Var(gout_index(i),k) enddo enddo end subroutine drv_extvar2d !--------------------------------------------------------------------- function get_index(x_len, glon, glat, lon, lat) ! ! Purpose: Find the nearest grid point for compaign sites, and return ! the index in the vectors ! Zhichang Guo 9/2002 implicit none integer :: x_len real :: glon(x_len), glat(x_len) real :: lon, lat integer :: get_index ! real :: dist, min_dist integer :: i, k ! get_index = 0 ! The initial minimum square distance is 2 * 10 deg * 10 deg min_dist = 200 do i = 1, x_len dist = (lon - glon(i))*(lon - glon(i)) + (lat - glat(i))*(lat - glat(i)) if(dist < min_dist) then min_dist = dist get_index = i endif ! If the square distance is less than 2 * 0.5 deg * 0.5 deg, return if(dist < 1) return enddo end function get_index function get_title(title_in, time_int) ! ! Purpose: Construct metadata for GSWP2 ! Dirmeyer 8/2001 character(len=48) :: title_in ! IN Title of output variable file character(len=64) :: get_title real :: time_int ! character(len=4) :: a4 character(len=2) :: a2 integer :: i !c>>> Construct metadata IF (time_int < 0.) THEN i = -int(time_int) IF (i == 1) THEN write(a2,"(i2)") i get_title = "Monthly output for " // title_in ELSE get_title = a2 // "-times per month output for " // title_in ENDIF ELSEIF (time_int < 3600.) THEN IF (MOD(time_int,60.) == 0) THEN i = int(time_int/60.) write(a2,"(i2)") i get_title = a2 // "-minute output for " // title_in ELSE i = int(time_int) write(a4,"(i4)") i get_title = a4 // "-second output for " // title_in ENDIF ELSEIF (time_int < 86400.) THEN IF (MOD(time_int,3600.) == 0) THEN i = int(time_int/3600.) write(a2,"(i2)") i get_title = a2 // "-hourly output for " // title_in ELSE i = int(time_int/60.) write(a4,"(i4)") i get_title = a4 // "-minute output for " // title_in ENDIF ELSE IF (time_int == 86400.) THEN get_title = "Daily output for " // title_in ELSEIF (time_int == 432000.) THEN get_title = "Pentad output for " // title_in ELSEIF (time_int == 864000.) THEN get_title = "Decad output for " // title_in ELSEIF (MOD(time_int,86400.) == 0) THEN i = int(time_int/3600.) write(a2,"(i2)") i get_title = a2 // "-daily output for " // title_in ELSE i = int(time_int/24.) write(a4,"(i4)") i get_title = a4 // "-hourly output for " // title_in ENDIF ENDIF end function get_title FUNCTION drv_get_namelist(varname, namelen, mode) IMPLICIT NONE INTEGER :: drv_get_namelist INTEGER :: namelen CHARACTER(LEN=1) :: mode CHARACTER(LEN=45) :: varname CHARACTER(LEN=20) :: varname_list(200) CHARACTER(LEN=1) :: varmode_list(200) CHARACTER(LEN=20) :: vname INTEGER :: i ! varname_list = ' ' varmode_list = ' ' ! varname_list(1) = 'SWnet' varmode_list(1) = 'F' varname_list(2) = 'LWnet' varmode_list(2) = 'F' varname_list(3) = 'Qle' varmode_list(3) = 'F' varname_list(4) = 'Qh' varmode_list(4) = 'F' varname_list(5) = 'Qg' varmode_list(5) = 'F' varname_list(6) = 'Qf' varmode_list(6) = 'F' varname_list(7) = 'Qv' varmode_list(7) = 'F' varname_list(8) = 'Qa' varmode_list(8) = 'F' varname_list(9) = 'DelSurfHeat' varmode_list(9) = 'F' varname_list(10) = 'DelColdCont' varmode_list(10) = 'F' varname_list(11) = 'Snowf' varmode_list(11) = 'M' varname_list(12) = 'Rainf' varmode_list(12) = 'M' varname_list(13) = 'Evap' varmode_list(13) = 'M' varname_list(14) = 'Qs' varmode_list(14) = 'M' varname_list(15) = 'Qsb' varmode_list(15) = 'M' varname_list(16) = 'Qsm' varmode_list(16) = 'M' varname_list(17) = 'Qfz' varmode_list(17) = 'M' varname_list(18) = 'Qst' varmode_list(18) = 'M' varname_list(19) = 'DelSoilMoist' varmode_list(19) = 'M' varname_list(20) = 'DelSWE' varmode_list(20) = 'M' varname_list(21) = 'DelSurfStor' varmode_list(21) = 'M' varname_list(22) = 'DelIntercept' varmode_list(22) = 'M' varname_list(23) = 'SnowT' varmode_list(23) = 'F' varname_list(24) = 'VegT' varmode_list(24) = 'F' varname_list(25) = 'BareSoilT' varmode_list(25) = 'F' varname_list(26) = 'AvgSurfT' varmode_list(26) = 'F' varname_list(27) = 'RadT' varmode_list(27) = 'F' varname_list(28) = 'Albedo' varmode_list(28) = 'M' varname_list(29) = 'SWE' varmode_list(29) = 'M' varname_list(30) = 'SurfStor' varmode_list(30) = 'M' varname_list(31) = 'SoilMoist' varmode_list(31) = 'M' varname_list(32) = 'SMLiqFrac' varmode_list(32) = 'M' varname_list(33) = 'SMFrozFrac' varmode_list(33) = 'M' varname_list(34) = 'SoilWet' varmode_list(34) = 'M' varname_list(35) = 'SoilTemp' varmode_list(35) = 'M' varname_list(36) = 'PotEvap' varmode_list(36) = 'M' varname_list(37) = 'ECanop' varmode_list(37) = 'M' varname_list(38) = 'TVeg' varmode_list(38) = 'M' varname_list(39) = 'ESoil' varmode_list(39) = 'M' varname_list(40) = 'EWater' varmode_list(40) = 'M' varname_list(41) = 'RootMoist' varmode_list(41) = 'M' varname_list(42) = 'SubSnow' varmode_list(42) = 'M' varname_list(43) = 'EvapSnow' varmode_list(43) = 'M' varname_list(44) = 'SubSurf' varmode_list(44) = 'M' varname_list(45) = 'ACond' varmode_list(45) = 'M' varname_list(46) = 'SnowFrac' varmode_list(46) = 'M' varname_list(47) = 'RainfSnowFrac' varmode_list(47) = 'M' varname_list(48) = 'SnowfSnowFrac' varmode_list(48) = 'M' varname_list(49) = 'Fdepth' varmode_list(49) = 'M' varname_list(50) = 'Tdepth' varmode_list(50) = 'M' varname_list(51) = 'SAlbedo' varmode_list(51) = 'M' varname_list(52) = 'SnowTProf' varmode_list(52) = 'M' varname_list(53) = 'SnowDepth' varmode_list(53) = 'M' varname_list(54) = 'SliqFrac' varmode_list(54) = 'M' ! varname_list(90) = 'FOUT_LAND' varmode_list(90) = 'F' varname_list(91) = 'DISCHARGE' varmode_list(91) = 'F' varname_list(92) = 'VELOCITY' varmode_list(92) = 'F' varname_list(93) = 'SW_STORE' varmode_list(93) = 'F' varname_list(94) = 'GW_OUTFLOW' varmode_list(94) = 'F' varname_list(95) = 'GW_STORE' varmode_list(95) = 'F' varname_list(96) = 'A_FOUT_LAND' varmode_list(96) = 'M' varname_list(97) = 'A_DISCHARGE' varmode_list(97) = 'M' varname_list(98) = 'A_VELOCITY' varmode_list(98) = 'M' varname_list(99) = 'A_SW_STORE' varmode_list(99) = 'M' varname_list(100)= 'A_GW_OUTFLOW' varmode_list(100)= 'M' varname_list(101)= 'A_GW_STORE' varmode_list(101)= 'M' varname_list(111)= 'SnowfF' varmode_list(111)= 'F' varname_list(112)= 'RainfF' varmode_list(112)= 'F' ! varname_list(120)= 'time' varmode_list(120)= 'A' varname_list(121)= 'timestep' varmode_list(121)= 'A' varname_list(122)= 'lon' varmode_list(122)= 'A' varname_list(123)= 'lat' varmode_list(123)= 'A' varname_list(124)= 'level' varmode_list(124)= 'A' DO i = 1,124 vname(1:20) = varname_list(i)(1:20) IF(vname(1:namelen) == varname(1:namelen) .AND. vname(namelen+1:namelen+1) == ' ') THEN IF(varmode_list(i) == mode .OR. varmode_list(i) == 'A') THEN drv_get_namelist = i RETURN ENDIF ENDIF ENDDO WRITE(6,*) 'Namelist: the variable ',varname(1:namelen),' with mode ',mode,' is not found' STOP END FUNCTION drv_get_namelist !--------------------------------------------------------------------------------- SUBROUTINE drv_datout(iu,vector) !====================================================================== ! Description: CONVERT THE VECTOR VARIABLES BACK TO ARRAYS ! ! $Log: drv_datout.f90,v $ ! Revision 1.1 2002/08/16 15:54:35 guo ! Initial revision ! !====================================================================== USE drv_dat_mod IMPLICIT NONE REAL, DIMENSION(lpnts) :: vector REAL, DIMENSION(lonin ,latin) :: array INTEGER :: i INTEGER :: j INTEGER :: n INTEGER :: iu DO j=1,latin DO i=1,lonin array(i,j)= missing ENDDO ENDDO DO n=1,lpnts if (hmask(n) > 0) & array(iindex(n),jindex(n))= vector(hmask(n)) ENDDO WRITE(iu)array END SUBROUTINE drv_datout end module drv_output_mod