! /SYM64/ 839947691 0 0 0 12144 ` ѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬѬ22222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222&d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d &d MAIN___main_para_new_logic_new_param_new_dims_new_files_new_io_new_time_new_misc_new_baro_new_shap_dake_mix_new_forc_new_forcgr_new_hfxevp_new_energy_pbl_files_new_vert_data_addr_grid_addr_mosf_data_geom_param0_run_grid_coords_winds_shapi_vert_strech_errors_gridk_baro_input_main_new_io_errors___dso_displacement__elf_header__program_header_table_ftextftext__start_mcountMAIN___main_mod_sink_do_island_do_island_int2_copya2b_btpgf_old_baro_bcset_tria_run_inp_sect_inp_dbl_inp_sarr_inp_any_inp_inxt_inp_fnxt_add_mean_old_out_mean_old_tios_close_hflx_s94b_copen_creade_cwrite_cclose_cseek_canseek_cflush_uniqnamsdens12_sdens14_sdens17_pdens14_sdens012_sdens014_sdens017_pdens014_opnda_lenda_mfloat_read_mint_read_nfloat_read_nint_read_killsp_odb_opcdf_odb_close_odb_dfdm_odb_dfvar1_odb_dfvar2_odb_dfvar4_odb_dfvar_odb_wrvar_odb_wr1v2_odb_wr1v3_odb_wr1v4_odb_wr2v4_odb_wr3v4_odb_rd1v2_odb_rd1v4_odb_rd2v4_odb_rd3v4_odb_getvdim_odb_getcattr_odb_setiaattr_odb_setrattr_odb_setraattr_odb_setdattr_odb_getdattr_odb_getiaattr_odb_wrdesc_odb_setfmt_odb_setxyt_odb_set2xyt_odb_set3xyt_odb_setxyte_odb_set2xyte_odb_setxyz_odb_set2xyz_odb_set3xyz_odb_wrxy_odb_wrxz_odb_wryz_odb_wrxye_odb_wr2xye_odb_rdxy_odb_rdxz_odb_rdyz_ncgopt_nccre_nctlen_ncinq_ncabor_ncdren_ncvp1c_ncvptc_ncvptg_ncvpgc_ncvgt1_ncvg1c_ncvgtc_ncvgtg_ncvggc_ncvren_ncacpy_ncanam_ncaren_ncadel_ncsfil_ncvarputsncvargetsncnobufncvarcpyncrecinqncrecputncrecget_etextetext_fdatafdatancfils__fbssedata_edatafbss__rld_obj_headmod_grid3_files_wnfils_gmap_curraddr_curringr_fileend_endbaro_init_baro_solv_mod_open_mod_init_extend_do_island_int_mod_mat_assem_do_elem_add_dt_do_xi_eta_coef_matr_mod_rhs_mod_lu_mod_sol_mod_gra_init_pack_to_y12m_do_adj1_add_to_graph_baro_rinit_do_winds_depth_init_clim_init_h_init_temp_init_salt_init_tau_init_tau_lin_hflx_init_evpr_init_qforc_epforc_hbcset_tbcset_it_catch_data_on_model_grid_grids_equiv_read_zt_nearest_blin_coef_bracket_clim_updt_psi_updt_clim_relax_psi_relax_afill_read_linz_zlin_blin_blin_intr_blin_indx_zlin_intrp_t_limit_idig_mlen_inout_ddiv_wtop_dwcal_vertu_vertt_vertts_verttr_enso2date_date2enso_dayofyear_enso2res_knergy_pnergy_vel_updat_dhoriz_thoriz_zero_em_decap_capfrm_tdecap_fixed_dep_capt_tupdat_zerodt_bcset_non_stable_h_updat_btpgf_new_topo_data_init_dfdxk_dfdyk_dfdx1_dfdy1_baro_dept_baro_shap_baro_sum_baro_scale_baro_tau_baro_comp_baro_rhs_curl_of_psi_baro_updat_baro_div_dens_unesco_sdens_pnt_pdens_pnt_dens_init_situ_dens_potn_dens_dconv_tconv_dconv_cl_tconv_cl_drich_mix_trich_mix_visc_diff_tria_init_tria_tem_dens_eos_theta_eos_sbulk_atg_comp_bncy_cvmix_tke0_ktmix_impmix_jpmix_tridiag_init_rstrt_read_rstrt_keep_rstrt_close_rstrt_dump_rstrt_segm_from_iox_model_input_read_mask_mem_alloc_mem_free_mem_realloc_mem_get_model_memory_datagrid_memory_prtstop1inp_file_inp_trace_inp_vrnt_inp_int_inp_flt_inp_str_inp_iarr_inp_rarr_inp_days_inp_date_inp_def_inp_wnxt_aarea_scaset_stretch_d2psi_dpsi_psi_wspace_perror1_bndrys_bndxy_bound_gridxy_sorti_newcorn_make_iox_maskk_reset_mask_set_pbck_set_bpxk_make_lok_set_pbc_set_bpx_init_data_out_data_out_h_to_z_dept_to_foh_comp_rich_out_mean_out_mosf_comp_mosf_zonal_int_add_mean_comp_q_idvar_tios_loc_wrloc_rdtios_init_tios_map_tios_grid_tios_var_tios_idvar_tios_read_tios_cntrl_sio_putvartios_putvar_tios_putidvar_tios_save_hflx_s89_hflx_s94_init_pbl_htflux_pbl_adv2deq1_advdifq1dx_advdifq1d_tridagqa_shap_indx_shap_vec_shap_scl_shap_2d_shap_1do_shap_1dper_shap_1dco_shap_1dp0_shap_3d_shap_1dcn_cread_cstop_sizefreverseitoa_ipast_scpu_ipast_swll_cpulog_icpu_time_pdens12_pdens17_pdens012_pdens017_pdens1_pdens4_opda_clda_flda_wrda_rdda_iwrda_irdda_y12mfe_y12mbe_y12mce_y12mde_odb_open_odb_dfend_odb_dfsta_odb_dfgr_odb_dftm_odb_dfvar3_odb_wrgr_odb_wrtm_odb_wrxv_odb_wr2v3_odb_rddm_odb_rdgr_odb_rdvar_odb_rdxv_odb_rd1v3_odb_rd2v3_idv_by_name_odb_setcattr_odb_setiattr_odb_getrattr_odb_getraattr_odb_getiattr_loc_len_odb_setnxyt_odb_setnxyte_odb_setnxyz_odb_ifvar_odb_ifatt_odb_creat_ncpopt_ncopn_ncddef_ncdid_ncvdef_ncvid_ncclos_ncredf_ncendf_ncsnc_ncdinq_ncvinq_ncvpt1_ncvpt_ncvgt_ncapt_ncaptc_ncainq_ncagt_ncagtc_ncvarputgncvargetgNC_free_cdfNC_new_cdfNC_dup_cdfncinquirexdr_cdfNC_xlen_cdfxdr_numrecsxdr_NC_fillNC_check_idNC_indefinenccreatencopenncsyncncabortncredefNC_dcpyncendefncclosencsetfillNC_xtypelenNC_typelennctypelenNC_arrayfillNC_new_arrayNC_re_arrayNC_free_arrayNC_xlen_arrayNC_incr_arrayNC_copy_arrayvalsxdr_NC_arrayNC_new_dimNC_free_dimncdimdefncdimidncdiminqncdimrenamexdr_NC_dimNC_xlen_dimNC_new_varNC_free_varncvardefNC_computeshapesncvaridNC_hlookupvarncvarinqncvarrenamexdr_NC_varNC_xlen_varNCcoordckxdr_NCvshortncvarput1ncvarget1NCvcmaxcontigNCvarioncvarputncvargetNC_new_iarrayNC_free_iarrayxdr_NC_iarrayNC_xlen_iarrayNC_new_attrNC_free_attrNCcktypeNC_findattrncattputncattnamencattinqncattrenamencattcopyncattdelncattgetxdr_NC_attrNC_xlen_attrNC_new_stringNC_free_stringNC_re_stringxdr_NC_stringNC_xlen_stringNCxdrfile_syncNCxdrfile_createnc_serrorNCadvisexdr_shorts__istartnew_io_errors_ncerrncoptscdf_routine_name__Argv__Argcpara_new_logic_new_param_new_dims_new_files_new_time_new_misc_new_baro_new_shap_dake_mix_new_forc_new_forcgr_new_hfxevp_new_energy_pbl_files_new_vert_data_addr_grid_addr_mosf_data_geom_param0_run_grid_coords_winds_shapi_vert_strech_gridk_baro_input_main_mod_state_mod_const_mod_grid_mod_grid1_mod_grid2_mod_data_mod_dt_mod_graph_mod_y1_mod_y2_island_1_island_2_mod_matrx_mod_space_baro_files_y12m_input_band_local_matr_local_pbl_data_pbl_param_tria_loc_new_save_new_filt_all_loc_tios_id_mean_comm_var_currgrid_currstr_currrang_currmap_currindx_filedata_filetios_filetiosshap_c25_odb_loc1_odb_loc2___dso_displacement__elf_header__program_header_tableftext_ftext__start_mcountMAIN___main_inp_trace_inp_vrnt_inp_sect_inp_flt_inp_dbl_inp_str_inp_iarr_inp_rarr_inp_sarr_inp_any_inp_days_inp_date_inp_inxt_inp_fnxt_etext_etextfdata_fdataedata_edatafbss_fbss__rld_obj_headend_endf77vfmt_com_read_mask_write_mask_write_mask__inout_mlen_prtstop1inp_file_inp_int_inp_def_inp_wnxt___istart__Argv__Argcfiles_Makefile/ 839272705 1572 1572 100444 3513 ` ######################################## # Makefile for an ocean model # # for use with pmake on SGI computers # # Senya Basin, 1992-96. # ######################################## COMPUTER = SGI MPS = 4 MIPS = -mips$(MPS) DBX = GLOBAL = ORDER = GIDON = #ISLAND = -DICELAND #ISLAND = -DICELAND -DANTILLES #ISLAND = -DAUSTRALIA ISLAND = MODEL = loam$(MPS)$(GLOBAL)$(ORDER) F77 = f77 default: $(MODEL) #if ($(MIPS) == "-mips4") OPTF = -O2 OPTF1 = -O3 -WK,-r=3 FFLAGS = LCDF = -lnetcdf #else OPTF = -O2 OPTF1 = -O2 FFLAGS = -static LCDF = -L/usr/lib -lnetcdf -ldf #endif OPTC = -O2 #if ($(DBX) == "-g") MODEL = new_debug OPTF = OPTF1 = OPTC = #endif FFLAGS += $(DBX) $(OPTF) -col120 $(MIPS) CFLAGS = $(DBX) $(OPTC) -cckr $(MIPS) LDOPT = $(MIPS) #if ($(GLOBAL) =="gl") ANTAR = -DANTARCTICA #else ANTAR = #endif #if ($(ORDER) =="low") ORD = #else ORD = -Dfourth_order #endif ARCH = libdyn$(MPS)$(GLOBAL)$(ORDER).a LIBS = -lsenq -ly12m -lodb $(LCDF) .PATH: NEW OBJ0 = dyn_main.o OBJF1 = dyn_glob.o dyn_subs.o \ dyn_filt.o dyn_dens.o dyn_baro.o \ dyn_hflx.o OBJF2 = dyn_tios.o dyn_mem.o dyn_xir.o dyn_io.o dyn_topo.o dyn_forc.o \ dyn_new.o OBJM = senq_dens.o barotropic.o OBJC = pgentc.o sio.o call.o dyn_c.o help: @echo '. Use "pmake" in order to compile:\n' @echo '. NOT-Global/mips4 version - is a default\n' @echo '. use "pmake mips2" - for MIPS2 version' @echo '. use "pmake [mips4]" - for MIPS4 version' @echo '. use "pmake global" - for GLOBAL version (mips4)' @echo '. use "pmake global" - for GLOBAL version (mips4)' @echo '. use "pmake GLOBAL=gl MPS=2" -for GLOBAL version (mips2)' @echo '. Senya, 1995-1996.' barotropic.o: barotropic.f barotropic.h f77 -c $(FFLAGS) $(ISLAND) $(ANTAR) $< rw_mask: mask.f dyn_c.c f77 -g mask.f dyn_c.c $(OBJF1): $(@:.o=.f) $(F77) -c $(DBX) $(OPTF1) -col120 $(MIPS) $< dyn_io.o: $(@:.o=.f) $(F77) -c $(DBX) -col120 $(MIPS) $< dyn_topo.o: $(@:.o=.f) $(F77) -c $(DBX) $(OPTF1) -col120 $(MIPS) $(ORD) $< dyn_forc.o: $(@:.o=.f) $(F77) -c $(DBX) $(OPTF1) -col120 $(MIPS) $(GIDON) $< dyn_new.o: $(@:.o=.f) # $(F77) -c $(DBX) $(OPTF1) -col120 $(MIPS) -Ddump_all $< $(F77) -c $(DBX) $(OPTF1) -col120 $(MIPS) $< dyn_mem.o: $(@:.o=.f) # $(F77) -c $(DBX) -col120 $(MIPS) -Ddump_all $< $(F77) -c $(DBX) -col120 $(MIPS) $< dyn_tios.o: $(@:.o=.f) # $(F77) -c $(DBX) -col120 $(MIPS) -Ddump_all $< $(F77) -c $(DBX) -col120 $(MIPS) $< senq_dens.o: senq_dens.f f77 -c $(FFLAGS) -DSIGMA $< $(ARCH) : $(ARCH)($(OBJF1) $(OBJF2) $(OBJM) $(OBJC)) ar cru $@ $(.OODATE) /bin/rm -f $(.OODATE) $(MODEL): $(OBJ0) $(ARCH) ... f77 $(LDOPT) -o $@ $> $(LIBS) mips2: @if [ -f $(OBJ0) ] && [ `file $(OBJ0) | cut -d" " -f4` != "mips-2" ] ;\ then /bin/rm $(OBJ0) ; fi pmake MPS=2 mips4: @if [ -f $(OBJ0) ] && [ `file $(OBJ0) | cut -d" " -f4` != "mips-4" ] ;\ then /bin/rm $(OBJ0) ; fi pmake MPS=4 global: @if [ -f $(OBJ0) ] && [ `file $(OBJ0) | cut -d" " -f4` != "mips-4" ] ;\ then /bin/rm $(OBJ0) ; fi pmake GLOBAL=gl MPS=4 debug: @if [ -f $(OBJ0) ]; then /bin/rm $(OBJ0) ; fi pmake DBX=-g MODEL=new_debug MPS=2 ARCH=libdyndebug.a low_order: @if [ -f $(OBJ0) ] && [ `file $(OBJ0) | cut -d" " -f4` != "mips-4" ] ;\ then /bin/rm $(OBJ0) ; fi pmake ORDER=low MPS=4 $(OBJ0) $(OBJF1) $(OBJF2): comm_para.h comm_new.h comm_data.h comm_pbl.h #............................................end of Makefile bak/ 838055104 1572 1572 40555 512 ` u|uVMakefile dyn_xir.old dyn_topo.oldp dyn_tios.oldX dyn_new.old dyn_mem.old dyn_main.old dyn_io.old dyn_forc.old dyn_filt.oldcomm_parah.old comm_newh.oldcomm_datah.oldbartropic_h.old bartropic.old...barotropic.f/ 839881589 1572 1572 100444 47218 ` c 2/24/93 changed call to baro_solv, added iox c 2/25/93 changed call to baro_solv, added psi c 2/25/93 changed call to baro_init, added ibar_key c 3/03/93 got rid of the deph_hx and deph_hy arrays c 3/08/93 changed call to baro_init, added periodic/non-periodic switch c 3/10/93 major revision: c baro_solv c (input) values of forcing at water and boundary points c (output) values of stream function at water and boundry pnts c baro_init c (input) number and list of water+boundary points c (input) number and list of boundary points c mask set according to the above list, NOT by using the c depth values c 3/24/93 changed call to baro_init, including Rayleigh friction and glubina c deleted the 'key' parameter, now controlled from mod.in c 5/18/93 allocation for bound_rhs moved to baro_init c 5/20/93 changed call to baro_solv, including Rayleigh friction c 6/04/93 changed call to baro_init, including nbaro c added subroutine baro_rinit c 6/29/93 variable depth version c 7/12/93 fixed to stabilize third order scheme c 5/12/94 new variable topography c 3/27/95 fixed 2 memory allocation bugs in "baro_init" & "baro_rinit" c 7/12/95 added geometric term to time dependent operator, see "mod_rhs" c and "add_dt" c 7/14/95 all input parameters from "mod.in" and ".y12m" put in common c blocks, for future setting from model_input subroutine c 7/17/95 rewrote so that differencing is on a uniform grid of unit meshsize c with the analytic coordinate transformation factors appearing c in the metric terms emx, emy and emxy, as in main code c 7/19/95 grid stretching implemented c first order derivatives :the stretch factors appear in emx, emy c second order derivatives:new terms were added in add_dt, c mod_rhs and do_xi_eta c 12/19/95 grid stretching invoked; baro-parameters are now read and set c in model_input; changed: calls to baro_init, baro_rinit & c baro_solv; debug output has been cleaned /Senya/ c 5/14/96 coriolis function in generalized coordinates from c common/data_geom instead of computed separately here c 6/19/96 fixed a bug in periodic use of coriolis function c 6/19/96 created this stripped down version with reduced memory c (second order, five point stencil only) c 6/26/96 fixed the sunken island which was spoiled when we imported c the geometric terms c-------------------------------------------------------------------------- subroutine baro_init (i_p, eps, nxp, nyp, nxyc, iox, nbx, lxx, * nby,lyx, alon, blon, alat, blat, x, y, db, glub, mgrid) c---------------------- c compute the coefficients of the discrete barotropic equations and c then perform an approximate lu decomposition c ip = (input) 0: non-periodic in x, 1: periodic in x c eps = (input) effective friction induced by time step c nxp = (input) number of x-coordinate values c nyp = (input) number of y-coordinate values c nxyc = (input) number of compressed (water+boundary) points c iox = (input) compressed -> uncompressed c nbx = (input) number of boundary points c lxx = (input) boundary list position -> compressed position c alon = (input) minimum longitude c blon = (input) maximum longitude c alat = (input) minimum latitude c blat = (input) maximum latitude c x = (input) x coordinate values in degrees c y = (input) y coordinate values in degrees c db = (input) depth values c glub = (input) total depth of ocean c--------------------------------------------------------------------------- dimension f(1), emx(1), emy(1), emxy(1), emx2(1), emy2(1), area(1) dimension sponge(1), relax(1) pointer (p_f, f), (p_emx, emx), (p_emy, emy), (p_emxy, emxy), * (p_emx2, emx2), (p_emy2, emy2), (p_area, area) * , (p_relax, relax), (p_sponge, sponge) common/data_geom/ p_f,p_emx,p_emy,p_emxy,p_emx2,p_emy2, p_area * ,p_relax,p_sponge c--------------------------------------------------------------------------- #include "barotropic.h" integer iox(1), lxx(1), lyx(1) real db(1), x(1), y(1) integer itmp(1) pointer (pitmp, itmp) if_per = i_p GLUBINA = glub mod_cosys = mgrid X_MIN = alon X_MAX = blon Y_MIN = alat Y_MAX = blat hx_s = (X_MAX - X_MIN)/(nxp-1) hy_s = (Y_MAX - Y_MIN)/(nyp-1) NX = nxp + 2*if_per do i = 1 , nxp xx(i+if_per) = x(i) enddo NY = nyp do j = 1 , nyp yy(j) = y(j) enddo c add border of land/periodic points if (if_per.eq.1) then iper = NX - 2 xx(1) = X_MIN - hx_s xx(NX) = X_MAX + hx_s endif NXY = NX * NY call mem_alloc (pdeph, NXY, 2, 'baro deph') call mem_alloc (pfcor, NXY, 2, 'baro fcor') call mem_alloc (pbemx, NXY, 2, 'baro emx') call mem_alloc (pbemy, NXY, 2, 'baro emy') call mem_alloc (pbemxy, NXY, 2, 'baro emxy') call mem_alloc (pbemxx, NXY, 2, 'baro emxx') call mem_alloc (pbemyy, NXY, 2, 'baro emyy') call mem_alloc (pmask, NXY, 0, 'baro mask') call mem_alloc (pbound_rhs, NXY, 2, 'baro bound rhs') do i = 1, NXY mask(i) = BC_L enddo do i = 1, nxyc ixy = iox(i) ix = mod(ixy-1,nxp)+1 iy = (ixy-ix)/nxp + 1 i_xy = (iy - 1)*NX + ix + if_per deph(i_xy) = db(i) fcor(i_xy) = f(i) bemx(i_xy) = emx(i) bemy(i_xy) = emy(i) bemxy(i_xy) = emxy(i) bemxx(i_xy) = emx2(i) bemyy(i_xy) = emy2(i) mask(i_xy) = BC_W enddo if (ibar_key .ne. 0) * open (unit = IUNIT_OUT, file = f_bar(1:n_bar)) if (ibar_key .eq. 3) then write(IUNIT_OUT, *) 'X-boundary points: i, ix,iy, lxx(i)' endif do i = 1, nbx ixy = iox(lxx(i)) ix = mod(ixy-1,nxp)+1 iy = (ixy-ix)/nxp + 1 i_xy = (iy - 1)*NX + ix + if_per if (ibar_key .eq. 3) write(IUNIT_OUT,*) i, ix, iy, lxx(i) if ( (ix.gt.1.and.ix.lt.nxp) .or. if_per.eq.0) mask(i_xy) = BC_L enddo if (ibar_key .eq. 3) then write(IUNIT_OUT,*)'interior points + X-boundary points 1/2:' do iy = NY, 1, -1 write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=1,NX/2) enddo write(IUNIT_OUT,*)'interior points + X-boundary points 2/2:' do iy = NY, 1, -1 write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=NX/2,NX) enddo write(IUNIT_OUT,*) 'Y-boundary points: i, ix, iy, lyx(i)' endif do i = 1, nby ixy = iox(lyx(i)) ix = mod(ixy-1,nxp)+1 iy = (ixy-ix)/nxp + 1 i_xy = (iy - 1)*NX + ix + if_per if (ibar_key .eq. 3) write(IUNIT_OUT,*) i, ix, iy, lyx(i) mask(i_xy) = BC_L enddo call mod_open (eps) call mod_init call mod_gra(0) if ( ibar_key .eq. 3 ) then call mem_alloc (pitmp, NXY, 1, 'BARO iox:') do i = 1, nxyc ixy = iox(i) itmp(ixy) = i enddo do iy = NY, 1, -1 write(IUNIT_OUT, '(200i3)') (mod(itmp(ix+(iy-1)*NX),1000), ix=1,NX) enddo call mem_free (pitmp, NXY, 1) endif call mem_alloc (prelx_p, NPACK, 2, 'baro relx_p') call mem_alloc (prelx_m, NPACK, 2, 'baro relx_m') call mem_alloc (prely_p, NPACK, 2, 'baro rely_p') call mem_alloc (prely_m, NPACK, 2, 'baro rely_m') do i = 1, NPACK i_xy = list(i) ix = mod (i_xy -1 ,NX) + 1 iy = (i_xy - ix)/NX + 1 relx_p(i) = 1. relx_m(i) = 1. rely_p(i) = 1. rely_m(i) = 1. dep = deph(i_xy) if (deph(i_xy+1).ge.BAR_DSINK) relx_p(i) = dep/deph(i_xy+1) if (mask(i_xy+1).eq.BC_P) relx_p(i) = dep/deph(i_xy+1-iper) if (deph(i_xy-1).ge.BAR_DSINK) relx_m(i) = dep/deph(i_xy-1) if (mask(i_xy-1).eq.BC_P) relx_m(i) = dep/deph(i_xy-1+iper) if (deph(i_xy+NX).ge.BAR_DSINK) rely_p(i) = dep/deph(i_xy+NX) if (deph(i_xy-NX).ge.BAR_DSINK) rely_m(i) = dep/deph(i_xy-NX) enddo call mem_alloc(psol, NXY, 2, 'baro sol') call mem_alloc(prhs_bc, NPACK, 2, 'baro rhs_bc') #ifdef ISLAND call mem_alloc(prhs_bc0, NPACK, 2, 'baro rhs_bc0') #endif #ifdef ISLAND1 call mem_alloc(prhs_bc1, NPACK, 2, 'baro rhs_bc1') #endif call mod_mat call mod_lu(0) call mem_free (piro, NN12, 1) if (ibar_key .ne. 0) call flush(IUNIT_OUT) return end subroutine baro_solv (nxp, nyp, nxyc, iox, tb, txb, tyb, psi) c---------------------- c compute the barotropic transports, ub, vb, given the depth and c the average forcing on a uniform grid, using the lu decomposition c from baro_init c nxp = (input) number of x-coordinate values c nyp = (input) number of y-coordinate values c nxyc = (input) number of compressed (water) points c iox = (input) compressed -> uncompressed c txb = (input) barotropic forcing, x-direction c tyb = (input) barotropic forcing, y-direction c tb = (input) curl of the barotropic forcing c psi =(output) barotropic stream function, (compressed x) c---------------------- #include "barotropic.h" real tb(1), txb(1), tyb(1), psi(1) integer iox(1) call mem_alloc (prhs, NPACK, 2, 'baro rhs') call mem_alloc (ptaux, NPACK, 2, 'baro taux') call mem_alloc (ptauy, NPACK, 2, 'baro tauy') call do_winds(nxp,nxyc,iox,txb,tyb,psi) call mod_rhs (nxp,nxyc,iox,tb) call mod_sol #ifdef ISLAND_SINK do i = 1, NPACK i_xy = list(i) bound_rhs(i_xy) = rhs(i) enddo #endif do i = 1, nxyc ixy = iox(i) ix = mod(ixy-1,nxp)+1 iy = (ixy-ix)/nxp + 1 i_xy = (iy - 1)*NX + ix + if_per if (mask(i_xy).eq.BC_W) then i_pac = ilst(i_xy) dpsi = rhs(i_pac) endif if (mask(i_xy).eq.BC_P) then if (ix.eq.1) then i_pac = ilst(i_xy+iper) dpsi = rhs(i_pac) else i_pac = ilst(i_xy-iper) dpsi = rhs(i_pac) endif endif if (mask(i_xy).eq.BC_L) dpsi = 0. if (mask(i_xy).eq.BC_1) dpsi = b_island(1) #ifdef ISLAND if (mask(i_xy).eq.BC_0) dpsi = b_island(0) #endif psi(i) = dpsi enddo call mem_free(prhs, NPACK, 2) call mem_free(ptaux, NPACK, 2) call mem_free(ptauy, NPACK, 2) if (ibar_key .ne. 0) call flush(IUNIT_OUT) return end subroutine mod_open (eps) c------------------------------------------- #include "barotropic.h" CNST_EPS = rayl CNST_EPT = eps/nbaro if ( ibar_key .gt. 0 ) then write (IUNIT_OUT, *) write (IUNIT_OUT, *) ' BAROTROPIC SOLVER INFO' write (IUNIT_OUT, *) ' ----------------------' write (IUNIT_OUT, *) write (IUNIT_OUT, *) 'NX, NY =', NX, NY write (IUNIT_OUT, *) 'X_MIN, X_MAX =', X_MIN,X_MAX write (IUNIT_OUT, *) 'Y_MIN, Y_MAX =', Y_MIN,Y_MAX write (IUNIT_OUT, *) 'epsilon =', CNST_EPT write (IUNIT_OUT, *) 'Rayleigh friction=', CNST_EPS endif return end subroutine mod_init c------------------------- #include "barotropic.h" R_EARTH = 6378000 CNST_2OMEGA = 2. * 2. * MATH_PI / (24. * 3600.) ! 2 * 2*pi/day phi_0 = to_RAD(Y_MIN + Y_MAX) / 2. CNST_BETA = CNST_2OMEGA * cos(phi_0) CNST_F0 = CNST_2OMEGA * ( sin(phi_0) - phi_0 * cos(phi_0) ) c set various repeated-use vectors call extend if (ibar_key.eq.3) then write(IUNIT_OUT, *) 'masks 1/2 :' do iy = NY, 1, -1 write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=1,NX/2) enddo write(IUNIT_OUT, *) 'masks 2/2 :' do iy = NY, 1, -1 write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=NX/2,NX) enddo endif #ifdef ISLAND1 call do_island #endif ISLAND1 #ifdef ISLAND_SINK call mod_sink if (ibar_key.eq.3) then write(IUNIT_OUT, *) 'after sinking, masks 1/2 :' do iy = NY, 1, -1 write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=1,NX/2) enddo write(IUNIT_OUT, *) 'after sinking, masks 2/2 :' do iy = NY, 1, -1 write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=NX/2,NX) enddo endif #endif !ISLAND_SINK end subroutine mod_sink c------------------------- c fictitious domain method c------------------------------------- #include "barotropic.h" do iy = 1, NY do ix = 2, NX i_xy = (iy - 1) * NX + ix if (mask(i_xy).eq.BC_S) then deph(i_xy) = BAR_DELTA mask(i_xy) = BC_W c the rest is a cludge - just to fill in these values fcor(i_xy) = fcor(i_xy - 1) bemx(i_xy) = bemx(i_xy - 1) bemy(i_xy) = bemy(i_xy - 1) bemxy(i_xy) = bemxy(i_xy - 1) bemxx(i_xy) = bemxx(i_xy - 1) bemyy(i_xy) = bemyy(i_xy - 1) endif enddo enddo end subroutine extend c------------------------- #include "barotropic.h" c extend east/west boundaries if (if_per .eq. 1) then ix = 1 do iy = 1, NY i_xy = (iy - 1) * NX + ix mask(i_xy) = mask(i_xy+iper) c deph(i_xy) = deph(i_xy+iper) enddo ix = NX do iy = 1, NY i_xy = (iy - 1) * NX + ix mask(i_xy) = mask(i_xy-iper) c deph(i_xy) = deph(i_xy-iper) enddo ix = NX do iy = 2, NY-1 i_xy = (iy - 1) * NX + ix if (mask(i_xy).eq.BC_W) then mask(i_xy) = BC_P mask(i_xy-NX+1) = BC_P endif if (mask(i_xy).eq.BC_L) then mask(i_xy-NX+1) = BC_L endif enddo endif c make the Southern land mass into an island #ifdef ISLAND do i_xy = 1, NXY ix = mod(i_xy-1, NX) + 1 iy = (i_xy-ix)/NX + 1 dlat = yy(iy) #ifdef ANTARCTICA if ((mask(i_xy).eq.BC_L) * .and. dlat.le.-60) mask(i_xy) = BC_0 #endif #if MUCKING_AROUND if ((mask(i_xy).eq.BC_L) * .and. dlat.le.yy(2)) mask(i_xy) = BC_0 #endif enddo #endif #ifdef ISLAND1 #ifdef ICELAND print*,'setting up ICELAND as an island in barotropic solve' #endif #ifdef AUSTRALIA print*,'setting up AUSTRALIA as an island in barotropic solve' #endif do i_xy = 1, NXY ix = mod(i_xy-1, NX) + 1 iy = (i_xy-ix)/NX + 1 dlon = xx(ix) dlat = yy(iy) #ifdef ICELAND if (mask(i_xy).ne.BC_W .and. (dlat .lt. 68 .and. dlat. gt. 60) * .and. ((dlon .lt. 347 .and. dlon .gt. 335).or. * (dlon .lt. -12 .and. dlon .gt. -25)) ) mask(i_xy) = BC_1 #endif #ifdef AUSTRALIA if (mask(i_xy).ne.BC_W .and. (dlat .lt. -10 .and. dlat. gt. -50) * .and. (dlon .lt. 160 .and. dlon .gt. 110)) mask(i_xy) = BC_1 #endif enddo #endif #ifdef ISLAND_SINK do i_xy = 1, NXY ix = mod(i_xy-1, NX) + 1 iy = (i_xy-ix)/NX + 1 dlon = xx(ix) dlat = yy(iy) c#ifdef ICELAND c if (mask(i_xy).ne.BC_W .and. (dlat .lt. 67 .and. dlat. gt. 60) c * .and. ((dlon .lt. 347 .and. dlon .gt. 335).or. c * (dlon .lt. -12 .and. dlon .gt. -25)) ) mask(i_xy) = BC_S c#endif #ifdef ANTILLES if (mask(i_xy).ne.BC_W .and. (dlat .lt. 24 .and. dlat. gt. 17) * .and. ((dlon .lt. 301 .and. dlon .gt. 276).or. * (dlon .lt. -67 .and. dlon .gt. -84)) ) mask(i_xy) = BC_S #endif #ifdef NEWZEALAND if (mask(i_xy).ne.BC_W .and. (dlat .lt. -30 .and. dlat. gt. -50) * .and. (dlon .lt. 190 .and. dlon .gt. 160)) mask(i_xy) = BC_S #endif #ifdef KERGUELEN if (mask(i_xy).ne.BC_W .and. (dlat .lt. -40 .and. dlat. gt. -60) * .and. (dlon .lt. 80 .and. dlon .gt. 60)) mask(i_xy) = BC_S #endif #ifdef MADAGASCAR if (mask(i_xy).ne.BC_W .and. (dlat .lt. 0 .and. dlat. gt. -30) * .and. (dlon .lt. 55 .and. dlon .gt. 41)) mask(i_xy) = BC_S #endif #ifdef AUSTRALIA if (mask(i_xy).ne.BC_W .and. (dlat .lt. -10 .and. dlat. gt. -50) * .and. (dlon .lt. 160 .and. dlon .gt. 110)) mask(i_xy) = BC_S if (mask(i_xy).ne.BC_W .and. (dlat .lt. 5 .and. dlat. gt. -15) * .and. (dlon .lt. 160 .and. dlon .gt. 125)) mask(i_xy) = BC_S #endif enddo #endif end subroutine do_island c------------------------- #include "barotropic.h" i_max = 1 i_min = NX j_max = 1 j_min = NY do i_xy = 1, NXY ix = mod(i_xy-1, NX) + 1 iy = (i_xy-ix)/NX + 1 if (mask(i_xy).eq.BC_1) then i_max = max(i_max,ix) i_min = min(i_min,ix) j_max = max(j_max,iy) j_min = min(j_min,iy) endif enddo i_max1 = i_max + 1 i_min1 = i_min - 1 j_max1 = j_max + 1 j_min1 = j_min - 1 end subroutine do_island_int c------------------------- #include "barotropic.h" #if defined ISLAND || defined ISLAND1 a_island(0,0) = 1. a_island(0,1) = 0. a_island(1,0) = 0. a_island(1,1) = 1. coef0 = 0. coef1 = 0. c line integrals - trapezoid rule on uniform grid #ifdef ISLAND c find the y index for 60 degrees south (a good place to do the line integral) iy = 1 10 iy = iy + 1 if (yy(iy).ge.-60) goto 20 goto 10 20 ib = iy iy = ib do ix = 2, NX-1 i_xy = (iy - 1) * NX + ix fc = fcor(i_xy) ipac = ilst(i_xy) ipyp = ilst(i_xy + NX) if (ix.gt.2) then ipxm = ilst(i_xy - 1) else ipxm = ilst(i_xy - 1 + iper) endif if (ix.lt.NX-1) then ipxp = ilst(i_xy + 1) else ipxp = ilst(i_xy + 1 - iper) endif dep = deph(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) hx = 1./bex d2 = dep**2 eps = CNST_EPS + dep*CNST_EPT coef0 = coef0 + hx*eps*bey*(rhs0(ipyp)-rhs0(ipac))/d2 coef0 = coef0 + fc/dep*(rhs0(ipxp)-rhs0(ipxm))/2. #ifdef ISLAND1 coef1 = coef1 + hx*eps*bey*(rhs1(ipyp)-rhs1(ipac))/d2 coef1 = coef1 + fc/dep*(rhs1(ipxp)-rhs0(ipxm))/2. #endif enddo a_island(0,0) = coef0 a_island(0,1) = coef1 #endif #ifdef ISLAND1 c integrate on rectangular path surrounding island c assuming all points on path are ocean points coef0 = 0. coef1 = 0. i_maxm = i_max1 - 1 j_maxm = j_max1 - 1 iy = j_max1 s = 0.5 do ix = i_min1, i_max1 i_xy = (iy - 1) * NX + ix fc = fcor(i_xy) ipac = ilst(i_xy) ipyp = ilst(i_xy + NX) ipxm = ilst(i_xy - 1) ipxp = ilst(i_xy + 1) dep = deph(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) hxs = s/bex d2 = dep**2 eps = CNST_EPS + dep*CNST_EPT coef1 = coef1 + hxs*eps*bey*(rhs1(ipyp)-rhs1(ipac))/d2 coef1 = coef1 + s*fc/dep*(rhs1(ipxp)-rhs1(ipxm))/2. #ifdef ISLAND coef0 = coef0 + hxs*eps*bey*(rhs0(ipyp)-rhs0(ipac))/d2 coef0 = coef0 + s*fc/dep*(rhs0(ipxp)-rhs0(ipxm))/2. #endif s = 1. if (ix.eq.i_maxm) s = 0.5 enddo iy = j_min1 s = 0.5 do ix = i_min1, i_max1 i_xy = (iy - 1) * NX + ix fc = fcor(i_xy) ipac = ilst(i_xy) ipym = ilst(i_xy - NX) ipxm = ilst(i_xy - 1) ipxp = ilst(i_xy + 1) dep = deph(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) hxs = s/bex d2 = dep**2 eps = CNST_EPS + dep*CNST_EPT coef1 = coef1 - hxs*eps*bey*(rhs1(ipac)-rhs1(ipym))/d2 coef1 = coef1 - s*fc/dep*(rhs1(ipxp)-rhs1(ipxm))/2. #ifdef ISLAND coef0 = coef0 - hxs*eps*bey*(rhs0(ipac)-rhs0(ipym))/d2 coef0 = coef0 - s*fc/dep*(rhs0(ipxp)-rhs0(ipxm))/2. #endif s = 1. if (ix.eq.i_maxm) s = 0.5 enddo ix = i_max1 s = 0.5 do iy = j_min1, j_max1 i_xy = (iy - 1) * NX + ix fc = fcor(i_xy) ipac = ilst(i_xy) ipxp = ilst(i_xy + 1) ipym = ilst(i_xy - NX) ipyp = ilst(i_xy + NX) dep = deph(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) hys = s/bey d2 = dep**2 eps = CNST_EPS + dep*CNST_EPT coef1 = coef1 + hys*eps*bex*(rhs1(ipxp)-rhs1(ipac))/d2 coef1 = coef1 - s*fc/dep*(rhs1(ipyp)-rhs1(ipym))/2. #ifdef ISLAND coef0 = coef0 + hys*eps*bex*(rhs0(ipxp)-rhs0(ipac))/d2 coef0 = coef0 - s*fc/dep*(rhs0(ipyp)-rhs0(ipym))/2. #endif s = 1. if (iy.eq.j_maxm) s = 0.5 enddo ix = i_min1 s = 0.5 do iy = j_min1, j_max1 i_xy = (iy - 1) * NX + ix fc = fcor(i_xy) ipac = ilst(i_xy) ipxm = ilst(i_xy - 1) ipym = ilst(i_xy - NX) ipyp = ilst(i_xy + NX) dep = deph(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) hys = s/bey eps = CNST_EPS + dep*CNST_EPT coef1 = coef1 - hys*eps*bex*(rhs1(ipac)-rhs1(ipxm))/d2 coef1 = coef1 + s*fc/dep*(rhs1(ipyp)-rhs1(ipym))/2. #ifdef ISLAND coef0 = coef0 - hys*eps*bex*(rhs0(ipac)-rhs0(ipxm))/d2 coef0 = coef0 + s*fc/dep*(rhs0(ipyp)-rhs0(ipym))/2. #endif s = 1. if (iy.eq.j_maxm) s = 0.5 enddo a_island(1,0) = coef0 if (coef1.ne.0) a_island(1,1) = coef1 #endif if ( ibar_key .ge. 1 ) then write(IUNIT_OUT, *) 'a_island(2:2)=' write(IUNIT_OUT, *) a_island(0,0),a_island(0,1) write(IUNIT_OUT, *) a_island(1,0),a_island(1,1) endif #endif end subroutine do_island_int2 c------------------------- #include "barotropic.h" dimension b(0:2) #if defined ISLAND || defined ISLAND1 b(0) = 0. b(1) = 0. coef = 0. wind = 0. c line integrals - trapezoid rule on uniform grid #ifdef ISLAND iy = ib do ix = 2, NX-1 i_xy = (iy - 1) * NX + ix fc = fcor(i_xy) ipac = ilst(i_xy) ipyp = ilst(i_xy + NX) if (ix.gt.2) then ipxm = ilst(i_xy - 1) else ipxm = ilst(i_xy - 1 + iper) endif if (ix.lt.NX-1) then ipxp = ilst(i_xy + 1) else ipxp = ilst(i_xy + 1 - iper) endif dep = deph(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) hx = 1./bex d2 = dep**2 wind = wind + hx * taux(ipac)/ dep eps = CNST_EPS + dep*CNST_EPT coef = coef + hx* eps* bey* (rhs(ipyp)-rhs(ipac))/d2 coef = coef + fc/dep*(rhs(ipxp)-rhs(ipxm))/2. enddo b(0) = - ( wind + coef ) #endif #ifdef ISLAND1 c integrate on rectangular path surrounding island coef = 0. coef0 = 0. coef1 = 0. wind = 0. i_maxm = i_max1 - 1 j_maxm = j_max1 - 1 iy = j_max1 s = 0.5 do ix = i_min1, i_max1 i_xy = (iy - 1) * NX + ix fc = fcor(i_xy) ipac = ilst(i_xy) ipxm = ilst(i_xy - 1) ipxp = ilst(i_xy + 1) ipyp = ilst(i_xy + NX) dep = deph(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) hxs = s/bex d2 = dep**2 wind = wind + hxs * taux(ipac)/ dep eps = CNST_EPS + dep*CNST_EPT c coef = coef + hxs* eps* bey*(rhs(ipyp)-rhs(ipac))/ d2 c coef = coef + s* fc/ dep* (rhs(ipxp)-rhs(ipxm))/2. coef0 = coef0 + hxs* eps* bey*(rhs(ipyp)-rhs(ipac))/ d2 coef1 = coef1 + s* fc/ dep* (rhs(ipxp)-rhs(ipxm))/2. s = 1. if (ix.eq.i_maxm) s = 0.5 enddo iy = j_min1 s = 0.5 do ix = i_min1, i_max1 i_xy = (iy - 1) * NX + ix fc = fcor(i_xy) ipac = ilst(i_xy) ipxm = ilst(i_xy - 1) ipxp = ilst(i_xy + 1) ipym = ilst(i_xy - NX) dep = deph(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) hxs = s/bex d2 = dep**2 wind = wind - hxs * taux(ipym)/ dep eps = CNST_EPS + dep*CNST_EPT c coef = coef - hxs* eps* bey*(rhs(ipac)-rhs(ipym))/ d2 c coef = coef - s * fc/dep*(rhs(ipxp)-rhs(ipxm))/2. coef0 = coef0 - hxs* eps* bey*(rhs(ipac)-rhs(ipym))/ d2 coef1 = coef1 - s * fc/dep*(rhs(ipxp)-rhs(ipxm))/2. s = 1. if (ix.eq.i_maxm) s = 0.5 enddo ix = i_max1 s = 0.5 do iy = j_min1, j_max1 i_xy = (iy - 1) * NX + ix fc = fcor(i_xy) ipac = ilst(i_xy) ipxp = ilst(i_xy + 1) ipym = ilst(i_xy - NX) ipyp = ilst(i_xy + NX) dep = deph(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) hys = s/bey d2 = dep**2 wind = wind - hys * tauy(ipac)/ dep eps = CNST_EPS + dep*CNST_EPT c coef = coef + hys* eps* bex*(rhs(ipxp)-rhs(ipac))/d2 c coef = coef - s * fc/dep*(rhs(ipyp)-rhs(ipym))/2. coef0 = coef0 + hys* eps* bex*(rhs(ipxp)-rhs(ipac))/d2 coef1 = coef1 - s * fc/dep*(rhs(ipyp)-rhs(ipym))/2. s = 1. if (iy.eq.j_maxm) s = 0.5 enddo ix = i_min1 s = 0.5 do iy = j_min1, j_max1 i_xy = (iy - 1) * NX + ix fc = fcor(i_xy) ipac = ilst(i_xy) ipxm = ilst(i_xy - 1) ipym = ilst(i_xy - NX) ipyp = ilst(i_xy + NX) dep = deph(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) hys = s/bey d2 = dep**2 wind = wind + hys * tauy(ipxm)/ dep eps = CNST_EPS + dep*CNST_EPT c coef = coef - hys* eps* bex*(rhs(ipac)-rhs(ipxm))/d2 c coef = coef + s * fc/dep*(rhs(ipyp)-rhs(ipym))/2. coef0 = coef0 - hys* eps* bex*(rhs(ipac)-rhs(ipxm))/d2 coef1 = coef1 + s * fc/dep*(rhs(ipyp)-rhs(ipym))/2. s = 1. if (iy.eq.j_maxm) s = 0.5 enddo b(1) = - ( wind + coef0 + coef1 ) #endif det = a_island(0,0)*a_island(1,1) - a_island(0,1)*a_island(1,0) b_island(0) = (b(0)*a_island(1,1) - b(1)*a_island(0,1)) / det b_island(1) = (b(1)*a_island(0,0) - b(0)*a_island(1,0)) / det if ( ibar_key .ge. 1 ) then write(IUNIT_OUT, *) 'b_island = ' write(IUNIT_OUT, *) wind,coef0,coef1 write(IUNIT_OUT, *) 'setting CNST_T = ', b_island(0), b_island(1) endif #endif end subroutine mod_mat c------------------------ c computes approximate matrix norm c sets up sparse matrix aa, using stencils computed c in do_elem* c scales all matrix entries in aa by approx. matrix norm c------------------------ #include "barotropic.h" common /band_local/ iband, iaa hx_ave = 0. hy_ave = 0. do i = 1, NPACK i_xy = list(i) hx_ave = hx_ave + 1./bemx(i_xy) hy_ave = hy_ave + 1./bemy(i_xy) enddo hx_ave = hx_ave/NPACK hy_ave = hy_ave/NPACK CNST_NORM * = (GLUBINA*CNST_EPT + CNST_EPS) * (1./hx_ave**2 + 1./hy_ave**2) + * CNST_BETA * GLUBINA / hx_ave / R_EARTH do i_xy = 1, NXY sol(i_xy) = 0.0 enddo do i = 1, NPACK rhs_bc(i) = 0. #ifdef ISLAND rhs_bc0(i) = 0. #endif #ifdef ISLAND1 rhs_bc1(i) = 0. #endif enddo iaa = 0 do i_pac = 1, NPACK i_xy = list(i_pac) call do_xi_eta (i_pac,i_xy,xi,eta) call do_elem(i_pac,i_xy,xi,eta) call add_dt(i_pac, i_xy) iband = 0 call assem (i_pac,i_xy) enddo if (iaa .ne. NONZ) then print*, 'BARO: The matrix has the wrong size !!!' stop endif end subroutine assem (i_pac,i_xy) c------------------------------ #include "barotropic.h" real*8 ce, cw, cn, cs, csum common /matr_local/ ce, cw, cn, cs, csum call coef_matr (i_pac, i_xy, csum) if (mask(i_xy+1).eq.BC_P) then call coef_matr (i_pac, i_xy + 1 - iper, ce) else call coef_matr (i_pac, i_xy + 1, ce) endif if (mask(i_xy-1).eq.BC_P) then call coef_matr (i_pac, i_xy - 1 + iper, cw) else call coef_matr (i_pac, i_xy - 1, cw) endif call coef_matr (i_pac, i_xy + NX, cn) call coef_matr (i_pac, i_xy - NX, cs) end subroutine do_elem(i_pac,i_xy,xi,eta) c----------------------------- #include "barotropic.h" real*8 ce, cw, cn, cs, csum common /matr_local/ ce, cw, cn, cs, csum real*8 hinv, gam, am, ac, ap, heps real*8 bm, bc, bp c ............................. x - direction hinv = bemx(i_xy) gam = xi/ hinv am = CNST_EPS - (gam-abs(gam))/2. ap = CNST_EPS + (gam+abs(gam))/2. ac = -(am+ap) c_h = hinv* hinv/ CNST_NORM ap = c_h * ap am = c_h * am ac = c_h * ac c ............................. y - direction hinv = bemy(i_xy) gam = eta/ hinv bm = CNST_EPS - (gam-abs(gam))/2. bp = CNST_EPS + (gam+abs(gam))/2. bc = -(bm+bp) c_h = hinv* hinv/ CNST_NORM bp = c_h * bp bm = c_h * bm bc = c_h * bc c ............................. construct stencil cw = am ce = ap cs = bm cn = bp csum = ac + bc end subroutine add_dt (i_pac, i_xy) c----------------------------- #include "barotropic.h" common /matr_local/ ce, cw, cn, cs, csum real*8 ce, cw, cn, cs, csum ix = mod (i_xy -1 ,NX) + 1 iy = (i_xy - ix)/NX + 1 dep = deph(i_xy) const = 0.5* dep* CNST_EPT/ CNST_NORM bex = bemx(i_xy) bey = bemy(i_xy) hxe = const*bex**2 hye = const*bey**2 hxy = const*bemxy(i_xy)*bey hxx = const*bemxx(i_xy)*bex hyy = const*bemyy(i_xy)*bey cea = hxe * (1. + relx_p(i_pac)) + hxx cwa = hxe * (1. + relx_m(i_pac)) - hxx cna = hye * (1. + rely_p(i_pac)) + hxy + hyy csa = hye * (1. + rely_m(i_pac)) - hxy - hyy ce = ce + cea cw = cw + cwa cn = cn + cna cs = cs + csa csum = csum - (cea + cwa + cna + csa) end subroutine do_xi_eta (ip,i_xy,xi,eta) c----------------------------- #include "barotropic.h" bex = bemx(i_xy) bey = bemy(i_xy) bexy = bemxy(i_xy) bexx = bemxx(i_xy) beyy = bemyy(i_xy) dep = deph(i_xy) if (dep.ge.BAR_DSINK) then deph_x =bex*(relx_p(ip)-relx_m(ip)) * (relx_p(ip)+relx_m(ip)) / 2. deph_y =bey*(rely_p(ip)-rely_m(ip)) * (rely_p(ip)+rely_m(ip)) / 2. if (mask(i_xy-1).eq.BC_P) then f_cmx = fcor(i_xy - 1 + iper) else f_cmx = fcor(i_xy - 1) endif if (mask(i_xy+1).eq.BC_P) then f_cpx = fcor(i_xy + 1 - iper) else f_cpx = fcor(i_xy + 1) endif f_cpy = fcor(i_xy + NX) f_cmy = fcor(i_xy - NX) c calculate H**2 (f/H)x fh_x = dep * bex* (f_cpx*relx_p(ip) - f_cmx*relx_m(ip))/ 2. c calculate H**2 (f/H)y fh_y = dep * bey* (f_cpy*rely_p(ip) - f_cmy*rely_m(ip))/ 2. xi = CNST_EPS * (deph_x + bexx) + fh_y eta= CNST_EPS * (deph_y + beyy + bexy) - fh_x else ! sunken island xi = 0. eta= 0. endif end subroutine coef_matr (i_pac, i_xy, elem) c---------------------------------------- #include "barotropic.h" real*8 elem common /band_local/ iband, iaa solu = 1. if (mask(i_xy) .eq. BC_W) then c if ocean iaa = iaa + 1 aa(iaa) = real(elem) return endif if (mask(i_xy) .eq. BC_L) then c if outer boundary of ocean iband = 1 rhs_bc(i_pac)=rhs_bc(i_pac) - elem * sol(i_xy) return endif #ifdef ISLAND if (mask(i_xy) .eq. BC_0) then rhs_bc0(i_pac)=rhs_bc0(i_pac) - elem * solu return endif #endif #ifdef ISLAND1 if (mask(i_xy) .eq. BC_1) then rhs_bc1(i_pac)=rhs_bc1(i_pac) - elem * solu return endif #endif end subroutine mod_rhs (nxp,nxyc,iox,tb) c------------------------------------------- #include "barotropic.h" real tb(1) integer iox(1) real tmp1(1) pointer (ptmp1, tmp1) call mem_alloc (ptmp1, NXY, 2, 'baro tmp1') do i = 1, nxyc ixy = iox(i) ix = mod(ixy-1,nxp)+1 iy = (ixy-ix)/nxp + 1 i_xy = (iy - 1)*NX + ix + if_per dep = deph(i_xy) tmp1(i_xy) = dep * dep * tb(i) enddo do i_pac = 1, NPACK i_xy = list(i_pac) ix = mod(i_xy-1, NX) + 1 iy = (i_xy-ix)/NX + 1 bw = bound_rhs(i_xy-1) be = bound_rhs(i_xy+1) if (mask(i_xy-1).eq.BC_P) bw = bound_rhs(i_xy-1+iper) if (mask(i_xy+1).eq.BC_P) be = bound_rhs(i_xy+1-iper) bn = bound_rhs(i_xy+NX) bs = bound_rhs(i_xy-NX) bc = bound_rhs(i_xy) bex = bemx(i_xy) bey = bemy(i_xy) dep = deph(i_xy) const = 0.5* dep* CNST_EPT hxe = const* bex**2 hye = const* bey**2 hxy = const* bemxy(i_xy)*bey hxx = const* bemxx(i_xy)*bex hyy = const* bemyy(i_xy)*bey ce = hxe * (1. + relx_p(i_pac)) + hxx cw = hxe * (1. + relx_m(i_pac)) - hxx cn = hye * (1. + rely_p(i_pac)) + hxy + hyy cs = hye * (1. + rely_m(i_pac)) - hxy - hyy csum = - (ce + cw + cn + cs) btemp= cw*bw + ce*be + cn*bn + cs*bs + csum*bc rhs(i_pac)= btemp enddo do i = 1, NXY bound_rhs(i) = 0. enddo do i_pac = 1, NPACK i = list(i_pac) bound_rhs(i) = (rhs(i_pac) + tmp1(i) ) / CNST_NORM enddo call mem_free (ptmp1, NXY, 2) end subroutine mod_lu(id) c-------------------------- c The contents of NPACK, NONZ, aa, ico, NN12, pivot, sn, a1, c columns 1, 3, 4, 6, 7, 8 and 11 of HA, c AFLAG(6), IFLAG(1), IFLAG(4) and IFAIL should c not be altered between calls of y12mfe c-------------------------- #include "barotropic.h" external icpu_time real b1(1), sol1(1) pointer (pb1, b1), (psol1,sol1) data M12_HA /13/ call mem_alloc (pb1, NPACK, 2, 'baro b1') call mem_alloc (psol1, NPACK, 2, 'baro sol1') #ifdef ISLAND1 call mem_alloc (prhs1, NPACK, 2, 'baro rhs1') #endif if ( id .eq. 0) then call mem_alloc (pa1, NONZ, 2, 'baro a1') call mem_alloc (psn, NONZ, 2, 'baro sn') call mem_alloc (pha, NPACK*M12_HA, 2, 'baro ha') call mem_alloc (ppivot, NPACK, 2, 'baro pivot') call mem_alloc (prhs0, NPACK, 2, 'baro rhs0') endif c modify rhs to include non-zero dirichlet boundary conditions #ifdef ISLAND do i = 1, NPACK rhs0(i) = rhs_bc0(i) enddo #endif NN12 = NONZ * RM12_NN call mem_realloc (piro, NGRAPH, NN12, NONZ, 1) if (id .eq. 0) then call mem_realloc (pico, NGRAPH, NN12, NONZ, 1) call mem_realloc (paa, NGRAPH, NN12, NONZ, 2) endif itime = icpu_time() if ( ibar_key.ge.1 ) then write(IUNIT_OUT, *) write(IUNIT_OUT, *) 'LU factorization:' write(IUNIT_OUT, *) 'NPACK, NONZ, NN12 = ', NPACK, NONZ, NN12 endif if (ibar_key .eq. 11) then ! output the matrix for separate analyses c open (unit=12, file = 'matr', form = 'unformatted') open (unit=12, file = 'matr', form = 'formatted') write(12,*) NPACK, NONZ, NN12 write(12,*) (iflag(i),i=1,8) write(12,*) (aflag(i),i=1,8) write(12,*) 'aa:' write(12,*) (aa(i),i=1,NONZ) write(12,*) 'iro:' write(12,*) (iro(i),i=1,NONZ) write(12,*) 'ico:' write(12,*) (ico(i),i=1,NONZ) close(12) stop endif iflag(5) = 2 call y12mfe(NPACK, aa, ico, NN12, iro, NN12, a1, sn, NONZ, * ha, NPACK, rhs0, b1, sol1, pivot, aflag, iflag, ifail) iflag(5) = 3 if (ibar_key.ge.1) then write(IUNIT_OUT, *) 'growth factor =',aflag(5) write(IUNIT_OUT, *) 'minimal pivotal element =',aflag(8) write(IUNIT_OUT, *) 'max number of non-zero elements needed ', * 'in array aa =',iflag(8) write(IUNIT_OUT, *) 'if this last number was much smaller than' * ,NN12,', reduce NN12' endif if (ifail .ne. 0) goto 10 itime = (icpu_time() - itime) / 1000000 if (ibar_key.ge.1) then write(IUNIT_OUT, *) write(IUNIT_OUT, *) 'CPU time for LU factorization was',itime,' sec' endif #ifdef ISLAND if (ibar_key.ge.1) then write(IUNIT_OUT, *) write(IUNIT_OUT, *)"ANTARCTICA" write(IUNIT_OUT, *)'number of iterations performed =',iflag(12) write(IUNIT_OUT, *)'max-norm of last correction vector =',aflag(9) write(IUNIT_OUT, *)'max-norm of last residual vector =',aflag(10) write(IUNIT_OUT, *)'max-norm of corrected solution vector =',aflag(11) endif do i = 1, NPACK rhs0(i) = sol1(i) enddo #endif #ifdef ISLAND1 do i = 1, NPACK rhs1(i) = rhs_bc1(i) enddo call y12mfe (NPACK, aa, ico, NN12, iro, NN12, a1, sn, NONZ, * ha, NPACK, rhs1, b1, sol1, pivot, aflag, iflag, ifail) if (ibar_key.ge.1) then write(IUNIT_OUT, *) write(IUNIT_OUT, *)"ISLAND1" write(IUNIT_OUT, *)'number of iterations performed =',iflag(12) write(IUNIT_OUT, *)'max-norm of last correction vector =',aflag(9) write(IUNIT_OUT, *)'max-norm of last residual vector =',aflag(10) write(IUNIT_OUT, *)'max-norm of corrected solution vector =',aflag(11) endif do i = 1, NPACK rhs1(i) = sol1(i) enddo #endif 10 if (ifail .ne. 0) then print*, 'BARO: !!! Error code from Y12M:',ifail stop endif call do_island_int call mem_free (pb1, NPACK, 2) call mem_free (psol1, NPACK, 2) #ifdef ISLAND1 call mem_free (prhs1, NPACK, 2) #endif end subroutine mod_sol c-------------------------- #include "barotropic.h" real b1(1), sol1(1) pointer (pb1, b1), (psol1,sol1) c modify rhs to include non-zero dirichlet boundary conditions do i = 1, NPACK i_xy = list(i) rhs0(i) = bound_rhs(i_xy) + rhs_bc(i) enddo call mem_alloc (pb1, NPACK, 2, 'baro b1') call mem_alloc (psol1, NPACK, 2, 'baro sol1') if (ibar_key.ge.2) then write(IUNIT_OUT, *) write(IUNIT_OUT, *) 'Baro_solv:' endif c solve once to get the solution for zero boundary condition, c in order to determine b_island call y12mfe(NPACK, aa, ico, NN12, iro, NN12, a1, sn, NONZ, * ha, NPACK, rhs0, b1, sol1, pivot, aflag, iflag, ifail) if (ifail .ne. 0) goto 10 if (ibar_key.ge.2) then write(IUNIT_OUT, *)'number of iterations performed =', iflag(12) write(IUNIT_OUT, *)'max-norm of last correction vector =', aflag(9) write(IUNIT_OUT, *)'max-norm of last residual vector =', aflag(10) write(IUNIT_OUT, *)'max-norm of corrected solution vector =',aflag(11) endif do i = 1, NPACK rhs(i) = sol1(i) rhs0(i) = b1(i) enddo #if defined ISLAND || defined ISLAND1 c correct for the island influence, using a_island call do_island_int2 c# write(54,*) b_island(0) #ifdef ISLAND c# b_island(0) = 120.e+06 do i = 1, NPACK rhs0(i) = rhs0(i) + rhs_bc0(i)*b_island(0) enddo #endif #ifdef ISLAND1 c# b_island(1) = -18.e+06 do i = 1, NPACK rhs0(i) = rhs0(i) + rhs_bc1(i)*b_island(1) enddo #endif call y12mfe (NPACK, aa, ico, NN12, iro, NN12, a1, sn, NONZ, * ha, NPACK, rhs0, b1, sol1, pivot, aflag, iflag, ifail) if (ibar_key.ge.2) then write(IUNIT_OUT, *) write(IUNIT_OUT, *)"correcting for island influence" write(IUNIT_OUT, *)'number of iterations performed =', iflag(12) write(IUNIT_OUT, *)'max-norm of last correction vector =', aflag(9) write(IUNIT_OUT, *)'max-norm of last residual vector =', aflag(10) write(IUNIT_OUT, *)'max-norm of corrected solution vector =',aflag(11) endif do i = 1, NPACK rhs(i) = sol1(i) enddo #endif call mem_free (pb1, NPACK, 2) call mem_free (psol1, NPACK, 2) 10 if (ifail .ne. 0) then print*, 'BARO: !!! Error code from Y12M:',ifail stop endif end subroutine mod_gra(id) c------------------------- #include "barotropic.h" if (id.eq.0) then call init_pack endif call to_y12m(id) end subroutine init_pack c--------------------------- #include "barotropic.h" NPACK = 0 do i = 1, NXY if (mask(i) .eq. BC_W) NPACK = NPACK + 1 enddo call mem_alloc (plist, NPACK, 1, 'baro list') call mem_alloc (pilst, NXY, 1, 'baro ilst') n = 0 do i = 1, NXY if (mask(i) .eq. BC_W) then n = n + 1 list(n) = i ilst(i) = n endif enddo end subroutine to_y12m(id) c------------------------ #include "barotropic.h" NGRAPH = NPACK * 5 call mem_alloc (piro, NGRAPH, 1, 'baro iro') if ( id .eq. 0 ) then call mem_alloc (pico, NGRAPH, 1, 'baro ico') call mem_alloc (paa, NGRAPH, 2, 'baro aa') endif NONZ = 0 do k = 1, NPACK call do_adj1(k) enddo end subroutine do_adj1 (k) c--------------------------------------- #include "barotropic.h" i = list(k) call add_to_graph (k, i) if (mask(i+1) .eq. BC_P) then call add_to_graph (k, i + 1 - iper) else call add_to_graph (k, i + 1) endif if (mask(i-1) .eq. BC_P) then call add_to_graph (k, i - 1 + iper) else call add_to_graph (k, i - 1) endif call add_to_graph (k, i + NX) call add_to_graph (k, i - NX) end subroutine add_to_graph (k, i) c-------------------------------- #include "barotropic.h" ii = ilst(i) if (ii .ne. 0) then NONZ = NONZ + 1 iro(NONZ) = k ico(NONZ) = ii endif end subroutine baro_rinit (eps) c---------------------- c recompute the coefficients of the discrete barotropic equations and c then perform an approximate lu decomposition c eps = (input) effective friction induced by time step c---------------------- #include "barotropic.h" CNST_EPS = rayl CNST_EPT = eps/nbaro if (ibar_key .ge. 1) then write (IUNIT_OUT, *) write (IUNIT_OUT, *) 'rinit: epsilon =', CNST_EPT write (IUNIT_OUT, *) 'rinit: Rayleigh friction=', CNST_EPS endif call mod_gra(1) call mod_mat call mod_lu(1) call mem_free(piro, NN12, 1) end subroutine do_winds (nxp,nxyc,iox,txb,tyb,psi) c---------------------- #include "barotropic.h" real txb(1), tyb(1), psi(1) integer iox(1) real tmp1(1) pointer (ptmp1, tmp1) call mem_alloc (ptmp1, NXY, 2, 'baro tmp1') do i = 1, nxyc ixy = iox(i) ix = mod(ixy-1,nxp)+1 iy = (ixy-ix)/nxp + 1 i_xy = (iy - 1)*NX + ix + if_per bound_rhs(i_xy) = psi(i) enddo #if defined ISLAND || defined ISLAND1 do i = 1, nxyc ixy = iox(i) ix = mod(ixy-1,nxp)+1 iy = (ixy-ix)/nxp + 1 i_xy = (iy - 1)*NX + ix + if_per tmp1(i_xy) = txb(i) enddo do i_pac = 1, NPACK i_xy = list(i_pac) bc = tmp1(i_xy) bn = tmp1(i_xy+NX) bnn = bn if (mask(i_xy+NX).eq.BC_W) bnn = tmp1(i_xy+NX+NX) bs = tmp1(i_xy-NX) c taux(i_pac) = (7.*(bn + bc) - (bnn + bs) ) / 12. taux(i_pac) = (bn + bc) / 2. enddo do i = 1, nxyc ixy = iox(i) ix = mod(ixy-1,nxp)+1 iy = (ixy-ix)/nxp + 1 i_xy = (iy - 1)*NX + ix + if_per tmp1(i_xy) = tyb(i) enddo do i_pac = 1, NPACK i_xy = list(i_pac) bc = tmp1(i_xy) be = tmp1(i_xy+1) bee = be if (mask(i_xy+1).eq.BC_W) bee = tmp1(i_xy+2) if (mask(i_xy-1).eq.BC_P) bw = tmp1(i_xy-1+iper) if (mask(i_xy+1).eq.BC_P) then be = tmp1(i_xy+1-iper) bee = tmp1(i_xy+2-iper) endif c tauy(i_pac) = (7.*(be + bc) - (bee + bw) ) / 12. tauy(i_pac) = (be + bc) / 2. enddo h2y = 2 * hy do i_pac = 1, NPACK i_xy = list(i_pac) ix = mod(i_xy-1, NX) + 1 iy = (i_xy-ix)/NX + 1 bex = bemx(i_xy) bey = bemy(i_xy) be = bound_rhs(i_xy+1) if (mask(i_xy+1).eq.BC_P) be = bound_rhs(i_xy+1-iper) bn = bound_rhs(i_xy+NX) bc = bound_rhs(i_xy) taux(i_pac) = taux(i_pac) - bey* CNST_EPT*(bn - bc) tauy(i_pac) = tauy(i_pac) + bex* CNST_EPT*(be - bc) enddo #else do i_pac = 1, NPACK taux(i_pac) = 0. tauy(i_pac) = 0. enddo #endif call mem_free (ptmp1, NXY, 2) end barotropic.h/ 838054470 1572 1572 100444 4210 ` c ISLANDS c-------------------------------- #ifdef ANTARCTICA #define ISLAND ! is there a periodic island? (antarctica) #endif #ifdef MUCKING_AROUND #define ISLAND ! is there a periodic island? (antarctica) #endif #ifdef ICELAND c#define ISLAND_SINK ! are there islands to be sunk? #define ISLAND1 ! is there a standard kind of island? (e.g., iceland) #endif #ifdef ANTILLES #define ISLAND_SINK ! are there islands to be sunk? #endif c-------------------------------- parameter (IUNIT_OUT = 18) character*1 BC_W, BC_L, BC_P, BC_0, BC_1, BC_S parameter (BC_W='W',BC_L='L',BC_P='P',BC_0='0',BC_1='1',BC_S='S') integer SCH_5, SCH_9 parameter (SCH_5=5, SCH_9=9) parameter(MAX_NX = 1000, MAX_NY = 1000) parameter (PREC = 1.e-6) real*8 MATH_PI,MATH_E parameter (MATH_PI=3.14159265358979323846) parameter (MATH_E= 2.7182818284590452354) #define to_RAD(v) ((v)*MATH_PI/180.) #define to_DEG(v) ((v)*180./MATH_PI) c----------------------------------------------------------------- common /MOD_STATE/ mod_cosys common /MOD_CONST/ CNST_EPS, CNST_2OMEGA, R_EARTH * , CNST_BETA, CNST_F0, CNST_NORM, GLUBINA * , mod_island, CNST_EPT c---------------------------------------------------------- character*1 mask(1) real*8 hx, hy, R_EARTH integer list(1) pointer (pmask,mask), (plist,list) real*4 xx(MAX_NX), yy(MAX_NY) real*4 hx_cos(MAX_NY), r_tan(MAX_NY) common /MOD_GRID/ NX_MODEL, NY_MODEL, NX, NY, NXY, NPACK * ,pmask, plist, if_per, iper common /MOD_GRID1/ hx, hy, hx_s, hy_s common /MOD_GRID2/ X_MAX, Y_MAX, X_MIN, Y_MIN, xx, yy common /MOD_GRID3/ hx_cos, r_tan real deph(1) real fcor(1), bemx(1), bemy(1), bemxy(1), bemxx(1), bemyy(1) real relx_m(1), relx_p(1), rely_m(1), rely_p(1) pointer (pdeph, deph), (pfcor,fcor) pointer (pbemx, bemx), (pbemy, bemy), (pbemxy, bemxy) pointer (pbemxx, bemxx), (pbemyy, bemyy) pointer (prelx_m,relx_m),(prelx_p,relx_p) pointer (prely_m,rely_m),(prely_p,rely_p) real taux(1), tauy(1) pointer (ptaux, taux), (ptauy, tauy) common /MOD_DATA/ pdeph, prelx_p, prelx_m, prely_p, prely_m, pfcor * , pbemx, pbemy, pbemxy, pbemxx, pbemyy common /MOD_DT/ ptaux, ptauy integer iro(1), ico(1), sn(1), ha(1) pointer (piro, iro), (pico, ico), (pha, ha), (psn, sn) real a1(1), pivot(1) pointer (pa1, a1), (ppivot, pivot) common /MOD_GRAPH/ NONZ, NGRAPH common /MOD_Y1/ NN12, pha, psn, ifail common /MOD_Y2/ piro, pico, pa1, ppivot c----------------------------------------------------------- real aa(1) real rhs0(1), rhs1(1), rhs(1) real bound_rhs(1) real rhs_bc(1), rhs_bc0(1), sol(1), rhs_bc1(1) pointer (paa, aa) pointer (prhs0, rhs0), (prhs1, rhs1), (prhs, rhs) pointer (pbound_rhs, bound_rhs) pointer (prhs_bc, rhs_bc), (psol, sol), (prhs_bc0, rhs_bc0) pointer (prhs_bc1, rhs_bc1) real b_island(0:2), a_island(0:2,0:2) common /ISLAND_1/ prhs_bc0, psol, prhs0, prhs_bc1, ib, prhs1, prhs common /ISLAND_2/ b_island, a_island * ,i_min1,i_max1,j_min1,j_max1 common /MOD_MATRX/ paa, prhs_bc, pbound_rhs c-------------------------------------------------------------- real rtmp(1) integer ilst(1) pointer (prtmp, rtmp), (pilst, ilst) common /MOD_SPACE/ prtmp, pilst c-------------------------------------------------------------- c-------------------------------------------------------------- c new common blocks to be added also to model_input subroutine c-------------------------------------------------------------- character*80 f_bar common /baro_files/ n_bar, f_bar integer iflag(12), RM12_NN real aflag(12) common /y12m_input/ RM12_NN, aflag, iflag common /baro_input/ n_def_cor, mod_scheme, mod_solver, BAR_DELTA, * BAR_DSINK, ibar_key, nbaro, rayl c-------------------------------------------------------------- call.c/ 832169702 1572 1572 100444 64 ` #include int icpu_time_() { return (int)clock(); } comm_data.h/ 837198301 1572 1572 100444 3886 ` c--------------------------------------------------------------------------- dimension u(1), uc(1), fu(1), v(1), vc(1), fv(1), w(1), h(1), fh(1), * t(1), ft(1), sal(1), fsal(1), dens(1), * um(1),vm(1),wm(1),hm(1),tm(1),salm(1),densm(1), qm(1),trm(1), * taux(1), tauy(1), * q(1), sst(1), sss(1),ep(1), cld(1), dtx(1), dty(1), solr(1), * tclim(1), dclim(1), sclim(1),convn(1), hclim(1), pclim(1), * iox(1), mask(1), * fs(1), fhs(1), fhd(1), pgfx(1), pgfy(1), corx(1), cory(1), * xnl(1), ynl(1), vertx(1), verty(1), rhsx(1), rhsy(1), * crhsx(1), crhsy(1), * dept(1), ubar(1), vbar(1), bdiv(1), uforc(1), vforc(1), * psi(1),zfu(1),zfv(1), * blcf(1), im2d(1), ixd(1),tp(1), tr(1), ftr(1), qr(1), qb(1), * wnd(1), * isk(1),iyk(1),nzi(1),isxk(1),isyk(1),nzi_b(1) pointer (p_u,u),(p_uc,uc),(p_fu, fu), (p_v,v),(p_vc,vc),(p_fv,fv), * (p_w,w),(p_h,h),(p_fh,fh), * (p_t,t),(p_ft,ft), (p_sal,sal),(p_fsal,fsal),(p_dens, dens), * (p_um,um),(p_vm,vm),(p_wm,wm),(p_hm,hm),(p_tm,tm), * (p_densm,densm),(p_salm,salm),(p_qm,qm),(p_trm,trm), * (p_taux, taux), (p_tauy, tauy), * (p_q,q), (p_sst,sst), (p_sss,sss),(p_ep,ep), (p_cld,cld), * (p_dtx,dtx),(p_dty,dty),(p_solr,solr), * (p_dclim,dclim), (p_tclim,tclim), (p_sclim,sclim),(p_convn,convn), * (p_hclim,hclim), (p_pclim,pclim), * (p_iox, iox), (p_mask, mask), * (p_fhs, fhs), (p_fs, fs),(p_fhd, fhd),(p_pgfx, pgfx), * (p_pgfy, pgfy),(p_corx,corx),(p_cory,cory), * (p_xnl, xnl),(p_ynl,ynl), * (p_vertx, vertx),(p_verty,verty), * (p_rhsx, rhsx),(p_rhsy,rhsy), * (p_crhsx, crhsx),(p_crhsy,crhsy), * (p_dept,dept),(p_ubar,ubar),(p_vbar,vbar),(p_bdiv,bdiv), * (p_uforc,uforc),(p_vforc,vforc), * (p_psi, psi),(p_zfu,zfu),(p_zfv,zfv), * (p_blcf, blcf), (p_im2d, im2d), (p_ixd, ixd), * (p_tp, tp), (p_tr, tr),(p_ftr, ftr), (p_qr,qr),(p_qb,qb), * (p_wnd,wnd), * (p_isk,isk),(p_iyk,iyk),(p_nzi,nzi),(p_nzi_b,nzi_b), * (p_isxk,isxk),(p_isyk,isyk) common /data_addr/ p_u, p_uc, p_fu, p_v, p_vc, p_fv, p_w, p_h, p_fh, * p_t, p_ft, p_sal, p_fsal, p_dens, * p_um,p_vm,p_wm,p_hm,p_tm,p_salm,p_densm,p_qm,p_trm, * p_taux, p_tauy, p_convn, * p_q, p_sst,p_sss,p_ep,p_cld,p_dtx,p_dty,p_solr, * p_dclim, p_tclim, p_sclim, p_hclim, p_pclim, * p_iox, p_mask, p_fs, p_fhs, p_fhd,p_pgfx,p_pgfy,p_corx,p_cory, * p_xnl,p_ynl,p_vertx,p_verty,p_rhsx,p_rhsy,p_crhsx,p_crhsy, * p_dept, p_ubar,p_vbar,p_bdiv,p_uforc,p_vforc,p_psi, * p_zfu,p_zfv,p_blcf, p_im2d, p_ixd, * p_tp,p_tr,p_ftr, p_qr, p_qb,p_wnd, * p_isk,p_iyk,p_nzi,p_isxk,p_isyk,p_nzi_b dimension xm(1),ym(1), xp(1),yp(1), xd(1),yd(1) pointer (p_xm,xm),(p_ym,ym),(p_xp,xp),(p_yp,yp),(p_xd,xd),(p_yd,yd) common /grid_addr/ p_xm, p_ym, p_xp, p_yp, p_xd, p_yd c---------------------------------------------------------------------------- dimension wint(1),psiw(1) pointer (p_wint,wint),(p_psiw,psiw) common /mosf/ p_wint, p_psiw c---------------------------------------------------------------------------- dimension f(1), emx(1), emy(1), emxy(1), emx2(1), emy2(1), area(1) dimension sponge(1), relax(1) pointer (p_f, f), (p_emx, emx), (p_emy, emy), (p_emxy, emxy), * (p_emx2, emx2), (p_emy2, emy2), (p_area, area) * , (p_relax, relax), (p_sponge, sponge) common/data_geom/ p_f,p_emx,p_emy,p_emxy,p_emx2,p_emy2,p_area * ,p_relax,p_sponge comm_new.h/ 839445546 1572 1572 100444 3080 ` c- begin of comm_new.h -------------------------------------------------------- logical use_salt, use_trac, mix_bc_s, mix_bc_b, * save_mean, first_step common /new_logic/ use_salt, use_trac, mix_bc_s, mix_bc_b, * save_mean, first_step common /new_param/ itemp, isalt, imix, ntrac, * TEMP_BOT, SALT_BOT, SITUD_BOT, POTND_BOT common /new_dims/ npt1, npt2, npt3, npt4, npten c character*80 fbi, fbo, fbt, fbwnd,fbtem,fbsal,fbsst,fbevp,fbsss, * fbdep,fbcld,fbslr, fbmap,fbhcl, finp,fout, ftios,fcpu, * fbpsi common /new_files/ n_in,n_out, n_wnd,n_tem,n_sal,n_sst,n_sss,n_psi, * n_slr, n_evp, n_dep, n_cld, n_map, n_hcl, * fbi, fbo, fbt, fbwnd,fbtem,fbsal,fbsst,fbevp,fbsss, * fbdep,fbcld,fbslr, fbmap,fbhcl,finp,fout,ftios,fcpu, * fbpsi c common /new_io/ iout, iou, iov, iow, ioh, iot, ios, ioe, iotr, lev_err common /new_time/ dlt, DLT_MIX, steps_per_day, * iday_curr, enso_start, enso_scale common /new_misc/ iglob,irest, initt,inits,initq,initep,initb,mbot_bc, * icl_h,icl_htop,icl_ts,icl_rlx,icl_psi, * clm_coef,clm_no,clm_so,ksponge,krelax,clm_psi, * initbt,ipre,itau_cos,isolrp * ,temp_coef common /new_baro/ ibaro, dep_min, dep_max common /new_shap/ nordu, nordh, mshx, mshy, mshh, shap_vel_cnst, shap_scl_cnst common /dake_mix/ cm_mix,cn_mix, hmin_mix,hmax_mix, * ric1_mix,ric2_mix, iuse_gam, gam1_mix, gam2_mix, * mix_wtop, iwnd_mix common /new_forc/ idf_dp, idf_cld, idf_slr, cld_tscl, slr_tscl, * idf_tx, idf_ty, ltau,itau,ntau,p_ttau, tau_tscl, lpsi, * idf_sst,idf_sss, lsst,isst,nsst,p_tsst, sst_tscl, isss, * idf_evp, levp,ievp,nevp,p_tevp, evp_tscl, * idf_t,idf_s,idf_hcl, lclm,iclm, ntclm,p_tclm, nzclm,p_zclm,clm_tscl, * idf_psi, ntpsi, ipsi, psi_tscl dimension ttau(1), tsst(1), tevp(1), tclm(1), zclm(1), tpsi(1) pointer (p_ttau,ttau), (p_tsst,tsst), (p_tevp,tevp), * (p_tclm,tclm), (p_zclm,zclm), (p_tpsi,tpsi) common /new_forcgr/ idatgr, mpack,mseg, mxp,myp, msx,msy common /new_hfxevp/ trans_coef, QCON, rlx_time, solr_gamma, TATM, SATM dimension hsave(1) pointer (p_hsave, hsave) common /new_energy/ iherr, p_hsave,ekf1,epf1,hcf1,wcf1,vlf1 character*80 fwsp, fuwd, fvwd, fah, fat, fprec common /pbl_files/ n_wsp, n_uwd, n_vwd, n_ah, n_at, n_prec, * idf_wsp, idf_uwd, idf_vwd, idf_ah, idf_at, idf_prec, * fwsp, fuwd, fvwd, fah, fat, fprec common /new_vert/ iv_top c- end of comm_new.h -------------------------------------------------------- comm_para.h/ 836921779 1572 1572 100444 790 ` c************************************************************************ parameter (MAXNB = 2000, MXBDY = 9000, MAXSP = 9000, * MAXSID = 500, MAXXS = 50, MAXNZ = 30, MAXSND = 6800) c parameter (MINSEG = 4) parameter (MPTEN = 6) c parameter (D2SEC = 86400.) parameter (GRAVTY = 9.8) c parameter (TALPHA = 2.55e-4) parameter (SIGMA0 = 27.) parameter (TCOEF = TALPHA * (1000. + SIGMA0)) common/para/MINSEG c c (if MAXNZ and MAXXS are changed here, they must also c be changed in all routines containing blocks VERT and STRECH.) c c MINSEG = the minimum number of consecutive ocean grid points as c required by routine dfdx. c************************************************************************ comm_pbl.h/ 832169702 1572 1572 100444 1617 ` c------------------------------------------------------------------------------- c.........in order to include this file, one must have NPT,NX,NY among arguments dimension wnsp(npt,1), uwnd(npt,1), vwnd(npt,1), * ahum(nx*ny,1), atem(nx*ny,1), amhum(nx*ny), amth(nx*ny) pointer (p_wnsp, wnsp),(p_uwnd, uwnd),(p_vwnd, vwnd), * (p_ahum, ahum),(p_atem, atem),(p_amhum, amhum),(p_amth, amth) c------------------------------------------------------------------------------- c------------------------------------------------------------------------------- dimension up(nx,ny), vp(nx,ny), * thv(nx,ny), the(nx,ny), thve(nx,ny), thvs(nx,ny), * pnuxp(nx,ny), pnuyp(nx,ny), qe(nx,ny), qs(nx,ny), * c0(nx,ny), dx(nx,ny), dy(ny), lsm(nx,ny) pointer (p_up, up), (p_vp, vp), * (p_thv,thv), (p_the,the), (p_thve,thve), (p_thvs,thvs), * (p_pnuxp,pnuxp), (p_pnuyp,pnuyp), (p_qe,qe), (p_qs,qs), * (p_c0,c0), (p_dx,dx), (p_dy, dy), (p_lsm, lsm) common /pbl_data/ p_up, p_vp, p_thv, p_the, p_thve, p_thvs, * p_pnuxp, p_pnuyp, p_qe, p_qs, p_c0, p_dx, p_dy, p_lsm, * p_wnsp, p_uwnd, p_vwnd, p_ahum, p_atem, p_amhum, p_amth c------------------------------------------------------------------------------- common /pbl_param/ pbl_pnu,pbl_delta,pbl_pml,pbl_depth,pbl_betav,pbl_grad, * nstep_pbl, ipbl_advec, ipbl_jsta,ipbl_jend, pbl_south,pbl_north,pbl_wmin c------------------------------------------------------------------------------- dens.h/ 832169702 1572 1572 100444 17010 ` /*****************************************************************/ #if defined(SDENS12) #if defined(DOUBLE_PRES) implicit double precision (a-c) c Error norm0(max) = 7.4428 c Error norm2(rms) = 1.1234 #if defined(SIGMA) c in situ SIGMA (rho-1000 kg/m^3) density as a function of c in situ temperature, salinity & pressure. data a0 / -1.5843939931764703E-01 / data a1 / 4.7270144711352193E-02 / data a2 / -2.9397698827436812E-03 / data a3 / -7.4739134414726020E-03 / data a4 / 3.3785607358454141E-05 / data a5 / 4.2345159659840616E-07 / data a6 / 3.5492171626440836E-05 / data a7 / 8.0760604501362962E-01 / data a8 / -7.5343589902807757E-06 / data a9 / 5.0204028880325237E-03 / data a10 / -2.8190006182690186E-05 / data a11 / -4.8593042192581616E-08 / data a12 / 4.9424959288401026E-10 / #else c in situ density (kg/m^3) as a function of c in situ temperature, salinity & pressure. data a0 / 9.9984156060068153E+02 / data a1 / 4.7270144711414658E-02 / data a2 / -2.9397698827454119E-03 / data a3 / -7.4739134414735257E-03 / data a4 / 3.3785607358473184E-05 / data a5 / 4.2345159659804902E-07 / data a6 / 3.5492171626444934E-05 / data a7 / 8.0760604501365325E-01 / data a8 / -7.5343589902855958E-06 / data a9 / 5.0204028880326863E-03 / data a10 / -2.8190006182677018E-05 / data a11 / -4.8593042192585249E-08 / data a12 / 4.9424959288174381E-10 / #endif #else #if defined(SIGMA) data a0 / -1.584394E-01 / data a1 / 4.727015E-02 / data a2 / -2.939770E-03 / data a3 / -7.473913E-03 / data a4 / 3.378561E-05 / data a5 / 4.234516E-07 / data a6 / 3.549217E-05 / data a7 / 8.076060E-01 / data a8 / -7.534359E-06 / data a9 / 5.020403E-03 / data a10 / -2.819001E-05 / data a11 / -4.859304E-08 / data a12 / 4.942496E-10 / #else data a0 / 9.998416E+02 / data a1 / 4.727015E-02 / data a2 / -2.939770E-03 / data a3 / -7.473913E-03 / data a4 / 3.378561E-05 / data a5 / 4.234516E-07 / data a6 / 3.549217E-05 / data a7 / 8.076060E-01 / data a8 / -7.534359E-06 / data a9 / 5.020403E-03 / data a10 / -2.819001E-05 / data a11 / -4.859304E-08 / data a12 / 4.942496E-10 / #endif #endif /*****************************************************************/ #elif defined(PDENS12) #if defined(DOUBLE_PRES) implicit double precision (a-c) c Error norm0(max) = 7.7819 c Error norm2(rms) = 0.97816 #if defined(SIGMA) c in situ SIGMA (rho-1000 kg/m^3) density as a function of c potential temperature, salinity & pressure. data a0 / -1.5504924602274576E-01 / data a1 / 4.7242360502523430E-02 / data a2 / -2.9355135788240534E-03 / data a3 / -7.4801638387312063E-03 / data a4 / 3.3806262972047482E-05 / data a5 / 3.6995743312311981E-07 / data a6 / 3.5589087697667882E-05 / data a7 / 8.0747615263133187E-01 / data a8 / -8.0022984647741619E-06 / data a9 / 5.0377429128316340E-03 / data a10 / -2.9566247219663237E-05 / data a11 / -5.1678728359398036E-08 / data a12 / 3.7388128423166246E-10 / #else c in situ density (kg/m^3) as a function of c potential temperature, salinity & pressure. data a0 / 9.9984495075397717E+02 / data a1 / 4.7242360502556559E-02 / data a2 / -2.9355135788249624E-03 / data a3 / -7.4801638387318654E-03 / data a4 / 3.3806262972062488E-05 / data a5 / 3.6995743312330793E-07 / data a6 / 3.5589087697669534E-05 / data a7 / 8.0747615263133631E-01 / data a8 / -8.0022984647632515E-06 / data a9 / 5.0377429128311419E-03 / data a10 / -2.9566247219662127E-05 / data a11 / -5.1678728359375112E-08 / data a12 / 3.7388128423099962E-10 / #endif #else #if defined(SIGMA) data a0 / -1.550492E-01 / data a1 / 4.724236E-02 / data a2 / -2.935514E-03 / data a3 / -7.480164E-03 / data a4 / 3.380626E-05 / data a5 / 3.699574E-07 / data a6 / 3.558909E-05 / data a7 / 8.074762E-01 / data a8 / -8.002298E-06 / data a9 / 5.037743E-03 / data a10 / -2.956625E-05 / data a11 / -5.167873E-08 / data a12 / 3.738813E-10 / #else data a0 / 9.998450E+02 / data a1 / 4.724236E-02 / data a2 / -2.935514E-03 / data a3 / -7.480164E-03 / data a4 / 3.380626E-05 / data a5 / 3.699574E-07 / data a6 / 3.558909E-05 / data a7 / 8.074762E-01 / data a8 / -8.002298E-06 / data a9 / 5.037743E-03 / data a10 / -2.956625E-05 / data a11 / -5.167873E-08 / data a12 / 3.738813E-10 / #endif #endif /*****************************************************************/ #elif defined(SDENS14) #if defined(DOUBLE_PRES) implicit double precision (a-c) c Error norm0(max) = 5.1297 c Error norm2(rms) = 0.88617 #if defined(SIGMA) c in situ SIGMA (rho-1000 kg/m^3) density as a function of c in situ temperature, salinity & pressure. data b0 / -1.5457113356963887E-01 / data b1 / 4.8274161492139198E-02 / data b2 / -2.9293422042122445E-03 / data b3 / -7.8297202416628062E-03 / data b4 / 3.3396251597915589E-05 / data b5 / 5.0305514971841871E-07 / data b6 / 5.9242306039765049E-05 / data b7 / -1.8761935916554911E-09 / data b8 / -4.4004698349207185E-07 / data b9 / 8.0754330842184014E-01 / data b10 / -7.5199970104093241E-06 / data b11 / 5.0192251646580583E-03 / data b12 / -2.8691551307377988E-05 / data b13 / -4.8525837979105048E-08 / data b14 / 5.2821790042401373E-10 / #else c in situ density (kg/m^3) as a function of c in situ temperature, salinity & pressure. data b0 / 9.9984542886643077E+02 / data b1 / 4.8274161492148248E-02 / data b2 / -2.9293422042124026E-03 / data b3 / -7.8297202416636828E-03 / data b4 / 3.3396251597949877E-05 / data b5 / 5.0305514971833975E-07 / data b6 / 5.9242306039746903E-05 / data b7 / -1.8761935917385809E-09 / data b8 / -4.4004698349169419E-07 / data b9 / 8.0754330842182504E-01 / data b10 / -7.5199970104007531E-06 / data b11 / 5.0192251646578691E-03 / data b12 / -2.8691551307371017E-05 / data b13 / -4.8525837979127866E-08 / data b14 / 5.2821790042306595E-10 / #endif #else #if defined(SIGMA) data b0 / -1.545711E-01 / data b1 / 4.827416E-02 / data b2 / -2.929342E-03 / data b3 / -7.829720E-03 / data b4 / 3.339625E-05 / data b5 / 5.030552E-07 / data b6 / 5.924231E-05 / data b7 / -1.876194E-09 / data b8 / -4.400470E-07 / data b9 / 8.075433E-01 / data b10 / -7.519997E-06 / data b11 / 5.019225E-03 / data b12 / -2.869155E-05 / data b13 / -4.852584E-08 / data b14 / 5.282179E-10 / #else data b0 / 9.998455E+02 / data b1 / 4.827416E-02 / data b2 / -2.929342E-03 / data b3 / -7.829720E-03 / data b4 / 3.339625E-05 / data b5 / 5.030552E-07 / data b6 / 5.924231E-05 / data b7 / -1.876194E-09 / data b8 / -4.400470E-07 / data b9 / 8.075433E-01 / data b10 / -7.519997E-06 / data b11 / 5.019225E-03 / data b12 / -2.869155E-05 / data b13 / -4.852584E-08 / data b14 / 5.282179E-10 / #endif #endif /*****************************************************************/ #elif defined(PDENS14) #if defined(DOUBLE_PRES) implicit double precision (a-c) c Error norm0(max) = 4.7042 c Error norm2(rms) = 0.65810 #if defined(SIGMA) c in situ SIGMA (rho-1000 kg/m^3) density as a function of c potential temperature, salinity & pressure. data b0 / -1.5099543208979131E-01 / data b1 / 4.8293064514940597E-02 / data b2 / -2.9238713403522172E-03 / data b3 / -7.8571184248837324E-03 / data b4 / 3.3385891265010374E-05 / data b5 / 4.6172868001366538E-07 / data b6 / 6.0751904648027190E-05 / data b7 / -2.2842291682861128E-09 / data b8 / -4.6613942915278920E-07 / data b9 / 8.0741085100371474E-01 / data b10 / -7.9879608235234487E-06 / data b11 / 5.0365498988416534E-03 / data b12 / -3.0158261301038717E-05 / data b13 / -5.1618517301301070E-08 / data b14 / 4.2164188192037137E-10 / #else c in situ density (kg/m^3) as a function of c potential temperature, salinity & pressure. data b0 / 9.9984900456791012E+02 / data b1 / 4.8293064514949266E-02 / data b2 / -2.9238713403523647E-03 / data b3 / -7.8571184248856917E-03 / data b4 / 3.3385891265004397E-05 / data b5 / 4.6172868001376228E-07 / data b6 / 6.0751904648172017E-05 / data b7 / -2.2842291682672226E-09 / data b8 / -4.6613942915550268E-07 / data b9 / 8.0741085100371918E-01 / data b10 / -7.9879608235240731E-06 / data b11 / 5.0365498988416810E-03 / data b12 / -3.0158261301038322E-05 / data b13 / -5.1618517301306345E-08 / data b14 / 4.2164188191996903E-10 / #endif #else #if defined(SIGMA) data b0 / -1.509954E-01 / data b1 / 4.829307E-02 / data b2 / -2.923871E-03 / data b3 / -7.857119E-03 / data b4 / 3.338589E-05 / data b5 / 4.617287E-07 / data b6 / 6.075190E-05 / data b7 / -2.284229E-09 / data b8 / -4.661394E-07 / data b9 / 8.074108E-01 / data b10 / -7.987961E-06 / data b11 / 5.036550E-03 / data b12 / -3.015826E-05 / data b13 / -5.161852E-08 / data b14 / 4.216419E-10 / #else data b0 / 9.998490E+02 / data b1 / 4.829307E-02 / data b2 / -2.923871E-03 / data b3 / -7.857119E-03 / data b4 / 3.338589E-05 / data b5 / 4.617287E-07 / data b6 / 6.075190E-05 / data b7 / -2.284229E-09 / data b8 / -4.661394E-07 / data b9 / 8.074108E-01 / data b10 / -7.987961E-06 / data b11 / 5.036550E-03 / data b12 / -3.015826E-05 / data b13 / -5.161852E-08 / data b14 / 4.216419E-10 / #endif #endif /*****************************************************************/ #elif defined(SDENS17) #if defined(DOUBLE_PRES) implicit double precision (a-c) c Error norm0(max) = 3.7240 c Error norm2(rms) = 0.71822 #if defined(SIGMA) c in situ SIGMA (rho-1000 kg/m^3) density as a function of c in situ temperature, salinity & pressure. data c0 / -1.6243434496636450E-01 / data c1 / 5.7535908559764719E-02 / data c2 / -3.1837995831724064E-03 / data c3 / -8.6797786092135336E-03 / data c4 / 5.4648837967931438E-05 / data c5 / 6.5185416868478354E-07 / data c6 / 8.1826851053890479E-05 / data c7 / -4.4858245406792951E-07 / data c8 / -7.6560639600702460E-09 / data c9 / -5.6615940292929387E-07 / data c10 / 8.0777616156676312E-01 / data c11 / -7.9776236744412338E-06 / data c12 / 1.7675041439612339E-07 / data c13 / 5.0351140611567597E-03 / data c14 / -3.5488739799483131E-05 / data c15 / -4.8509877279023854E-08 / data c16 / 6.6352773503588382E-10 / data c17 / -2.7658618545499495E-11 / #else c in situ density (kg/m^3) as a function of c in situ temperature, salinity & pressure. data c0 / 9.9983756565503369E+02 / data c1 / 5.7535908559893584E-02 / data c2 / -3.1837995831754497E-03 / data c3 / -8.6797786092314073E-03 / data c4 / 5.4648837968225851E-05 / data c5 / 6.5185416868858991E-07 / data c6 / 8.1826851054623155E-05 / data c7 / -4.4858245407464298E-07 / data c8 / -7.6560639602356630E-09 / data c9 / -5.6615940293851219E-07 / data c10 / 8.0777616156676277E-01 / data c11 / -7.9776236744555211E-06 / data c12 / 1.7675041439849216E-07 / data c13 / 5.0351140611571949E-03 / data c14 / -3.5488739799566748E-05 / data c15 / -4.8509877279009829E-08 / data c16 / 6.6352773503562794E-10 / data c17 / -2.7658618546087971E-11 / #endif #else #if defined(SIGMA) data c0 / -1.624343E-01 / data c1 / 5.753591E-02 / data c2 / -3.183800E-03 / data c3 / -8.679778E-03 / data c4 / 5.464884E-05 / data c5 / 6.518542E-07 / data c6 / 8.182685E-05 / data c7 / -4.485825E-07 / data c8 / -7.656064E-09 / data c9 / -5.661594E-07 / data c10 / 8.077762E-01 / data c11 / -7.977624E-06 / data c12 / 1.767504E-07 / data c13 / 5.035114E-03 / data c14 / -3.548874E-05 / data c15 / -4.850988E-08 / data c16 / 6.635277E-10 / data c17 / -2.765862E-11 / #else data c0 / 9.998376E+02 / data c1 / 5.753591E-02 / data c2 / -3.183800E-03 / data c3 / -8.679778E-03 / data c4 / 5.464884E-05 / data c5 / 6.518542E-07 / data c6 / 8.182685E-05 / data c7 / -4.485825E-07 / data c8 / -7.656064E-09 / data c9 / -5.661594E-07 / data c10 / 8.077762E-01 / data c11 / -7.977624E-06 / data c12 / 1.767504E-07 / data c13 / 5.035114E-03 / data c14 / -3.548874E-05 / data c15 / -4.850988E-08 / data c16 / 6.635277E-10 / data c17 / -2.765862E-11 / #endif #endif /*****************************************************************/ #elif defined(PDENS17) #if defined(DOUBLE_PRES) implicit double precision (a-c) c Error norm0(max) = 2.8225 c Error norm2(rms) = 0.52139 #if defined(SIGMA) c in situ SIGMA (rho-1000 kg/m^3) density as a function of c potential temperature, salinity & pressure. data c0 / -1.5862652198103819E-01 / data c1 / 5.7207239651872372E-02 / data c2 / -3.1733586873196486E-03 / data c3 / -8.6709261650891846E-03 / data c4 / 5.4773992446508810E-05 / data c5 / 5.5410488944578117E-07 / data c6 / 8.1300196759789216E-05 / data c7 / -4.5995132105162293E-07 / data c8 / -6.0525121543258126E-09 / data c9 / -5.4999448818125165E-07 / data c10 / 8.0763554004703426E-01 / data c11 / -8.3777800126292660E-06 / data c12 / 1.6315692381057324E-07 / data c13 / 5.0500721785257240E-03 / data c14 / -3.6208523725344514E-05 / data c15 / -5.1597455716244535E-08 / data c16 / 4.9863336832618436E-10 / data c17 / -1.7971906682917162E-11 / #else c in situ density (kg/m^3) as a function of c potential temperature, salinity & pressure. data c0 / 9.9984137347801924E+02 / data c1 / 5.7207239651807189E-02 / data c2 / -3.1733586873184598E-03 / data c3 / -8.6709261650839319E-03 / data c4 / 5.4773992446462695E-05 / data c5 / 5.5410488944324889E-07 / data c6 / 8.1300196759551894E-05 / data c7 / -4.5995132105069007E-07 / data c8 / -6.0525121542334305E-09 / data c9 / -5.4999448817739962E-07 / data c10 / 8.0763554004702662E-01 / data c11 / -8.3777800126130657E-06 / data c12 / 1.6315692380962662E-07 / data c13 / 5.0500721785252249E-03 / data c14 / -3.6208523725296442E-05 / data c15 / -5.1597455716262068E-08 / data c16 / 4.9863336832462135E-10 / data c17 / -1.7971906682702998E-11 / #endif #else #if defined(SIGMA) data c0 / -1.586265E-01 / data c1 / 5.720724E-02 / data c2 / -3.173359E-03 / data c3 / -8.670926E-03 / data c4 / 5.477399E-05 / data c5 / 5.541049E-07 / data c6 / 8.130020E-05 / data c7 / -4.599513E-07 / data c8 / -6.052512E-09 / data c9 / -5.499945E-07 / data c10 / 8.076355E-01 / data c11 / -8.377780E-06 / data c12 / 1.631569E-07 / data c13 / 5.050072E-03 / data c14 / -3.620852E-05 / data c15 / -5.159746E-08 / data c16 / 4.986334E-10 / data c17 / -1.797191E-11 / #else data c0 / 9.998414E+02 / data c1 / 5.720724E-02 / data c2 / -3.173359E-03 / data c3 / -8.670926E-03 / data c4 / 5.477399E-05 / data c5 / 5.541049E-07 / data c6 / 8.130020E-05 / data c7 / -4.599513E-07 / data c8 / -6.052512E-09 / data c9 / -5.499945E-07 / data c10 / 8.076355E-01 / data c11 / -8.377780E-06 / data c12 / 1.631569E-07 / data c13 / 5.050072E-03 / data c14 / -3.620852E-05 / data c15 / -5.159746E-08 / data c16 / 4.986334E-10 / data c17 / -1.797191E-11 / #endif #endif #endif /*****************************************************************/ dyn_baro.f/ 839513370 1572 1572 100444 9815 ` c$Source$ c$Author$ c$Revision$ c$Date$ c$State$ c--------------------------------------------------------- subroutine baro_sum (npt, nz, nzi_b, uc, vc, ubar, vbar) c--------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension uc(npt,nz),vc(npt,nz), ubar(npt), vbar(npt), nzi_b(npt) do i = 1, npt ubar(i) = uc(i,1) vbar(i) = vc(i,1) enddo do i = 1, npt do k = 2, nzi_b(i) ubar(i) = ubar(i) + uc(i,k) vbar(i) = vbar(i) + vc(i,k) enddo enddo return end subroutine baro_scale (npt, ubar, vbar, dept) c--------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension ubar(1), vbar(1), dept(1) do i = 1, npt depi = 1./dept(i) ubar(i) = depi* ubar(i) vbar(i) = depi* vbar(i) enddo return end subroutine baro_tau (npt, uforc, vforc, taux, tauy) c--------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension uforc(npt), vforc(npt), taux(npt), tauy(npt) include 'comm_new.h' do i = 1, npt uforc(i) = taux(i) vforc(i) = tauy(i) enddo return end subroutine baro_comp (npt,dnt,abi,bi,nbaro,uforc,vforc,tfu,tfv * ,zfu,zfv,dept) c----------------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension uforc(npt),vforc(npt),tfu(npt),tfv(npt),zfu(npt),zfv(npt),dept(npt) b_d2 = bi / (dnt * real(nbaro)) do i = 1, npt depi = dept(i) dzu = zfu(i) - depi* tfu(i) dzv = zfv(i) - depi* tfv(i) uforc(i) = uforc(i) - b_d2*dzu vforc(i) = vforc(i) - b_d2*dzv zfu(i) = abi * dzu zfv(i) = abi * dzv enddo return end subroutine baro_rhs (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,snxk,snyk, * isyk,isk,mbc,lpbcwk,lpbcek,uu,vv,rhs,tp,dept) c------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch c include 'comm_para.h' common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz), * snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz), * lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz) dimension emx(1),emy(1),emxy(1),dept(npt),uu(npt),vv(npt),rhs(npt), * tp(npt,3) do i = 1, npt depi = 1./dept(i) tp(i,3) = depi* uu(i) tp(i,2) = depi* vv(i) enddo nxk = nbxk(1) nyk = nbyk(1) nck = ncsk(1) npbk = npbck(1) nbu = 0 nbv = 0 call dfdx1(tp(1,2),tp,npt,nbu,nxk,nyk,nck,lxxk,lyxk, * snxk,npbk,lpbcwk,lpbcek) call dfdy1(tp(1,3),tp(1,2),npt,nbv,nyk,nxk,nck, * lyyk,lxyk,snyk,isyk) c.................rhs = -curl(forcing/depth) if (mgrid .ne. 2) then do i = 1, npt rhs(i) = emx(i)*tp(i,1) - emy(i)*tp(i,2) enddo else do i = 1, npt rhs(i) = emx(i)*tp(i,1) - emy(i)*tp(i,2) - emxy(i)*tp(i,3) enddo endif return end subroutine curl_of_psi (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,snxk,snyk, * isyk,isk,mbc,lpbcwk,lpbcek,psi,sfu,sfv,tp,dept) c------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz), * snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz), * lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz) dimension emx(npt),emy(npt),emxy(npt),dept(npt), * sfu(npt),sfv(npt),psi(npt),tp(npt,2) k = 1 nxk = nbxk(k) nyk = nbyk(k) nck = ncsk(k) npbk = npbck(k) nbu = 0 nbv = 0 call dfdy1(psi,tp(1,2),npt,nbv,nyk,nxk,nck,lyyk,lxyk,snyk,isyk) call dfdx1(psi,tp,npt,nbu,nxk,nyk,nck,lxxk,lyxk, * snxk,npbk,lpbcwk,lpbcek) do i = 1, npt depi = 1./dept(i) sfu(i) = -emy(i)*tp(i,2)*depi sfv(i) = emx(i)*tp(i,1)*depi enddo return end subroutine baro_updat(npt,nz,nzi,h,uc,vc,tfu,tfv,uforc,vforc,ubar,vbar) c------------------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension h(npt,nz),uc(npt,nz),vc(npt,nz), * tfu(npt),tfv(npt), * uforc(npt), vforc(npt), ubar(npt), vbar(npt), nzi(npt) do i = 1, npt do k = 1, nzi(i) hik = h(i,k) uc(i,k) = uc(i,k) + hik*(tfu(i) - ubar(i)) vc(i,k) = vc(i,k) + hik*(tfv(i) - vbar(i)) enddo enddo do i = 1, npt uforc(i) = 0. vforc(i) = 0. ubar(i) = tfu(i) vbar(i) = tfv(i) enddo return end subroutine baro_div (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,mbc,lpbcwk,lpbcek,ubar,vbar,bdiv,tp,dept) c------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz), * snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz), * lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz) dimension emx(1),emy(1),emxy(1),dept(1), * ubar(1),vbar(1),bdiv(1),tp(npt,1) nbu = 0 nbv = 0 if(mbc.eq.1 .or. mbc.eq.4) nbu = 1 if(mbc.eq.1 .or. mbc.eq.3) nbv = 1 do i = 1, npt depi = dept(i) tp(i,3) = depi* ubar(i) tp(i,4) = depi* vbar(i) enddo nxk = nbxk(1) nyk = nbyk(1) nck = ncsk(1) npbk = npbck(1) call dfdy1(tp(1,4),tp(1,2),npt,nbv,nyk,nxk,nck,lyyk,lxyk,snyk,isyk) call dfdx1(tp(1,3),tp,npt,nbu,nxk,nyk,nck,lxxk,lyxk, * snxk,npbk,lpbcwk,lpbcek) if (mgrid .ne. 2) then do i = 1, npt depi = 1./dept(i) bdiv(i) = depi*(emx(i)*tp(i,1) + emy(i)*tp(i,2)) enddo else do i = 1, npt depi = 1./dept(i) bdiv(i) = depi*(emx(i)*tp(i,1) + emy(i)*tp(i,2) + emxy(i)*tp(i,4)) enddo endif return end c ------------------------------------------------------------------ subroutine baro_bcset(mbc,lxxk,lyyk,npt,u,v) c ------------------------------------------------------------------ c impose the u, v boundary conditions according to mbc. c c mbc = (input) type of boundary condition: c = 1; u(xb)=v(yb)=u(yb) = v(xb) = 0; no slip everywhere. c = 2; u(xb)=v(yb) = 0; no normal flow. c = 3; u(xb)=v(yb)=du(yb)/dy= v(xb) = 0; no slip at eastern c and western side walls; free slip along northern and c southern boundaries/steps, v=du/dy=0. c = 4; u(xb)=v(yb)=u(yb) = dv(xb)/dx= 0; no slip at northern c and southern; free slip along eastern and western c boundaries/steps, u=dv/dy=0. c c lxx = (input) nbx x-boundary plus ncs corner indices for a c regular or compressed x-sort. c lyy = (input) nby y-boundary plus ncs corner indices for a c regular or compressed x-sort. c npt = (input) number of field points/layer. c u,v = (input) fields. c = (output) fields with boundary conditions imposed. c implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) dimension lxxk(MXBDY,nz), lyyk(MXBDY,nz) dimension u(npt),v(npt) c c normal components are always zero at boundaries, u(xb)=v(yb)=0. c similarly, so is the along boundary derivative c du(xb)/dy = dv(yb)/dx = 0. c c the ncs corner points are part of the u/v-boundaries depending c on mbc. c mbc = 1; yes for u and v; du(yb)/dx = dv(xb)/dy = 0. c = 2; no for u and v. c = 3; no for u, yes for v; dv(xb)/dy = 0. c = 4; yes for u, no for v; du(yb)/dx = 0. c k = 1 do i = 1, nbxk(k) u(lxxk(i,k)) = 0. enddo do i = 1, nbyk(k) v(lyyk(i,k)) = 0. enddo if(mbc.eq.1 .or. mbc.eq.4) then do 30 i=1,nbyk(k)+ncsk(k) 30 u(lyyk(i,k)) = 0. endif c if(mbc.eq.1 .or. mbc.eq.3) then do 40 i=1,nbxk(k)+ncsk(k) 40 v(lxxk(i,k)) = 0. endif return c end of baro_bcset. end dyn_c.c/ 833824910 1572 1572 100444 14821 ` /************************************************************************** * This is a library to provide an *easy* * ASCII formatted input for FORTRAN/C. * * Senya Basin, 1994 ************************************************************************** $Source$ $Author$ $Revision$ $Date$ $State$ ***************************************************************************/ #include #include #include #define MAX_LINE 200 /******* FORTRAN-word to C-string pointer *******/ #define fw_to_cp(p) strtok(strdup(p)," ,;\t\n\r\f\v\b\000") #define get_word(p) strtok(p," \t[](){},;\n\r\f\v\b\000") #define get_arra(p) strtok(p," \t,;[({\n\r\f\v\b\000") #ifdef CRAY void INP_FILE (void *a1) {inp_file_(a1);} void INP_SECT (void *a1) {inp_sect_(a1);} void INP_VRNT (void *a1, *a2) {inp_vrnt_(a1,a2);} int INP_DEF (void *a1) {return inp_def_(a1);} int INP_INXT (void *a1) {return inp_inxt_(a1);} float INP_FNXT (void *a1) {return inp_fnxt_(a1);} int INP_WNXT (void *a1) {return inp_wnxt_(a1);} int INP_INT (void *a1, *a2) {return inp_int_(a1,a2);} float INP_FLT (void *a1, *a2) {return inp_flt_(a1,a2);} double INP_DBL (void *a1, *a2) {return inp_dbl_(a1,a2);} int INP_STR (void *a1, *a2, *a3) {return inp_str_(a1,a2,a3);} int INP_IARR(void *a1, *a2, *a3, *a4) {return inp_iarr_(a1,a2,a3,a4);} int INP_RARR(void *a1, *a2, *a3, *a4) {return inp_rarr_(a1,a2,a3,a4);} int INP_SARR(void *a1, *a2, *a3, *a4,*a5){return inp_sarr_(a1,a2,a3,a4,a5);} void INP_ANY (void *a1, *a2, *a3, *a4) {inp_any_(a1,a2,a3,a4);} float INP_DAYS (void *a1, *a2) {return inp_days_(a1,a2);} void INP_DATE (void *a,*b,*c,*d,*e,*f,*g) {inp_date_(a,b,c,d,e,f,g);} #endif static FILE *file, *ftrace; static char buff1[MAX_LINE], buff2[MAX_LINE], *psection; static long psec_pos; static int trace_input, search_in_main; static found(int usends, long offset, char *tag) /*******************************************************/ { char *word; fseek (file, offset, SEEK_SET); while (fgets(buff1, MAX_LINE, file)) { if (strchr("%#",*buff1) || !(word = get_word(strcpy(buff2, buff1))) ) continue; else if (usends && !strcasecmp(word, "end")) return 0; else if (*word == '+' && !strcmp(word+1, tag)) return 1; } return 0; } static tag_found (char *tag) /********************************************************/ { return ( (psec_pos && found(1, psec_pos, tag)) || (search_in_main && found(1, 0L, tag)) ); } void prtstop1 (mess, s1) char *mess, *s1; { fprintf (stderr, mess, s1); exit(-1); } void inp_file_(name) /************* Set the name of input FILE *********************/ char *name; { if (file) fclose(file); if ( !(file = fopen(fw_to_cp(name), "r"))) prtstop1 ("!!!inp_file: can't open <%s> for reading\n",fw_to_cp(name)); psection = NULL; psec_pos = 0L; search_in_main = 1; trace_input = 0; } void inp_trace_(name) /************* Set the name of trace file for output **********/ char *name; { if (ftrace) fclose(ftrace); if ( !(ftrace = fopen(fw_to_cp(name), "w+"))) prtstop1 ("!!!inp_trace: can't open <%s>.\n",fw_to_cp(name)); trace_input = 1; } void inp_vrnt_(name, num) /************* Set the VARIANT as a first place to search **/ char *name; int *num; { char *str, space[MAX_LINE]; str = fw_to_cp(name); strncpy (space, str, strlen(str)); if (*num >= 0) sprintf (space+strlen(space), "_%1u", *num); psection = strdup(space); if (found(0,0L,psection)) psec_pos = ftell(file); else psec_pos = 0L; search_in_main = 1; } void inp_sect_(name) /************* Set the SECTION as a first place to search **/ char *name; { char *str, space[MAX_LINE]; str = fw_to_cp(name); strncpy (space, str, strlen(str)); psection = strdup(space); if (found(0,0L,psection)) psec_pos = ftell(file); else psec_pos = 0L; search_in_main = 0; } int inp_int_(tag, dflt) /*********** input an INTEGER number ***********************/ char *tag; int *dflt; { int val; if (tag_found(fw_to_cp(tag))) { if ( sscanf(get_word(NULL), "%d", &val) != 1) prtstop1 ("!!!inp_int: can't read <%s>\n", fw_to_cp(tag)); } else val = *dflt; if (trace_input) fprintf(ftrace, "+%-20s %d\n", fw_to_cp(tag), val), fflush(ftrace); return val; } float inp_flt_(tag, dflt) /************* input a REAL/FLOAT number *******************/ char *tag; float *dflt; { float val; if (tag_found(fw_to_cp(tag))) { if ( sscanf (get_word(NULL), "%g", &val) != 1) prtstop1 ("!!!inp_flt: can't read <%s>\n", fw_to_cp(tag)); } else val = *dflt; if (trace_input) fprintf(ftrace, "+%-20s %g\n", fw_to_cp(tag), val), fflush(ftrace); return val; } double inp_dbl_(tag, dflt) /************** input a REAL*8/DOUBLE number ****************/ char *tag; double *dflt; { double val; if (tag_found(fw_to_cp(tag))) { if ( sscanf (get_word(NULL), "%lg", &val) != 1) prtstop1 ("!!!inp_flt: can't read <%s>\n", fw_to_cp(tag)); } else val = *dflt; if (trace_input) fprintf(ftrace, "+%-20s %lg\n", fw_to_cp(tag), val), fflush(ftrace); return val; } int inp_str_(tag, dflt, val) /************ input a 'CHARACTER' "string" *****************/ char *tag, *dflt, *val; { char *p1, *p2; if (tag_found(fw_to_cp(tag))) { if (!(p1 = strpbrk (buff1, "\"\'")) || !(p2 = strchr(p1+1,*p1)) ) prtstop1 ("!!!inp_str: error reading <%s>\n", fw_to_cp(tag)); *p2 = '\0'; strcpy(val, &p1[1]); } else if (val != dflt) strcpy(val, dflt); if (trace_input) fprintf(ftrace, "+%-20s \"%s\"\n", fw_to_cp(tag), val), fflush(ftrace); return strlen(val); } int inp_iarr_ (tag, ddim, darr, arr) /************* input an integer ARRAY ************************/ char *tag; int *ddim, *darr, *arr; { register int i; char *word; int dim; if (tag_found(fw_to_cp(tag))) { dim = 0; while ((word = get_arra(NULL)) || (fgets(buff1,MAX_LINE,file) && !strchr("%#",*buff1) && (word = get_arra(strcpy(buff2,buff1))) ) ) { if ( strpbrk(word, ")]}")) { sscanf(word, "%d", &arr[dim++]); break; } if ( sscanf(word, "%d", &arr[dim++]) != 1) prtstop1 ("!!!inp_iarr: can't read <%s>\n", fw_to_cp(tag)); } } else { dim = *ddim; if (arr != darr) for(i=0; i\n", fw_to_cp(tag)); } } else { dim = *ddim; if (arr != darr) for(i=0; islen ? slen : *dlen)); alen[dim] = strlen(&arr[*dlen*dim]); dim++; p1 = p2+1; } } else { dim = *ddim; if (arr != darr) for(i=0; i<*dlen*dim; i += *dlen) strncpy(&arr[i],&darr[i],*dlen); for(i = 0; i < dim;) alen[i] = ((len = strlen(&arr[*dlen*i])) > *dlen) ? *dlen : len; } if (trace_input) { fprintf(ftrace, "+%-20s [", fw_to_cp(tag)); for(len = 23,i = 0; i < dim;) { slen = strlen(&arr[*dlen*i]); if (slen > *dlen) slen = *dlen; fprintf(ftrace, "\"%*s\" ", slen, &arr[*dlen*i]); len += 2 + slen; if (!(++i%10) || len > 70) len = 23,fprintf(ftrace,"\n%23c",' '); } fprintf(ftrace, "]\n"), fflush(ftrace); } return dim; } void inp_any_(tag, dflt, val, type) /************ input *any* OBJECT ***********************/ char *tag, *type; void *dflt, *val; { int sz; char *p1, *p2, fmi[12], fmo[16], *word = strdup(fw_to_cp(type)); strcpy (fmi, "%d"); strcpy (fmo, "+%-20s %d"); if (!strcasecmp(word,"i") || !strcasecmp(word,"int") || !strcasecmp(word,"integer")) sz = sizeof(int); else if (!strcasecmp(word,"f") || !strcasecmp(word,"flt") || !strcasecmp(word,"float") || !strcasecmp(word,"r") || !strcasecmp(word,"real")) sz = sizeof(float),fmi[1] = 'g', fmo[8] = 'g'; else if (!strcasecmp(word,"d") || !strcasecmp(word,"dbl") || !strcasecmp(word,"dble") || !strcasecmp(word,"double")) sz = sizeof(double),strcpy(fmi,"%lg"), strcpy(fmo, "+%-20s %lg"); else if (!strcasecmp(word,"c") || !strcasecmp(word,"c1") || !strcasecmp(word,"char") || !strcasecmp(word,"char1") || !strcasecmp(word,"char*1") || !strcasecmp(word,"character")) sz = 1,fmi[1] = 'c', fmo[8] = 'c'; else if (!strcasecmp(word,"w") || !strcasecmp(word,"word")) sz = 0,fmi[1] = 's', fmo[8] = 's'; else if (!strcasecmp(word,"s") || !strcasecmp(word,"str") || !strcasecmp(word,"string")) sz = 0,fmi[1] = 's', strcpy(fmo, "+%-20s \"%s\""); else if (!strcasecmp(word,"i1") || !strcasecmp(word,"int1") || !strcasecmp(word,"integer*1")) sz = 1; else if (!strcasecmp(word,"i2") || !strcasecmp(word,"int2") || !strcasecmp(word,"integer*2")) sz = 2; else if (!strcasecmp(word,"i4") || !strcasecmp(word,"int4") || !strcasecmp(word,"integer4")|| !strcasecmp(word,"integer*4")) sz = 4; else if (!strcasecmp(word,"r4") || !strcasecmp(word,"real4") || !strcasecmp(word,"real*4")) sz = 4,fmi[1] = 'g', fmo[8] = 'g'; else if (!strcasecmp(word,"r8") || !strcasecmp(word,"real8") || !strcasecmp(word,"real*8")) sz = 8,strcpy(fmi,"%lg"), strcpy(fmo, "+%-20s %lg"); else if (!strcasecmp(word,"h") || !strcasecmp(word,"x") || !strcasecmp(word,"hex") || !strcasecmp(word,"hexadecimal")) sz = 1, strcpy(fmi,"%*2c%x"), strcpy(fmo, "+%-20s %#x"); else if (!strcasecmp(word,"o") || !strcasecmp(word,"oct") || !strcasecmp(word,"octal")) sz = 1, strcpy(fmi,"%*c%o"), strcpy(fmo, "+%-20s %#o"); else prtstop1("!!!inp_any: unknown format <%s>\n", word); if ( tag_found(fw_to_cp(tag)) ) { if (sz) { if (sscanf (get_word(NULL), fmi, val) != 1) prtstop1 ("!!!inp_any: can't read <%s>\n", fw_to_cp(tag)); } else { if (*word == 'w') { if (word = get_word(NULL)) strcpy(val, word); else prtstop1 ("!!!inp_any: can't read <%s>\n", fw_to_cp(tag)); } else { if (!(p1 = strpbrk (buff1, "\"\'")) || !(p2 = strchr(p1+1,*p1))) prtstop1 ("!!!inp_any: error reading <%s>\n", fw_to_cp(tag)); *p2 = '\0'; strcpy(val, &p1[1]); } } } else if (val != dflt) { if (sz) memmove(val, dflt, (size_t)sz); else { if (*word == 'w') strcpy (val, fw_to_cp(dflt)); else strcpy (val, dflt); } } if (trace_input) fprintf(ftrace, fmo, fw_to_cp(tag), val), fflush(ftrace); } float inp_days_(tag, dflt) /************* input a TIME in days *******************/ char *tag; float *dflt; { float old, val; char *word, *fmt = "day"; if (tag_found(fw_to_cp(tag))) { if ( sscanf(get_word(NULL), "%g", &old) == 1) word = get_word(NULL); else prtstop1 ("!!!inp_days: can't read <%s>\n", fw_to_cp(tag)); } else val = old = *dflt, word = fmt; switch (tolower(*word) ) { case 'h': val = old/24.; fmt = "hour"; break; case 'w': val = 7.*old; fmt = "week"; break; case 'm': val = (365./12.)*old; fmt = "month"; break; case 'y': val = 365.*old; fmt = "year"; break; default: val = old; break; } if (trace_input) fprintf(ftrace, "+%-20s %g %s%c\n", fw_to_cp(tag), old, fmt, ((int)old == 1 ?' ':'s')), fflush(ftrace); return val; } void inp_date_(tag, dm, dd, dy, im, id, iy) char *tag; int *dm, *dd, *dy, *im, *id, *iy; { if (tag_found(fw_to_cp(tag))) { if ( sscanf(get_word(NULL), "%d", im) != 1 || sscanf(get_word(NULL), "%d", id) != 1 || sscanf(get_word(NULL), "%d", iy) != 1 ) prtstop1 ("!!!inp_date: can't read <%s>\n", fw_to_cp(tag)); } else *im = *dm, *id = *dd, *iy = *dy; if (trace_input) fprintf(ftrace,"+%-20s %d %d %d\n",fw_to_cp(tag),*im,*id,*iy),fflush(ftrace); } int inp_def_ (tag) char *tag; { return tag_found(fw_to_cp(tag)); } int inp_inxt_(dflt) /*********** input a next INTEGER from the previous TAG ****/ int *dflt; { int val; if ( sscanf(get_word(NULL), "%d", &val) != 1) prtstop1 ("!!!inp_inxt: can't read <%s>\n", buff1); else val = *dflt; return val; } float inp_fnxt_(dflt) /*********** input a next FLOAT from the previous TAG ****/ float *dflt; { float val; if ( sscanf(get_word(NULL), "%g", &val) != 1) prtstop1 ("!!!inp_fnxt: can't read <%s>\n", buff1); else val = *dflt; return val; } int inp_wnxt_ (val) /************* read a next *word* form the file ************************/ char *val; { char *word; return ((word = get_word(NULL)) || (fgets(buff1,MAX_LINE,file) && !strchr("%#",*buff1) && (word = get_word(strcpy(buff2,buff1))) ) ) ? strlen(strcpy(val,word)) : 0; } dyn_dens.f/ 839513370 1572 1572 100444 40486 ` function dens_unesco (temp, sal, pres) c-------------------------------------------- real*8 rh, rh0 ccccccccccccccccccccccccccccccccccccccccccccccc c Gilles's variant: c situ = theta (pres, temp, sal, 0.) c then, for insitu dens (for poten. dens pres = 0.): c call dens_eos (pres, situ, sal, rh0, rh) c dens_unesco = 1.e3 * real(rh - 1.d0) c c "sigth" variant: c call dens_eos (pres, thet, sal, rh0, rh) c dens_unesco = 1.e3 * real(rh0 - 1.d0) ccccccccccccccccccccccccccccccccccccccccccccccc call dens_eos (pres, temp, sal, rh0, rh) dens_unesco = 1.e3 * real(rh - 1.d0) return end function sdens_pnt (temp, sal, pres) c------------------------------------------------- include 'comm_para.h' include 'comm_new.h' if (isalt .eq. 1) then sdens_pnt = SIGMA0 - TCOEF * (temp - TEMP_BOT) elseif (isalt .eq. 2) then sdens_pnt = pdens1 (temp) elseif (isalt .eq. 3) then sdens_pnt = pdens4 (temp, sal, pres) elseif (isalt .eq. 4) then sdens_pnt = pdens12 (temp, sal, pres) elseif (isalt .eq. 5) then sdens_pnt = pdens17 (temp, sal, pres) elseif (isalt .eq. 6) then situ = theta_eos (pres, temp, sal, 0.) sdens_pnt = dens_unesco (situ, sal, pres) endif return end function pdens_pnt (thet, sal) c------------------------------------------------- include 'comm_para.h' include 'comm_new.h' if (isalt .eq. 1) then pdens_pnt = SIGMA0 - TCOEF * (thet - TEMP_BOT) elseif (isalt .eq. 2) then pdens_pnt = pdens1 (thet) elseif (isalt .eq. 3) then pdens_pnt = pdens4 (thet, sal, 0.) elseif (isalt .eq. 4) then pdens_pnt = pdens012 (thet, sal) elseif (isalt .eq. 5) then pdens_pnt = pdens017 (thet, sal) elseif (isalt .eq. 6) then pdens_pnt = dens_unesco (thet, sal, 0.) endif return end c----------------------------------------------------- subroutine dens_init (npt, nz, nzi, t, sal, dens, h) c----------------------------------------------------- csenq dimension t(npt,1), sal(npt,1), dens(npt,1), nzi(1), h(npt,1) include 'comm_new.h' c do i = 1, npt do k = 1, nzi(i) POTND_BOT = amax1(POTND_BOT,pdens_pnt (t(i,k),sal(i,k))) enddo enddo POTND_BOT = amax1(POTND_BOT,pdens_pnt (TEMP_BOT, SALT_BOT)) call situ_dens (npt, nz, nzi, t, sal, dens, h) SITUD_BOT = POTND_BOT do i = 1, npt do k = 1, nzi(i) SITUD_BOT = amax1(SITUD_BOT,dens(i,k)) enddo enddo SITUD_BOT = amax1(SITUD_BOT,sdens_pnt (TEMP_BOT, SALT_BOT, dep_max)) write (iout, *) 'TEMP_BOT = ', TEMP_BOT write (iout, *) 'SALT_BOT = ', SALT_BOT write (iout, *) 'MAX_DEPTH = ', dep_max write (iout, *) 'DENS_BOT(in situ) = ', SITUD_BOT write (iout, *) 'DENS_BOT(potential) = ', POTND_BOT return end c---------------------------------------------------------------- subroutine situ_dens (npt, nz, nzi, tem, sal, dens, h) c---------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' include 'comm_new.h' dimension tem(npt,nz), sal(npt,nz), dens(npt,nz), h(npt,nz), nzi(npt) c in situ SIGMA density as a function of potential temperature, c salinity & pressure. sigma == 1000. * (rho - 1.); c Senya Basin 1992 c if (isalt .eq. 1) then do i = 1, npt do k = 1, nzi(i) dens(i,k) = SIGMA0 - TCOEF * (tem(i,k) - TEMP_BOT) enddo enddo elseif (isalt .eq. 2) then do i = 1, npt do k = 1, nzi(i) dens(i,k) = pdens1 (tem(i,k)) enddo enddo elseif (isalt .eq. 3) then do i = 1, npt pp = h(i,1)/2. pp1 = pp pp0 = -pp do k = 1, nzi(i) dens(i,k) = pdens4 (tem(i,k), sal(i,k), pp) pp = pp0 + 2.*h(i,k) pp0 = pp1 pp1 = pp enddo enddo elseif (isalt .eq. 4) then do i = 1, npt pp = h(i,1)/2. pp1 = pp pp0 = -pp do k = 1, nzi(i) dens(i,k) = pdens12 (tem(i,k), sal(i,k), pp) pp = pp0 + 2.*h(i,k) pp0 = pp1 pp1 = pp enddo enddo elseif (isalt .eq. 5) then do i = 1, npt pp = h(i,1)/2. pp1 = pp pp0 = -pp do k = 1, nzi(i) dens(i,k) = pdens17 (tem(i,k), sal(i,k), pp) pp = pp0 + 2.*h(i,k) pp0 = pp1 pp1 = pp enddo enddo elseif (isalt .eq. 6) then do i = 1, npt pp = h(i,1)/2. pp1 = pp pp0 = -pp do k = 1, nzi(i) salt = sal(i,k) c Gilles variant: situ = theta_eos (pp, tem(i,k), salt, 0.) dens(i,k) = dens_unesco (situ, salt, pp) pp = pp0 + 2.*h(i,k) pp0 = pp1 pp1 = pp enddo enddo endif return end c---------------------------------------------------------------- subroutine potn_dens (npt, nzi, tem, sal, dens) c---------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' include 'comm_new.h' dimension tem(npt,1), sal(npt,1), dens(npt,1), nzi(1) c Potential SIGMA density as a function of potential temperature & salinity c sigma == 1000. * (rho - 1.); c Senya Basin 1992 c if (isalt .eq. 1) then do i = 1, npt do k = 1, nzi(i) dens(i,k) = SIGMA0 - TCOEF * (tem(i,k) - TEMP_BOT) enddo enddo elseif (isalt .eq. 2) then do i = 1, npt do k = 1, nzi(i) dens(i,k) = pdens1 (tem(i,k)) enddo enddo elseif (isalt .eq. 3) then do i = 1, npt do k = 1, nzi(i) dens(i,k) = pdens4 (tem(i,k), sal(i,k), 0.) enddo enddo elseif (isalt .eq. 4) then do i = 1, npt do k = 1, nzi(i) dens(i,k) = pdens012 (tem(i,k), sal(i,k)) enddo enddo elseif (isalt .eq. 5) then do i = 1, npt do k = 1, nzi(i) dens(i,k) = pdens017 (tem(i,k), sal(i,k)) enddo enddo elseif (isalt .eq. 6) then do i = 1, npt do k = 1, nzi(i) dens(i,k) = dens_unesco (tem(i,k), sal(i,k), 0.) enddo enddo endif return end c------------------------------------------------------------------------------ subroutine dconv (npt,nz,nzi,u,v,uc,vc,h,t,sal,dens,tr,convn) c------------------------------------------------------------------------------ c main aim: removing possible static instability in density. c No influence on layer depths in this version c (see isopycnal mixing model in Ragu's version) c-----------------------------------------------------------------Senq Ltd. Co. c c boundary condition at bottom changed - instead of t(i,nzi) = t_bot c i prefer t(i,nzi)_after = t(i,nzi)_before - NHN implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' common /errors/ ioerr, nstep c dimension u(npt,nz), v(npt,nz), uc(npt,nz), vc(npt,nz), h(npt,nz), * t(npt,nz), sal(npt,nz), dens(npt,nz), convn(npt,nz), nzi(npt), * tr(npt,nz,1) parameter (ERR_LEV = 1.e-4) c if (.not. use_salt) then call tconv (npt,nz,nzi,u,v,uc,vc,h,t,tr,convn) return endif do i = 1, npt do k = 1, nzi(i) - 1 kp = k + 1 if (dens(i,k)-dens(i,kp) .gt. ERR_LEV) then hinv = h(i,k) + h(i,kp) oldpotener = (dens(i,kp)*h(i,kp) + dens(i,k)*hinv)/2. hinv = 1.0 / hinv hki = hinv * h(i,k) hkpi = hinv * h(i,kp) tmp = uc(i,k) + uc(i,kp) uc(i,k) = tmp * hki uc(i,kp) = tmp * hkpi tmp = hinv * tmp u(i,k) = tmp u(i,kp) = tmp tmp = vc(i,k) + vc(i,kp) vc(i,k) = tmp * hki vc(i,kp) = tmp * hkpi tmp = hinv * tmp v(i,k) = tmp v(i,kp) = tmp tmp1 = hki*t(i,k) + hkpi*t(i,kp) t(i,k) = tmp1 t(i,kp) = tmp1 tmp = hki*sal(i,k) + hkpi*sal(i,kp) sal(i,k) = tmp sal(i,kp) = tmp tmp = pdens_pnt (tmp1, tmp) dens(i,k) = tmp dens(i,kp) = tmp do m = 1, ntrac tmp = hki*tr(i,k,m) + hkpi*tr(i,kp,m) tr(i,k,m) = tmp tr(i,kp,m) = tmp enddo znewpotener = tmp*(h(i,kp) + h(i,k)/2.) convn(i,k) = convn(i,k) + oldpotener - znewpotener endif enddo enddo return end c------------------------------------------------------------------------------ subroutine tconv (npt,nz,nzi,u,v,uc,vc,h,t,tr,convn) c------------------------------------------------------------------------------ c main aim: removing possible static instability in density. c No influence on layer depths in this version c (see isopycnal mixing model in Ragu's version) c-----------------------------------------------------------------Senq Ltd. Co. implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' include 'comm_new.h' common /errors/ ioerr, nstep c dimension u(npt,nz), v(npt,nz), uc(npt,nz), vc(npt,nz), h(npt,nz), * t(npt,nz), convn(npt,nz), nzi(npt), tr(npt,nz,1) parameter (ERR_LEV = 1.e-4) c do i = 1, npt do k = 1, nzi(i) - 1 kp = k + 1 if (t(i,kp)-t(i,k) .gt. ERR_LEV) then convn(i,k) = convn(i,k) + t(i,kp)-t(i,k) hinv = 1.0 / (h(i,k) + h(i,kp)) hki = hinv * h(i,k) hkpi = hinv * h(i,kp) tmp = uc(i,k) + uc(i,kp) uc(i,k) = tmp * hki uc(i,kp) = tmp * hkpi tmp = hinv * tmp u(i,k) = tmp u(i,kp) = tmp tmp = vc(i,k) + vc(i,kp) vc(i,k) = tmp * hki vc(i,kp) = tmp * hkpi tmp = hinv * tmp v(i,k) = tmp v(i,kp) = tmp tmp = hki*t(i,k) + hkpi*t(i,kp) t(i,k) = tmp t(i,kp) = tmp do m = 1, ntrac tmp = hki*tr(i,k,m) + hkpi*tr(i,kp,m) tr(i,k,m) = tmp tr(i,kp,m) = tmp enddo endif enddo enddo return end c------------------------------------------------------------------------------ subroutine dconv_cl (npt,nz,nzi,h,t,sal,dens) c------------------------------------------------------------------------------ c main aim: removing possible static instability in density. c No influence on layer depths in this version c (see isopycnal mixing model in Ragu's version) c-----------------------------------------------------------------Senq Ltd. Co. c c boundary condition at bottom changed - instead of t(i,nzi) = t_bot c i prefer t(i,nzi)_after = t(i,nzi)_before - NHN implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' common /errors/ ioerr, nstep c dimension h(npt,nz), * t(npt,nz), sal(npt,nz), dens(npt,nz), nzi(npt) parameter (ERR_LEV = 1.e-4) c if (.not. use_salt) then call tconv_cl (npt,nz,nzi,h,t) return endif do i = 1, npt do k = 1, nzi(i) - 1 kp = k + 1 if (dens(i,k)-dens(i,kp) .gt. ERR_LEV) then hinv = h(i,k) + h(i,kp) oldpotener = (dens(i,kp)*h(i,kp) + dens(i,k)*hinv)/2. hinv = 1.0 / hinv hki = hinv * h(i,k) hkpi = hinv * h(i,kp) tmp1 = hki*t(i,k) + hkpi*t(i,kp) t(i,k) = tmp1 t(i,kp) = tmp1 tmp = hki*sal(i,k) + hkpi*sal(i,kp) sal(i,k) = tmp sal(i,kp) = tmp tmp = pdens_pnt (tmp1, tmp) dens(i,k) = tmp dens(i,kp) = tmp znewpotener = tmp*(h(i,kp) + h(i,k)/2.) endif enddo enddo return end c------------------------------------------------------------------------------ subroutine tconv_cl (npt,nz,nzi,h,t) c------------------------------------------------------------------------------ c main aim: removing possible static instability in density. c No influence on layer depths in this version c (see isopycnal mixing model in Ragu's version) c-----------------------------------------------------------------Senq Ltd. Co. implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' include 'comm_new.h' common /errors/ ioerr, nstep c dimension h(npt,nz), t(npt,nz), nzi(npt) parameter (ERR_LEV = 1.e-4) c do i = 1, npt do k = 1, nzi(i) - 1 kp = k + 1 if (t(i,kp)-t(i,k) .gt. ERR_LEV) then hinv = 1.0 / (h(i,k) + h(i,kp)) hki = hinv * h(i,k) hkpi = hinv * h(i,kp) tmp = hki*t(i,k) + hkpi*t(i,kp) t(i,k) = tmp t(i,kp) = tmp endif enddo enddo return end c--------------------------------------------------------------------- subroutine drich_mix (npt, nz, nzi, h,u,v,uc,vc,tem,sal,dens,tr) c--------------------------------------------------------------------- c Senya Basin, 1992 implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' include 'comm_new.h' dimension rnu(MAXNZ), rka(MAXNZ) dimension u(npt,nz), v(npt,nz), uc(npt,nz), vc(npt,nz), h(npt,nz), * dens(npt,nz), tem(npt,nz), sal(npt,nz), nzi(npt), tr(npt,nz,1) common /errors/ ioerr, nstep common /tria_loc/ ixy, ndim, alf(MAXNZ),bet(MAXNZ),gam(MAXNZ),aga(MAXNZ) parameter (R_COEF = -0.5 * GRAVTY/1000.) parameter (R_CRIT = 2.e5) parameter (DUZ_0 = 1.e-5) c c Ri = -(g/rho0) * d(rho)/dz / (du/dz**2 + du/dz**2) c if (.not. use_salt) then call trich_mix (npt, nz, nzi, h,u,v,uc,vc,tem,tr) return endif do i = 1, npt ndim = nzi(i) rnu(ndim) = 0. rka(ndim) = 0. do k = 1, ndim-1 uu = u(i,k) - u(i,k+1) vv = v(i,k) - v(i,k+1) du2 = uu*uu + vv*vv if (du2 .lt. DUZ_0) du2 = DUZ_0 h12 = h(i,k) + h(i,k+1) rich = R_COEF * h12 * (dens(i,k) - dens(i,k+1)) / du2 call visc_diff (rich, vnu, vka) tmp = DLT_MIX / h12 rnu(k) = tmp * vnu rka(k) = tmp * vka enddo ixy = i call tria_init (npt, rnu, h) call tria_tem (npt, u, 0.) call tria_tem (npt, v, 0.) call tria_init (npt, rka, h) tb = tem(i,ndim) sb = sal(i,ndim) call tria_tem (npt, tem, tb) call tria_tem (npt, sal, sb) do m = 1, ntrac trb = tr(i,ndim,m) call tria_tem (npt, tr(1,1,m), trb) enddo enddo do i = 1, npt do k = 1, nzi(i) hi = h(i,k) uc(i,k) = u(i,k) * hi vc(i,k) = v(i,k) * hi enddo enddo return end c--------------------------------------------------------------------- subroutine trich_mix (npt, nz, nzi, h,u,v,uc,vc,tem,tr) c--------------------------------------------------------------------- c Senya Basin, 1992 implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' include 'comm_new.h' dimension rnu(MAXNZ), rka(MAXNZ) dimension u(npt,nz), v(npt,nz), uc(npt,nz), vc(npt,nz), h(npt,nz), * tem(npt,nz), nzi(npt), tr(npt,nz,1) common /errors/ ioerr, nstep common /tria_loc/ ixy, ndim, alf(MAXNZ),bet(MAXNZ),gam(MAXNZ),aga(MAXNZ) parameter (R_COEF = -0.5 * GRAVTY/1000.) parameter (R_CRIT = 2.e5) parameter (DUZ_0 = 1.e-5) c c Ri = -(g/rho0) * d(rho)/dz / (du/dz**2 + du/dz**2) c rtcoef = TCOEF * R_COEF do i = 1, npt ndim = nzi(i) rnu(ndim) = 0. rka(ndim) = 0. do k = 1, ndim-1 uu = u(i,k) - u(i,k+1) vv = v(i,k) - v(i,k+1) du2 = uu*uu + vv*vv if (du2 .lt. DUZ_0) du2 = DUZ_0 h12 = h(i,k) + h(i,k+1) c dik = TCOEF * (TEMP_BOT - tem(i,k)) c dik1 = TCOEF * (TEMP_BOT - tem(i,k+1)) c rich = R_COEF * h12 * (dik - dik1) / du2 rich = rtcoef * h12 * (tem(i,k+1) - tem(i,k)) / du2 call visc_diff (rich, vnu, vka) tmp = DLT_MIX / h12 rnu(k) = tmp * vnu rka(k) = tmp * vka enddo ixy = i call tria_init (npt, rnu, h) call tria_tem (npt, u, 0.) call tria_tem (npt, v, 0.) call tria_init (npt, rka, h) tb = tem(i,ndim) call tria_tem (npt, tem, tb) do m = 1, ntrac trb = tr(i,ndim,m) call tria_tem (npt, tr(1,1,m), trb) enddo enddo do i = 1, npt do k = 1, nzi(i) hi = h(i,k) uc(i,k) = u(i,k) * hi vc(i,k) = v(i,k) * hi enddo enddo return end c--------------------------------------------- subroutine visc_diff (Ri, rnu, rka) c--------------------------------------------- c eddy viscosity & diffusivity c a'la Pacanowski & Philander [1981] c--------------------------------------------- c from PP-1981: c parameter (GAMMA = 5., RNU_0 = 0.01, RNU_B = 5.e-5, RKA_B = 5.e-6) c parameter (GAMMA = 5., RNU_0 = 0.05, RNU_B = 1.34e-5, RKA_B = 1.34e-6) parameter (RNU_NEG = RNU_B + RNU_0) parameter (RKA_NEG = RKA_B + RNU_NEG) if ( Ri .gt. 0. ) then tmp = 1. + GAMMA * Ri rnu = RNU_B + RNU_0 / (tmp * tmp) rka = RKA_B + rnu / tmp else rnu = RNU_NEG rka = RKA_NEG endif return end c------------------------------------------------------ subroutine tria_init (npt, cappa, h) c------------------------------------------------------ csenq include 'comm_para.h' real cappa(1), h(npt,1) common /tria_loc/ ixy, ndim, alf(MAXNZ),bet(MAXNZ),gam(MAXNZ),aga(MAXNZ) capk = cappa(1) hi = h(ixy,1) tmp = capk + hi betk = capk / tmp bet(1) = betk gam(1) = hi / tmp do k = 2, ndim betkm1 = betk capkm1 = capk capk = cappa(k) hi = h(ixy,k) tmp = hi + capk + capkm1 - betkm1 * capkm1 betk = capk / tmp bet(k) = betk aga(k) = capkm1 / tmp gam(k) = hi / tmp enddo return end subroutine tria_run (npt, data) c------------------------------------- csenq include 'comm_para.h' real data(npt,1) common /tria_loc/ ixy, ndim, alf(MAXNZ),bet(MAXNZ),gam(MAXNZ),aga(MAXNZ) alfa = data(ixy,1)*gam(1) alf(1) = alfa do k = 2, ndim alfa = data(ixy,k)*gam(k) + alfa*aga(k) alf(k) = alfa enddo prev = 0. do k = ndim, 1, -1 prev = alf(k) + bet(k) * prev data(ixy,k) = prev enddo return end subroutine tria_tem (npt, data, botval) c-------------------------------------------- csenq include 'comm_para.h' real data(npt,1) common /tria_loc/ ixy, ndim, alf(MAXNZ),bet(MAXNZ),gam(MAXNZ),aga(MAXNZ) alfa = data(ixy,1)*gam(1) alf(1) = alfa do k = 2, ndim alfa = data(ixy,k)*gam(k) + alfa*aga(k) alf(k) = alfa enddo prev = botval do k = ndim, 1, -1 prev = alf(k) + bet(k) * prev data(ixy,k) = prev enddo return end c**************************************************************************** subroutine dens_eos(pr, t, s, r0, rr) c**************************************************************************** c sub to compute density c calls sub 'sbulk', for secant bulk modulas c c r0 is density at p = 0 - returned in gr cm**3 c rr is in situ density - returned c implicit double precision (a-z) real*4 t, s, pr c dimension a(0:5), b(0:4), c(0:2) parameter 1 (a0=999.842594d+00,a1=6.793952d-02,a2=-9.095290d-03, 2 a3=1.001685d-04,a4=-1.120083d-06,a5=6.536332d-09, 3 b0=8.24493d-01,b1=-4.0899d-03,b2=7.6438d-05, 4 b3=-8.2467d-07,b4=5.3875d-09, 5 c0=-5.72466d-03,c1=1.0227d-04,c2=-1.6546d-06, 6 d=4.8314d-04) if (t.lt.-4.0 .or. t.gt.40.0) then r0 = -99.9 rr = -99.9 return else if (s.lt.0.0 .or. s.gt.42.0) then r0 = -99.9 rr = -99.9 return else if (pr.lt.0.0 .or. pr.gt.10000.0) then r0 = -99.9 rr = -99.9 return end if call sbulk(pr, t, s, kk) c secant bulk modulas (k) of seawater c c density of smow c rw = ((((a5*t + a4)*t + a3)*t + a2)*t + a1)*t +a0 c c density at p = 0 c r0 = rw + s*((((b4*t + b3)*t + b2)*t + b1)*t + b0) * + s*sqrt(s)*((c2*t + c1)*t + c0) + s*s*d c c in situ density c p = pr / 10.0 c p is in bars rr = r0 / (1.d0 - p / kk) rr = rr / 1.d3 c densities are returned in r0 = r0 / 1.d3 c grams / cubic centimeter return end c**************************************************************************** function theta_eos(p0, t0, s, pf) c**************************************************************************** c c to compute local potential temperature at pf c c oct 12 1975 n. fofonoff c p = p0 t = t0 h = pf - p xk = h * atg(p, t, s) t = t + 0.5 * xk q = xk p = p + 0.5 * h xk = h*atg(p,t,s) t = t + 0.29298322*(xk-q) q = 0.58578644*xk + 0.121320344*q xk = h*atg(p,t,s) t = t + 1.707106781*(xk-q) q = 3.414213562*xk - 4.121320344*q p = p + 0.5*h xk = h*atg(p,t,s) theta = t + (xk - 2.0 * q) / 6.0 return end c**************************************************************************** c**************************************************************************** subroutine sbulk(pr, t, s, kk) c**************************************************************************** c c subroutines to calculate density, spec vol, secant bulk c modulas and alpha & beta c based on unesco 1981 report c equation of state for seawater - millero c programmer - c. greengrove, jan 1982 c modified for hp - p mele, sep '82 c c range: c s = 0 to 42 (practical salinity) c t = -4 to 40 (c) c pr = 0 to 10000 (decibars) c c other units: c density = kg/m3 **3 c bulk deni mod.(k) = bars c c c kk is secant bulk modulas - returned c implicit double precision (a-z) real*4 t, s, pr, s12 c single precision parameter 1 (e0=19652.21d+00,e1=148.4206d+00,e2=-2.327105d+00, 2 e3=1.360477d-02,e4=-5.155288d-05, 3 f0=54.6746d+00,f1=-.603459d+00,f2=1.09987d-02,f3=-6.167d-05, 4 g0=7.944d-02,g1=1.6483d-02,g2=-5.3009d-04, 5 h0=3.239908d+00,h1=1.43713d-03,h2=1.16092d-04,h3=-5.77905d-07, 6 i0=2.2838d-03,i1=-1.0981d-05,i2=-1.6078d-06, 7 j=1.91075d-04, 8 k0=8.50935d-05,k1=-6.12293d-06,k2=5.2787d-08, 9 m0=-9.9348d-07,m1=2.0816d-08,m2=9.1697d-10) if (t.lt.-4.0 .or. t.gt.40.0) then c range specifications kk = -99.9 return else if (s.lt.0.0 .or. s.gt.42.0) then kk = -99.9 return else if (pr.lt.0.0 .or. pr.gt.10000.0) then kk = -99.9 return end if p = pr / 10.0 c convert to bars c define sqrt(s) s12=sqrt(s) c c secant bulk modulas (k) of seawater c c pure water terms of sbm are w series c kw = (((e4*t + e3)*t + e2)*t + e1)*t + e0 aw = ((h3*t + h2)*t + h1)*t + h0 bw = (k2*t + k1)*t + k0 c c coeff for final equation c aa = aw + s*((i2*t + i1)*t + i0 + j*s12) bb = bw + s*((m2*t + m1)*t + m0) c c sbm at p = 0 first term in the final eq c ko = kw + s*(((f3*t + f2)*t + f1)*t + f0) * + s*s12*((g2*t + g1)*t + g0) c c final eq sbm c kk = (bb*p + aa)*p + ko return end c**************************************************************************** function atg(p, t, s) c**************************************************************************** c c adiabatic temperature gradient (bryden 1973) c ds = s - 35.0 atg = (((-2.1687e-16 * t + 1.8676e-14) * t - 4.6206e-13) * p + * ((2.7759e-12 * t - 1.1351e-10) * ds + ((-5.4481e-14 * t + * 8.733e-12) * t - 6.7795e-10) * t + 1.8741e-8)) * p + * (-4.2393e-8 * t + 1.8932e-6) * ds + ((6.6228e-10 * t - * 6.836e-8) * t + 8.5258e-6) * t + 3.5803e-5 return end c ------------------------------------------------------------------ subroutine comp_bncy (npt,nzi,dens,bncy) c ------------------------------------------------------------------ c Compute boyoncy as : b = -g(rho-rho_0)/rho_0 c ------------------------------------------------------------------ include 'comm_para.h' include 'comm_new.h' dimension dens(npt,1),bncy(npt,1),nzi(npt) c if ( use_salt ) then coef = -GRAVTY/(1000. + POTND_BOT) do i = 1, npt do k = 1, nzi(i) bncy(i,k) = coef * (dens(i,k) - POTND_BOT) enddo enddo endif return end c ------------------------------------------------------------------ subroutine cvmix(npt,nzi,h,t,s,b,u,v) c ------------------------------------------------------------------ c Convective adjustment as of Dake Chen. include 'comm_new.h' dimension nzi(npt),h(npt,1),t(npt,1),s(npt,1),b(npt,1),u(npt,1),v(npt,1) c if ( use_salt ) then do ns = 1, 2 do ks = 1, 2 do i = 1, npt do k = ks, nzi(i)-1, 2 k1 = k + 1 if (b(i,k) .lt. b(i,k1)) then hik = h(i,k) hik1 = h(i,k1) hsum1 = 1. / (hik + hik1) t(i,k) = (hik*t(i,k) + hik1*t(i,k1))*hsum1 t(i,k1) = t(i,k) s(i,k) = (hik*s(i,k) + hik1*s(i,k1))*hsum1 s(i,k1) = s(i,k) b(i,k) = (hik*b(i,k) + hik1*b(i,k1))*hsum1 b(i,k1) = b(i,k) endif enddo enddo enddo enddo else do ns = 1, 2 do ks = 1, 2 do i=1,npt do k = ks, nzi(i)-1, 2 if (t(i,k) .lt. t(i,k+1)) then hsum = h(i,k)+h(i,k+1) t(i,k) = (h(i,k)*t(i,k)+h(i,k+1)*t(i,k+1))/hsum t(i,k+1) = t(i,k) endif enddo enddo enddo enddo endif return end c ---------------------------------------------------------------- function tke0(wp,b0,br,h,hp) c ---------------------------------------------------------------- hp2 = hp + hp hexp = h - hp2 + (h + hp2)*exp(-h/hp) bp = b0*h + br*hexp tke0 = wp - bp return end c --------------------------------------------------------------------- subroutine ktmix(npt,nsig,ddt,h,t,s,b,u,v,q,qr,ep,taux,tauy,sigma,dh1) c --------------------------------------------------------------------- c Vertical Mixing Using Kraus-Turner Scheme.(Dake Chen, 1995) include 'comm_new.h' dimension u(npt,1),v(npt,1),h(npt,1),t(npt,1),s(npt,1),b(npt,1), + dh1(1),q(1),qr(1),ep(1),taux(1),tauy(1),sigma(1) data alph/2.55e-4/, beta/7.6e-4/, gravty/9.8/, taumin/3.e-5/, hp/17./ c ga = alph*gravty gb = beta*gravty c cm2 = 2.0 * cm_mix cn2 = cn_mix / 2.0 do i = 1, npt h10 = h(i,1) tau = sqrt(taux(i)**2 + tauy(i)**2) tau = amax1(tau,taumin) ustar = sqrt(tau) wp = cm2 * ustar * tau br = ga*qr(i) if ( use_salt ) then b0 = ga*q(i) - gb*ep(i) dbh = (b(i,1) - b(i,2))*h10 else b0 = ga*q(i) dbh = ga*(t(i,1) - t(i,2))*h10 endif b0 = b0 - cn2 * (b0-abs(b0)) dbh = amax1(dbh,1.e-5) tke = tke0(wp,b0,br,h10,hp) if( tke .lt. 0.) then h1 = h10 h2 = 0.5*h1 f1 = tke0(wp,b0,br,h1,hp) do iter = 1, 10 f2 = tke0(wp,b0,br,h2,hp) hnew = h2 - f2*(h2-h1)/(f2-f1) err = abs(hnew-h2)/h2 if (err .lt. 1.e-4) goto 15 h1 = h2 h2 = hnew f1 = f2 enddo 15 continue hnew = amin1(h10, hnew) else h1 = h10 h2 = h10 + h10 hm = h10 f1 = -ddt*tke0(wp,b0,br,hm,hp) do iter = 1, 10 hm = 0.5*(h2+h10) f2 = dbh*(h2-h10) - ddt*tke0(wp,b0,br,hm,hp) hnew = h2 - f2*(h2-h1)/(f2-f1) err = abs(hnew-h2)/h2 if (err .lt. 1.e-4) goto 25 h1 = h2 h2 = hnew f1 = f2 enddo 25 continue hnew = amax1(h10, hnew) endif hnew = amax1(hmin_mix, hnew) hnew = amin1(hmax_mix, hnew) dh = hnew - h10 adh = amin1(abs(dh), h(i,2)) dh1(i) = sign(adh, dh) enddo call impmix (npt,nsig,dh1,u,v,h,t,s,sigma) return end c ---------------------------------------------------------------- subroutine impmix (npt,nz,dh1,u,v,h,t,s,sigma) c ---------------------------------------------------------------- c Adjust vertical profiles according to the depth change of the c mixed layer as of Dake Chen. /modified by Senya Basin, July 1995/ include 'comm_para.h' include 'comm_new.h' dimension dh1(1),u(npt,1),v(npt,1),h(npt,1), * t(npt,1),s(npt,1), sigma(1), * u1(MAXNZ),u2(MAXNZ),v1(MAXNZ),v2(MAXNZ),t1(MAXNZ),t2(MAXNZ), * aa(MAXNZ),bb(MAXNZ),cc(MAXNZ),dh(MAXNZ),we(MAXNZ),hr(MAXNZ), * s1(MAXNZ),s2(MAXNZ) do i = 1, npt dh_mix = dh1(i) if (dh_mix .ne. 0.) then dh(1) = dh_mix do k = 2, nz dh(k) = -1.5*(sigma(k)+sigma(k+1))*dh_mix enddo we(1) = dh_mix do k = 2, nz-1 we(k) = we(k-1) + dh(k) enddo if (use_salt) then do k = 1, nz hik = h(i,k) u1(k) = u(i,k)*hik v1(k) = v(i,k)*hik t1(k) = t(i,k)*hik s1(k) = s(i,k)*hik h(i,k) = hik + dh(k) enddo else do k = 1, nz hik = h(i,k) u1(k) = u(i,k)*hik v1(k) = v(i,k)*hik t1(k) = t(i,k)*hik h(i,k) = hik + dh(k) enddo endif do k = 1, nz-1 hr(k) = we(k)/(h(i,k)+h(i,k+1)) enddo hr1 = 0.5*(dh_mix - abs(dh_mix)) / h(i,1) hr2 = 0.5*(dh_mix + abs(dh_mix)) / h(i,2) cc(1) = -hr2 bb(1) = 1. - hr1 aa(2) = hr1 cc(2) = -hr(2) bb(2) = 1. - hr(2) + hr2 aa(nz) = hr(nz-1) bb(nz) = 1. + aa(nz) hr_k = hr(2) do k = 3, nz-1 hr_km1 = hr_k hr_k = hr(k) aa(k) = hr_km1 cc(k) = -hr_k bb(k) = 1. + hr_km1 - hr_k enddo call tridiag(aa,bb,cc,u1,u2,nz) call tridiag(aa,bb,cc,v1,v2,nz) call tridiag(aa,bb,cc,t1,t2,nz) if ( use_salt ) then call tridiag(aa,bb,cc,s1,s2,nz) do k = 1, nz hik = 1./h(i,k) u(i,k) = hik*u2(k) v(i,k) = hik*v2(k) t(i,k) = hik*t2(k) s(i,k) = hik*s2(k) enddo else do k = 1, nz hik = 1./h(i,k) u(i,k) = hik*u2(k) v(i,k) = hik*v2(k) t(i,k) = hik*t2(k) enddo endif endif enddo return end c ------------------------------------------------------------------ subroutine jpmix (npt,nz,nzi,h,t,s,b,u,v) c ------------------------------------------------------------------ c Reduce gradient Richardson # instability using a Jim Price criterion. include 'comm_para.h' include 'comm_new.h' dimension u(npt,1),v(npt,1),h(npt,1),t(npt,1),s(npt,1),b(npt,1), * gama(MAXNZ), ric(MAXNZ), nzi(npt) logical use_gamma save EPSILON, use_gamma, ifirst, ric, ric_inv data EPSLON/1.e-9/, ifirst/0/ c if ( ifirst .eq. 0 ) then ifirst = 1 gama(1) = gam1_mix ric(1) = ric1_mix do k = 2, nz gama(k) = gam2_mix ric(k) = ric2_mix enddo use_gamma = (iuse_gam .eq. 1) endif if ( use_salt ) then do kn = 1, 2 do ks = 1, 2 do i = 1, npt do k = ks, nzi(i)-1, 2 Rik = ric(k) Rik_inv = 1./ric(k) gamkt = gama(k) gamkv = 0.5*(1.+gama(k)) c compute the gradient Richardson number hm = h(i,k) + h(i,k+1) bd = b(i,k) - b(i,k+1) dd = 0.5 * hm * bd ud = u(i,k+1) - u(i,k) vd = v(i,k+1) - v(i,k) dv = ud*ud + vd*vd Ri = amax1(dd,0.)/amax1(dv,EPSLON) c check to see if Ri is critical or not if (Ri .lt. Rik) then c partially mix layers k and k+1 if ( use_gamma ) then ri2 = Ri*Rik_inv ct = 1.- ri2**gamkt cv = 1.- ri2**gamkv else ct = 1. - Ri*Rik_inv cv = ct endif c1 = h(i,k) / hm c2 = h(i,k+1) / hm td = (t(i,k+1)-t(i,k))*ct sd = (s(i,k+1)-s(i,k))*ct bd = -bd*ct ud = ud*cv vd = vd*cv t(i,k+1) = t(i,k+1) - td*c1 t(i,k) = t(i,k) + td*c2 s(i,k+1) = s(i,k+1) - sd*c1 s(i,k) = s(i,k) + sd*c2 b(i,k+1) = b(i,k+1) - bd*c1 b(i,k) = b(i,k) + bd*c2 u(i,k+1) = u(i,k+1) - ud*c1 u(i,k) = u(i,k) + ud*c2 v(i,k+1) = v(i,k+1) - vd*c1 v(i,k) = v(i,k) + vd*c2 endif enddo enddo enddo enddo else coef = TALPHA*GRAVTY / 2.0 do kn = 1, 2 do ks = 1, 2 do i = 1, npt do k = ks, nzi(i)-1, 2 Rik = ric(k) Rik_inv = 1./ric(k) gamkt = gama(k) gamkv = 0.5*(1.+gama(k)) c compute the gradient Richardson number hm = h(i,k) + h(i,k+1) td = t(i,k) - t(i,k+1) dd = coef * hm * td ud = u(i,k+1) - u(i,k) vd = v(i,k+1) - v(i,k) dv = ud*ud + vd*vd Ri = amax1(dd,0.)/amax1(dv,EPSLON) c check to see if Ri is critical or not if (Ri .lt. Rik) then c partially mix layers k and k+1 if ( use_gamma ) then ri2 = Ri*Rik_inv ct = 1.- ri2**gamkt cv = 1.- ri2**gamkv else ct = 1. - Ri*Rik_inv cv = ct endif c1 = h(i,k)/hm c2 = h(i,k+1)/hm td = -td*ct ud = ud*cv vd = vd*cv t(i,k+1) = t(i,k+1) - td*c1 t(i,k) = t(i,k) + td*c2 u(i,k+1) = u(i,k+1) - ud*c1 u(i,k) = u(i,k) + ud*c2 v(i,k+1) = v(i,k+1) - vd*c1 v(i,k) = v(i,k) + vd*c2 endif enddo enddo enddo enddo endif return end c---------------------------------------------------------------------------- subroutine tridiag(A,B,C,Y,X,N) c---------------------------------------------------------------------------- c Modified 2 Feb 1991 c This routine solves a matrix equation of the form MX=Y where Y is c the know vector and M is an NxN tridiagonal matrix with a diagonal of c B, a lower diagonal of A and an upper diagonal of C. It should be c noted that N will be equal to the number of layers (nz). If there c are more than 100 the array size will exceed memory allocation. c c This routine requires the matrix elements (A,B,C), the known vector c (Y) and the dimensions of both (N). c c This routine supplies the new vector X. c The variables are defined as: c c Name Type Description c ==== ==== =========== c c a(n) From Lower diagonal elements c dimpl c b(n) From Main diagonal elements c dimpl c bit Internal Storage variable c c(n) From Upper diagonal elements c dimpl c gam(nmax) Internal Storage array c nmax Internal Maximum array size c x(n) Ret to new velocity (temp) field c dimpl c y(n) From Original velocity (temp) field c dimpl c c------------------ Establish variables and constants ----------------------- parameter (nmax=100) dimension gam(nmax),a(n),b(n),c(n),y(n),x(n) bet = b(1) x(1) = y(1)/bet c-------------------------- Forward substitute ------------------------------ do j = 2, n gam(j) = c(j-1)/bet bet = b(j) - a(j)*gam(j) x(j) = (y(j) - a(j)*x(j-1)) / bet enddo c-------------------------- Back substitute ------------------------------ do j = n-1, 1, -1 x(j) = x(j) - gam(j+1)*x(j+1) enddo return end dyn_filt.f/ 839513370 1572 1572 100444 17542 ` subroutine shap_indx(npt,nxp,nyp,mask,isx,nfxk,nfpxk,nfyk,ifx,ifpx,ify) c------------------------------------------------------------------------- c nfx : number of contiguous latitudinal segments c ifx(1,i): starting point (x-compressed index) of i'th segment c ifx(2,i): length of i-th segment c ifx(3,i): highest order filter used in i'th segment c nfpx : number of segments with periodic overlap c ifx(1,i): starting point western portion of segment c ifx(2,i): length of western portion of segment c ifx(3,i): starting point eastern portion of segment c ifx(4,i): length of eastern portion of segment c ifx(5,i): highest order filter used in segment c nfy : number of contiguous longitudinal segments c ify(1,j): starting point (y-compressed index) of j'th segment c ify(2,j): length of j'th segment c ify(3,j): highest order filter used in j'th segment include "comm_new.h" include 'comm_para.h' dimension mask(nxp,1),isx(1),ifx(3,1),ifpx(5,1),ify(3,1) logical prev, curr, peri, ZER common /shap_c25/ cs25(10), ZER, s_coef common /new_filt/ MAXFO, nbx, nby, nfx, nfpx, nfy do i = 1, MAXFO cs25(i) = 1./(4.**i) enddo nfxk = 0 nfpxk = 0 do irow = 1, nyp ista = 1 prev = (mask(1, irow) .eq. 0) peri = (.not. prev) .and. (iglob .ne. 0) do icol = 2, nxp curr = (mask(icol,irow) .eq. 0) if (curr .ne. prev) then if (peri .and. ista .eq. 1) then nfpxk = nfpxk + 1 ifpx(1,nfpxk) = mask(1,irow) ifpx(2,nfpxk) = icol - 1 elseif (curr) then nfxk = nfxk + 1 ifx(1,nfxk) = mask(ista,irow) ifx(2,nfxk) = icol-ista ifx(3,nfxk) = min((icol-ista-1)/2,MAXFO) endif ista = icol prev = curr endif enddo if (.not. curr) then if (peri) then if (ista .eq. 1) then nfpxk = nfpxk + 1 ifpx(1,nfpxk) = mask(1,irow) ifpx(2,nfpxk) = nxp ifpx(3,nfpxk) = 0 ifpx(4,nfpxk) = 0 ifpx(5,nfpxk) = MAXFO else ifpx(3,nfpxk) = mask(ista,irow) ifpx(4,nfpxk) = mask(nxp,irow) - mask(ista,irow) + 1 ifpx(5,nfpxk) = min((ifpx(2,nfpxk)+ifpx(4,nfpxk)-1)/2,MAXFO) endif else nfxk = nfxk + 1 ifx(1,nfxk) = mask(ista,irow) ifx(2,nfxk) = nxp-ista+1 ifx(3,nfxk) = min((nxp-ista)/2,MAXFO) endif endif enddo nfyk = 0 do icol = 1, nxp jsta = 1 prev = (mask(icol, 1) .eq. 0) do irow = 2, nyp curr = (mask(icol,irow) .eq. 0) if (curr .ne. prev) then if (curr) then nfyk = nfyk + 1 ify(1,nfyk) = isx(mask(icol,jsta)) ify(2,nfyk) = irow-jsta ify(3,nfyk) = min((irow-jsta-1)/2,MAXFO) endif jsta = irow prev = curr endif enddo if (.not. curr) then nfyk = nfyk + 1 ify(1,nfyk) = isx(mask(icol,jsta)) ify(2,nfyk) = nyp-jsta+1 ify(3,nfyk) = min((nyp-jsta)/2,MAXFO) endif enddo return end c----------------------------------------------------------------------- subroutine shap_vec(nstep,npt,nz,uc,vc,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp) c----------------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' dimension uc(npt,1),vc(npt,1),tp(1) dimension lxxk(MXBDY,nz),lyxk(MAXNB,nz),isyk(npt,nz),isk(npt,nz), * ifxk(9*MAXSID,nz), ifpxk(5*MAXSID,nz), ifyk(9*MAXSID,nz) common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) logical NOSLIP common /new_shap/ nordu, nordh, mshx, mshy, mshh, shap_vel_cnst, shap_scl_cnst common/shapi/nord,nshapu,nshaph,nshapt,mshapu,mshaph,mshapt common/param0/iyear,iday,isec,delt,ncyc,mbc,nonlin,label(20), + itherm,mlc,limp common /new_filt/ MAXFO, nbx, nby, nfx, nfpx, nfy external shap_1do, shap_1dco if (nstep.eq.0 .or. (nshapu.ne.0 .and. mod(nstep,nshapu).eq.0)) then NOSLIP = (mbc .eq. 1) do k = 1, nz npk = nptk(k) nbx = nbxk(k) nby = nbyk(k) nfx = nfxk(k) nfpx = nfpxk(k) nfy = nfyk(k) call shap_2d (nordu, mshapu, .true.,NOSLIP, npk, * lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k), * ifxk(1,k),ifpxk(1,k),ifyk(1,k), uc(1,k),tp, * shap_1do,shap_vel_cnst) call shap_2d (nordu, mshapu, NOSLIP,.true., npk, * lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k), * ifxk(1,k),ifpxk(1,k),ifyk(1,k), vc(1,k),tp, * shap_1do,shap_vel_cnst) enddo endif return end c----------------------------------------------------------------------- subroutine shap_scl(nstep,npt,nz,tem,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp) c----------------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' dimension tem(npt,nz), tp(1) dimension lxxk(MXBDY,nz),lyxk(MAXNB,nz),isyk(npt,nz),isk(npt,nz), * ifxk(9*MAXSID,nz), ifpxk(5*MAXSID,nz), ifyk(9*MAXSID,nz) common /new_shap/ nordu, nordh, mshx, mshy, mshh, shap_vel_cnst, shap_scl_cnst common/shapi/nord,nshapu,nshaph,nshapt,mshapu,mshaph,mshapt common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) common /new_filt/ MAXFO, nbx, nby, nfx, nfpx, nfy external shap_1do, shap_1dco, shap_1dcn if (nstep.eq.0 .or. (nshaph.ne.0 .and. mod(nstep,nshaph).eq.0)) then do k = 1, nz npk = nptk(k) nbx = nbxk(k) nby = nbyk(k) nfx = nfxk(k) nfpx = nfpxk(k) nfy = nfyk(k) if (mshaph.eq.3) then call shap_3d (nordh, mshaph, .false.,.false.,npk, * lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),ifpxk(1,k), * ifyk(1,k), tem(1,k),tp,shap_1dco,shap_scl_cnst) else call shap_2d (nordh, mshaph, .false.,.false., npk, * lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k), * ifxk(1,k),ifpxk(1,k),ifyk(1,k), tem(1,k),tp, * shap_1dcn,shap_scl_cnst) endif enddo endif return end c-------------------------------------------------------------------------- subroutine shap_2d (nord,key,SETX,SETY,npt,lxx,lyx,isy,isk, * ifx,ifpx,ify, aa,abc,filter,scoef) c-------------------------------------------------------------------------- c.....if key.eq.0 then reduce order for all points on short segments c since ifx(3,*) = min((ifx(2,*)-1)/2,MAXFO) : c length=4 -> nshap = 1 c length=5,6 -> nshap = min(2,nord) c length=7,8 -> nshap = min(3,nord) c etc. implicit real(a-h,o-z),integer(i-n) dimension lxx(1),lyx(1),isy(1),isk(1), aa(1), bb(1), cc(1), abc(npt,1) dimension ifx(3,1), ifpx(5,1), ify(3,1) logical SETX, SETY, ZER, REDUC pointer (pbb, bb), (pcc, cc) external filter common /shap_c25/ cs25(10), ZER, s_coef common /new_filt/ MAXFO, nbx, nby, nfx, nfpx, nfy s_coef = scoef c sizeof(abc) = 3*npt pbb = loc(abc(1,1)) pcc = loc(abc(1,2)) c REDUC = (key .eq. 0) c.......apply Shapiro filter in X direction do i = 1, npt bb(i) = aa(isk(i)) enddo ZER = SETX ! used only if filter = shap_1do nshap = MAXFO do k = 1, nfx if (REDUC) nshap = min(nord, ifx(3,k)) call filter (nshap, ifx(2,k), bb(ifx(1,k)), cc) enddo do k = 1, nfpx if (REDUC) nshap = min(nord, ifpx(5,k)) if (ifpx(4,k) .eq. 0) then call shap_1dp0 (nshap, ifpx(2,k), bb(ifpx(1,k)), cc) else call shap_1dper (nshap, ifpx(1,k), bb, cc, filter) endif enddo do i = 1, npt cc(isk(i)) = bb(i) enddo if (SETX) then do i = 1, nbx cc(lxx(i)) = 0. enddo endif if (SETY) then do i = 1, nby cc(lyx(i)) = 0. enddo endif do j = 1, npt i = isk(j) aa(i) = aa(i) - cc(i) enddo c.......apply Shapiro filter in Y direction do i = 1, npt bb(i) = aa(isy(i)) enddo ZER = SETY ! used only if filter = shap_1do do k = 1, nfy if (REDUC) nshap = min(nord, ify(3,k)) call filter (nshap, ify(2,k), bb(ify(1,k)), cc) enddo do i = 1, npt cc(isy(i)) = bb(i) enddo if (SETX) then do i = 1, nbx cc(lxx(i)) = 0. enddo endif if (SETY) then do i = 1, nby cc(lyx(i)) = 0. enddo endif do j = 1, npt i = isk(j) aa(i) = aa(i) - cc(i) enddo return end subroutine shap_1do (nshap, nn, f, tmp) c---------------------------------------------- c non-conservative, order reduced near boundaries c ZER => no change at boundary c (i.e. u=0 before filter -> u=0 after filter) implicit real(a-h,o-z),integer(i-n) dimension f(1), tmp(1), aa(1), bb(1), cc(1) pointer (paa, aa), (pbb, bb), (pcc, cc) logical ZER common /shap_c25/ cs25(10), ZER, s_coef paa = loc(f(1)) pbb = loc(tmp(1)) pcc = loc(tmp(nn+1)) do n = 1, nshap const = cs25(n) iab = paa paa = pbb pbb = iab f0 = bb(1) fp = bb(2) do i = 2, nn-1 fm = f0 f0 = fp fp = bb(i+1) aa(i) = (f0 - fp) + (f0 - fm) enddo if (n .eq. 1) then if (ZER) then aa(1) = 0. aa(nn) = 0. else aa(1) = bb(1) - bb(2) aa(nn) = bb(nn) - bb(nn-1) endif endif cc(n) = const*aa(n) cc(nn-n+1) = const*aa(nn-n+1) enddo do i = nshap+1, nn-nshap f(i) = const*aa(i) enddo do i = 1, nshap f(i) = cc(i) f(nn-i+1) = cc(nn-i+1) enddo return end subroutine shap_1dper (nshap, id, f, tmp, filter) c------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) dimension id(4), f(1), tmp(1), aa(1), bb(1) pointer (paa, aa), (pbb, bb) external filter i1 = id(1) n1 = id(2) i2 = id(3) n2 = id(4) n12 = n1 + n2 paa = loc(f(i2)) do i = 1, n2 tmp(i) = aa(i) enddo paa = loc(f(i1)) k = n2 do i = 1, n1 k = k + 1 tmp(k) = aa(i) enddo call filter (nshap, n12, tmp, tmp(n12+1)) k = n2 do i = 1, n1 k = k + 1 aa(i) = tmp(k) enddo paa = loc(f(i2)) do i = 1, n2 aa(i) = tmp(i) enddo return end subroutine shap_1dco (nshap, nn, f, tmp) c--------------------------------------------- c conservative, order NOT reduced near boundaries implicit real(a-h,o-z),integer(i-n) dimension f(1), tmp(1), aa(1), bb(1) pointer (paa, aa), (pbb, bb) logical ZER common /shap_c25/ cs25(10), ZER, s_coef paa = loc(f(1)) pbb = loc(tmp(1)) do n = 1, nshap iab = paa paa = pbb pbb = iab f0 = bb(1) fp = bb(2) do i = 2, nn-1 fm = f0 f0 = fp fp = bb(i+1) aa(i) = (f0 - fp) + (f0 - fm) enddo aa(1) = bb(1) - bb(2) aa(nn) = bb(nn) - bb(nn-1) enddo const = cs25(nshap) do i = 1, nn f(i) = const * aa(i) enddo return end subroutine shap_1dp0 (nshap, nn, f, tmp) c--------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension f(1), tmp(1), aa(1), bb(1) pointer (paa, aa), (pbb, bb) logical ZER common /shap_c25/ cs25(10), ZER, s_coef paa = loc(f(1)) pbb = loc(tmp(1)) do n = 1, nshap iab = paa paa = pbb pbb = iab f1 = bb(1) f2 = bb(2) f0 = f1 fp = f2 do i = 2, nn-1 fm = f0 f0 = fp fp = bb(i+1) aa(i) = (f0 - fp) + (f0 - fm) enddo aa(1) = (f1 - f2) + (f1 - fp) aa(nn) = (fp - f1) + (fp - f0) enddo const = cs25(nshap) do i = 1, nn f(i) = const * aa(i) enddo return end c-------------------------------------------------------------------------- subroutine shap_3d (nord,key,SETX,SETY,npt,lxx,lyx,isy,isk, * ifx,ifpx,ify, aa,abc,filter,scoef) c-------------------------------------------------------------------------- c.....reduces order for all points on short segments c length=4 -> nshap = 1 c length=5,6 -> nshap = min(2,nord) c length=7,8 -> nshap = min(3,nord) c etc. c.....but if nshap <= LIM_SHAP, then DON'T FILTER segment at all implicit real(a-h,o-z),integer(i-n) dimension lxx(1),lyx(1),isy(1),isk(1), aa(1), bb(1), cc(1), abc(npt,1) dimension ifx(3,1), ifpx(5,1), ify(3,1) logical SETX, SETY, ZER, REDUC pointer (pbb, bb), (pcc, cc) external filter common /shap_c25/ cs25(10), ZER, s_coef common /new_filt/ MAXFO, nbx, nby, nfx, nfpx, nfy s_coef = scoef LIM_SHAP = key - 2 c sizeof(abc) = 3*npt pbb = loc(abc(1,1)) pcc = loc(abc(1,2)) c.....use a reduced order filter in a narrow passages. c c.......apply Shapiro filter in X direction do i = 1, npt bb(i) = aa(isk(i)) enddo ZER = SETX do k = 1, nfx nshap = min(nord, ifx(3,k)) if (nshap .gt. LIM_SHAP) then call filter (nshap, ifx(2,k), bb(ifx(1,k)), cc) else call zero_em (ifx(2,k), bb(ifx(1,k))) endif enddo do k = 1, nfpx nshap = min(nord, ifpx(5,k)) if (nshap .gt. LIM_SHAP) then if (ifpx(4,k) .eq. 0) then call shap_1dp0 (nshap, ifpx(2,k), bb(ifpx(1,k)), cc) else call shap_1dper (nshap, ifpx(1,k), bb, cc, filter) endif else call zero_em (ifpx(2,k), bb(ifpx(1,k))) call zero_em (ifpx(4,k), bb(ifpx(3,k))) endif enddo do i = 1, npt cc(isk(i)) = bb(i) enddo if (SETX) then do i = 1, nbx cc(lxx(i)) = 0. enddo endif if (SETY) then do i = 1, nby cc(lyx(i)) = 0. enddo endif do j = 1, npt i = isk(j) aa(i) = aa(i) - cc(i) enddo c.......apply Shapiro filter in Y direction do i = 1, npt bb(i) = aa(isy(i)) enddo ZER = SETY do k = 1, nfy nshap = min(nord, ify(3,k)) if (nshap .gt. LIM_SHAP) then call filter (nshap, ify(2,k), bb(ify(1,k)), cc) else call zero_em (ify(2,k), bb(ify(1,k))) endif enddo do i = 1, npt cc(isy(i)) = bb(i) enddo if (SETX) then do i = 1, nbx cc(lxx(i)) = 0. enddo endif if (SETY) then do i = 1, nby cc(lyx(i)) = 0. enddo endif do j = 1, npt i = isk(j) aa(i) = aa(i) - cc(i) enddo return end subroutine shap_1dcn (nshap, nn, f, tmp) c--------------------------------------------- c suppose to be an old key=6 case implicit real(a-h,o-z),integer(i-n) dimension f(1), tmp(1), aa(1), bb(1) pointer (paa, aa), (pbb, bb) logical ZER common /shap_c25/ cs25(10), ZER , s_coef paa = loc(f(1)) pbb = loc(tmp(1)) do n = 1, nshap iab = paa paa = pbb pbb = iab f0 = bb(1) fp = bb(2) do i = 2, nn-1 fm = f0 f0 = fp fp = bb(i+1) aa(i) = (f0 - fp) + (f0 - fm) enddo aa(1) = -aa(2) aa(nn) = -aa(nn-1) enddo const = cs25(nshap) do i = 1, nn f(i) = const * aa(i) enddo return end dyn_forc.f/ 839603022 1572 1572 100444 61557 ` c ------------------------------------------------ subroutine depth_init (npt, zin) c ------------------------------------------------ implicit real(a-h,o-z),integer(i-n) include 'comm_data.h' include 'comm_new.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch dimension zin(1) if (initb .eq. 0) then c.....Constant Depth (Flat Bottom) dep_max = zin(nz+1) call afill(npt, depth, dep_max) dep_min = dep_max elseif (initb .eq. 1) then c.....Read Bathymetry Data From a File call odb_open(idf_dp, fbdep(1:n_dep), 0) call data_on_model_grid(idf_dp, lret, 'bath') call read_zt (idf_dp, lret, npt, 1, 1, 'bath', tp, dept) c do i = 1, npt c dept(i) = max(dept(i),(zin(3)+zin(2))/2.) c dept(i) = max(dept(i),(zin(4)+zin(5))/2.) c enddo elseif (initb .eq. 2) then iseed = 10001 dept(1) = 50 + zin(nz+1)*ran(iseed) do i = 2, npt dept(i) = 50 + zin(nz+1)*ran(iseed) enddo do i = 1, npt dept(i) = max(dept(i),zin(1)) enddo elseif (initb .ge. 3) then c ramp depmin = (zin(initb-2) + zin(initb-1))/2. depmax = zin(nz+1) x1 = xm(1) xn = xm(nxp) xs = xn-x1 do i = 1, nxp tp(i) = depmin + (xm(i) - x1)*(depmax-depmin)/xs enddo y1 = ym(1) yn = ym(nyp) ys = yn-y1 do j = 1, nyp tp(j+nxp) = depmin + (ym(j) - y1)*(depmax-depmin)/ys enddo do k = 1, npt j = (iox(k)-1)/nxp + 1 i = iox(k) - (j-1)*nxp dept(k) = (tp(i)+tp(j+nxp))/2. enddo endif dept(1) = max(dep_min,dept(1)) do i = 2, npt dept(i) = max(dep_min,dept(i)) enddo dep_min = dept(1) dep_max = dept(1) do i = 2, npt dep_max = max(dep_max, dept(i)) dep_min = min(dep_min, dept(i)) enddo return end c -------------------------------------------------------------------- subroutine clim_init(npt,nstart,h0,sigma,dzin,hmf, * hclf,tclf,sclf,dclf,psif,tpf,nsponge,lsponge) c -------------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' include 'comm_data.h' dimension h0(1),hmf(npt,nz),hclf(npt,nz,1),dclf(npt,nz),dzin(nz+1), * tclf(npt,nz,1),sclf(npt,nz,1),tpf(npt,1),ind3(3),sigma(nz) * ,lsponge(nsponge), psif(npt,1) common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch c do k = nsig+1, nz do i = 1, npt hclf(i,k,1) = hmf(i,k) enddo enddo if (icl_h .eq. 0) then do k = 1, nsig do i = 1, npt hclf(i,k,1) = hmf(i,k) enddo enddo elseif (icl_h .eq. 1) then c........H: sigma structure between Mixed Layer & Thermocline - Static: call odb_open(idf_hcl, fbhcl(1:n_hcl), 0) call data_on_model_grid(idf_hcl, lclm, 'mltc') if (icl_htop .eq. 1) * call read_zt (idf_hcl,lclm,npt, 1,1, 'mltc', tpf, hclf(1,1,1)) if (icl_htop .eq. 0) call afill (npt, hclf, h0(1)) sigk = sigma(3) do i = 1, npt hclf(i,2,1) = 0.5*hclf(i,1,1) + sigk*(z_begin - 1.5*hclf(i,1,1)) enddo do k = 3, nsig - 1 sigkp = sigma(k+1) do i = 1, npt hclf(i,k,1) = (sigk+sigkp) * (z_begin - 1.5*hclf(i,1,1)) enddo sigk = sigkp enddo k = nsig do i = 1, npt hclf(i,k,1) = dzin(k+1) + sigma(k)*(z_begin - 1.5*hclf(i,1,1)) enddo elseif (icl_h .eq. 2) then c........H: sigma structure between Mixed Layer & Thermocline - Dynamic call odb_open(idf_hcl, fbhcl(1:n_hcl), 0) call data_on_model_grid(idf_hcl, lclm, 'mltc') call odb_rddm(idf_hcl, 'T', ntclm) call mem_alloc(p_tclm, ntclm, 2, 'tclm') call odb_rdgr(idf_hcl, 'T', ntclm, tclm) call it_catch (ntclm, tclm, nstart, it1, it2, clm_tscl) iclm = it2 if (icl_htop .eq. 1) then call read_zt (idf_hcl, lclm,npt, 1, it1, 'mltc', tpf, hclf(1,1,1)) call read_zt (idf_hcl, lclm,npt, 1, it2, 'mltc', tpf, hclf(1,1,2)) endif if (icl_htop .eq. 0) then call afill (npt, hclf(1,1,1), h0(1)) call afill (npt, hclf(1,1,2), h0(1)) endif sigk = sigma(3) do i = 1, npt hclf(i,2,1) = 0.5*hclf(i,1,1) + sigk*(z_begin - 1.5*hclf(i,1,1)) hclf(i,2,2) = 0.5*hclf(i,1,2) + sigk*(z_begin - 1.5*hclf(i,1,2)) enddo do k = 3, nsig - 1 sigkp = sigma(k+1) do i = 1, npt hclf(i,k,1) = (sigk+sigkp) * (z_begin - 1.5*hclf(i,1,1)) hclf(i,k,2) = (sigk+sigkp) * (z_begin - 1.5*hclf(i,1,2)) enddo sigk = sigkp enddo k = nsig do i = 1, npt hclf(i,k,1) = dzin(k+1) + sigma(k)*(z_begin - 1.5*hclf(i,1,1)) hclf(i,k,2) = dzin(k+1) + sigma(k)*(z_begin - 1.5*hclf(i,1,2)) enddo endif if (icl_psi .eq. 1) then call odb_open(idf_psi, fbpsi(1:n_psi), 0) call data_on_model_grid(idf_psi, lpsi, 'psi') call read_zt (idf_psi,lpsi,npt, 1,1, 'psi', tpf, psif(1,1)) elseif (icl_psi .eq. 2) then call odb_open(idf_psi, fbpsi(1:n_psi), 0) call data_on_model_grid(idf_psi, lpsi, 'psi') call odb_rddm(idf_psi, 'T', ntpsi) call mem_alloc(p_tpsi, ntpsi, 2, 'psi') call odb_rdgr(idf_psi, 'T', ntpsi, tpsi) call it_catch (ntpsi, tpsi, nstart, it1, it2, psi_tscl) ipsi = it2 call read_zt (idf_psi, lpsi,npt, 1, it1, 'psi', tpf, psif(1,1)) call read_zt (idf_psi, lpsi,npt, 1, it2, 'psi', tpf, psif(1,2)) endif if (icl_ts .eq. 0) return call odb_open(idf_t, fbtem(1:n_tem), 0) if (icl_h .eq. 0) call data_on_model_grid(idf_t, lclm, 'temp') call odb_rddm(idf_t, 'Z', nzclm) call mem_alloc(p_zclm, nzclm, 2, 'MZ for temp climatology') call odb_rdgr (idf_t, 'Z', nzclm, zclm) mz = nzclm if (use_salt) then call odb_open(idf_s, fbsal(1:n_sal), 0) call odb_rddm(idf_s, 'Z', mz) if (mz .ne. nzclm) * call perror1('Temp & Salt DATA should be on the same Z grid', 1) endif if (icl_ts .eq. 1) then !!.....time independent case: call read_linz(idf_t,lclm,npt,mpack,nz,mz,1,hclf,tclf,zclm,tp,'temp') if (use_salt) * call read_linz(idf_s,lclm,npt,mpack,nz,mz,1,hclf,sclf,zclm,tp,'salt') if (iv_bot .eq. 4) then do i = 1, npt tclf(i,nz,1) = TEMP_BOT if (use_salt) sclf(i,nz,1) = SALT_BOT enddo endif elseif (icl_ts .eq. 2) then !!.....time dependent case: call odb_rddm(idf_t, 'T', i) if (icl_h .ne. 2) then !!.....H_clim is time independent ntclm = i call mem_alloc(p_tclm, ntclm, 2, 'tclm') call odb_rdgr(idf_t, 'T', ntclm, tclm) call it_catch (ntclm, tclm, nstart, it1, it2, clm_tscl) iclm = it2 elseif (i .ne. ntclm ) then call perror1('MxTh & Temp DATA should be on the same T grid', 1) endif if (use_salt) then call odb_rddm(idf_s, 'T', i) if (i .ne. ntclm) * call perror1('Temp & Salt DATA should be on the same T grid', 1) endif call read_linz(idf_t, lclm, npt,mpack,nz,mz, it1, * hclf(1,1,1),tclf(1,1,1),zclm,tp, 'temp') k2_h = 1 if (icl_h .eq. 2) k2_h = 2 call read_linz(idf_t, lclm, npt,mpack,nz,mz, it2, * hclf(1,1,k2_h),tclf(1,1,2),zclm,tp, 'temp') if (use_salt) then call read_linz(idf_s, lclm, npt,mpack,nz,mz, it1, * hclf(1,1,1),sclf(1,1,1),zclm,tp, 'salt') call read_linz(idf_s, lclm, npt,mpack,nz,mz, it2, * hclf(1,1,k2_h),sclf(1,1,2),zclm,tp, 'salt') endif endif if (ipre.eq.1) then if (use_salt) call potn_dens (npt,nzi,tclf(1,1,1),sclf(1,1,1),dclf) call dconv_cl (npt,nz,nzi,hclf,tclf(1,1,1),sclf(1,1,1),dclf) if (use_salt) call potn_dens (npt,nzi,tclf(1,1,2),sclf(1,1,2),dclf) call dconv_cl (npt,nz,nzi,hclf,tclf(1,1,2),sclf(1,1,2),dclf) endif if (icl_rlx .eq. 1) then do j = 1, nyp if (ym(j) .gt. clm_no) then tp(j) = clm_coef * (ym(j)-clm_no)/(ym(nyp)-clm_no) elseif (ym(j) .lt. clm_so) then tp(j) = clm_coef * (clm_so-ym(j))/(clm_so-ym(1)) else tp(j) = 0. endif enddo do i = 1, npt j = (iox(i)-1)/nxp + 1 sponge(i) = tp(j) enddo elseif (icl_rlx .eq. 2) then do i = 1, npt sponge(i) = clm_coef enddo elseif (icl_rlx .eq. 3) then dsponge = real(ksponge) do i = 1, npt ixy = iox(i) ix = mod (ixy -1 ,nxp) + 1 iy = (ixy - ix)/nxp + 1 dmin = nxp+nyp do j = 1, nsponge kxy = lsponge(j) kx = mod (kxy -1 ,nxp) + 1 ky = (kxy - kx)/nxp + 1 d = sqrt(float((ix-kx)**2 + (iy-ky)**2)) c d = abs(ix-kx) + abs(iy-ky) dmin = min(d,dmin) enddo sponge(i) = clm_coef*max((dsponge-dmin)/dsponge,0.) enddo endif return end c ---------------------------------------------- subroutine h_init (npt, nz, nzi, nstart, hmf, hclf) c ---------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension hmf(npt,1), hclf(npt,nz,1), nzi(1) if (icl_h .eq. 1) then do i = 1, npt do k = 1, nzi(i) hmf(i,k) = hclf(i,k,1) enddo enddo elseif (icl_h .eq. 2) then do i = 1, npt do k = 1, nzi(i) hmf(i,k) = hclf(i,k,1) + clm_tscl*(hclf(i,k,2) - hclf(i,k,1)) enddo enddo endif return end c ----------------------------------------------------------------- subroutine temp_init (npt, nz, nzi, nstart, t0, tmf, tclf) c ----------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension t0(1), tmf(npt,1), tclf(npt,nz,1), nzi(1) c if (initt .eq. 0) then c.......constant values for each layer according to T_INIT c iseed = 10001 rand = 1. do i = 1, npt do k = 1, nzi(i) c rand = 1.+temp_coef*(2.*ran(iseed)-1.) tmf(i,k) = t0(k)*rand enddo enddo elseif (initt .eq. 3) then c.....from CLIMATOLOGY Data. if (icl_ts .eq. 2) then do i = 1, npt do k = 1, nzi(i) tmf(i,k) = tclf(i,k,1)+ clm_tscl*(tclf(i,k,2)- tclf(i,k,1)) enddo enddo else do i = 1, npt do k = 1, nzi(i) tmf(i,k) = tclf(i,k,1) enddo enddo endif endif return end c ----------------------------------------------------------------- subroutine salt_init (npt, nz, nzi, nstart, s0, smf, sclf) c ----------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension s0(1), smf(npt,1), sclf(npt,nz,1), nzi(1) c if (inits .eq. 0) then do i = 1, npt do k = 1, nzi(i) smf(i,k) = s0(k) enddo enddo elseif (inits .eq. 3) then c.....from CLIMATOLOGY Data. if (icl_ts .eq. 2) then do i = 1, npt do k = 1, nzi(i) smf(i,k) = sclf(i,k,1)+ clm_tscl*(sclf(i,k,2)- sclf(i,k,1)) enddo enddo else do i = 1, npt do k = 1, nzi(i) smf(i,k) = sclf(i,k,1) enddo enddo endif endif return end c---------------------------------------------------- subroutine tau_init (nstart,npt, dtaux, dtauy) c---------------------------------------------------- c..........initalize the winds according to MTAU implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' include 'comm_data.h' parameter (TAUCON = 10300., API = 3.14159265, TAUINV = 1./TAUCON) common/winds/mtau,matau,tausc,atau,froude,icloud common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch dimension dtaux(npt,1),dtauy(npt,1) taub = tausc/TAUCON tauc = atau/TAUCON if (mtau .eq. 1 .or. mtau .eq. 2) then call odb_open(idf_tx, fbwnd(1:n_wnd)//'.x', 0) call odb_open(idf_ty, fbwnd(1:n_wnd)//'.y', 0) call odb_rddm(idf_tx, 'T', ntau) call mem_alloc(p_ttau, ntau, 2, 'ttau') call odb_rdgr(idf_tx, 'T', ntau, ttau) call it_catch (ntau, ttau, nstart, it1, it2, tscl) itau = it2 call data_on_model_grid(idf_tx, ltau, 'tau') call read_zt (idf_tx, ltau, npt, 1, it1, 'taux', tp, dtaux(1,1)) call read_zt (idf_tx, ltau, npt, 1, it2, 'taux', tp, dtaux(1,2)) call read_zt (idf_ty, ltau, npt, 1, it1, 'tauy', tp, dtauy(1,1)) call read_zt (idf_ty, ltau, npt, 1, it2, 'tauy', tp, dtauy(1,2)) do i = 1, npt dtaux(i,1) = TAUINV * dtaux(i,1) dtaux(i,2) = TAUINV * dtaux(i,2) dtauy(i,1) = TAUINV * dtauy(i,1) dtauy(i,2) = TAUINV * dtauy(i,2) enddo if (mtau .eq. 1) then do i = 1, npt taux(i) = dtaux(i,1) + tscl * (dtaux(i,2) - dtaux(i,1)) tauy(i) = dtauy(i,1) + tscl * (dtauy(i,2) - dtauy(i,1)) enddo endif elseif (mtau .eq. 3) then c..........3 - annualy averaged climatology call odb_open(idf_tx, fbwnd(1:n_wnd)//'.x', 0) call odb_open(idf_ty, fbwnd(1:n_wnd)//'.y', 0) call odb_rddm(idf_tx, 'T', ntau) call data_on_model_grid(idf_tx, ltau, 'tau') do k = 1, ntau call read_zt (idf_tx, ltau, npt, 1, k, 'taux', tp, dtaux(1,2)) call read_zt (idf_ty, ltau, npt, 1, k, 'tauy', tp, dtauy(1,2)) do i = 1, npt dtaux(i,1) = dtaux(i,1) + dtaux(i,2) dtauy(i,1) = dtauy(i,1) + dtauy(i,2) enddo enddo coef = TAUINV/real(ntau) do i = 1, npt taux(i) = coef * dtaux(i,1) tauy(i) = coef * dtauy(i,1) enddo elseif (mtau .eq. 5) then c..........5 - COSINE winds if (itau_cos .eq. 0) then do j = 1, nyp tp(j) = taub*cos(API*(ym(j))/80.) enddo elseif (itau_cos .eq. 1) then y1 = ym(1) y2 = ym(nyp) do j = 1, nyp tp(j) = taub*cos(2.*API*( (ym(j)-y1)/(y2-y1) - 0.5)) enddo elseif (itau_cos .eq. 2) then y1 = ym(1) y2 = ym(nyp) do j = 1, nyp tp(j) = taub*cos(API*( (ym(j)-y1)/(y2-y1) - 0.5)) enddo endif do k = 1, npt j = (iox(k)-1)/nxp + 1 tmpx = tp(j) taux(k) = tmpx dtaux(k,1) = tmpx tauy(k) = tauc dtauy(k,1) = tauc enddo endif return end c ------------------------------------------------------------------ subroutine tau_lin (nstep,npt,ixd,im2d,blcf, taux,tauy,dtx,dty,tp) c ------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' parameter (TAUCON = 10300., API = 3.14159265, TAUINV = 1./TAUCON) dimension taux(1),tauy(1),dtx(npt,1),dty(npt,1) dimension ixd(1),im2d(1),blcf(1),tp(1) call it_catch (ntau, ttau, nstep, it1, it2, tscl) if (it2 .ne. itau) then itau = it2 do i = 1, npt dtx(i,1) = dtx(i,2) dty(i,1) = dty(i,2) enddo call read_zt (idf_tx, ltau, npt, 1, it2, 'taux', tp, dtx(1,2)) call read_zt (idf_ty, ltau, npt, 1, it2, 'tauy', tp, dty(1,2)) do i = 1, npt dtx(i,2) = TAUINV * dtx(i,2) dty(i,2) = TAUINV * dty(i,2) enddo endif do i = 1, npt taux(i) = dtx(i,1) + tscl * (dtx(i,2) - dtx(i,1)) tauy(i) = dty(i,1) + tscl * (dty(i,2) - dty(i,1)) enddo return end c ------------------------------------------------------------------ subroutine hflx_init (nstart, npt, nx, ny, temp, sstf, cldf, slrf, * nrelax, lrelax) c ------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' include 'comm_data.h' include 'comm_pbl.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch dimension temp(1), sstf(npt,1), cldf(npt,1), slrf(npt,1), lrelax(1) if (initq .eq. 0) then c.....Haney case Q = QCOF * (TATM - T) with Heat Transfer Coef.=30 w/m**2/k. do i = 1, npt sstf(i,1) = TATM sstf(i,3) = TATM enddo return elseif (initq .eq. 1) then c.....T_atm = initial T(i,1) = const(time) do i = 1, npt sstf(i,1) = temp(i) sstf(i,3) = temp(i) enddo elseif (initq .eq. 2) then c.....T_atm = average(SST) = const(time) call odb_open(idf_sst, fbsst(1:n_sst), 0) call odb_rddm(idf_sst, 'T', nsst) call data_on_model_grid(idf_sst, lsst, 'sst') do k = 1, nsst call read_zt (idf_sst, lsst, npt, 1, k, 'sst', tp, sstf(1,2)) do i = 1, npt sstf(i,1) = sstf(i,1) + sstf(i,2) enddo enddo coef = 1./real(nsst) do i = 1, npt sstf(i,1) = coef * sstf(i,1) sstf(i,3) = sstf(i,1) enddo elseif (initq .eq. 3) then c.....T_atm = SST(time) - climatology call odb_open(idf_sst, fbsst(1:n_sst), 0) call odb_rddm(idf_sst, 'T', nsst) call mem_alloc(p_tsst, nsst, 2, 'tsst') call odb_rdgr(idf_sst, 'T', nsst, tsst) call it_catch (nsst, tsst, nstart, it1, it2, tscl) isst = it2 call data_on_model_grid(idf_sst, lsst, 'sst') call read_zt (idf_sst, lsst, npt, 1, it1, 'sst', tp, sstf(1,1)) call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) elseif (initq .eq. 4) then c.....Q = Q(CLD,TAU,SLR),using Seager formulation.+[qcof*(SST_clim - SST_model)] call odb_open(idf_sst, fbsst(1:n_sst), 0) call odb_open(idf_cld, fbcld(1:n_cld), 0) call odb_rddm(idf_sst, 'T', nsst) call mem_alloc(p_tsst, nsst, 2, 'tsst') call odb_rdgr(idf_sst, 'T', nsst, tsst) call odb_rddm(idf_cld, 'T', i) if (i .ne. nsst) * call perror1('SST & Cloud Cover DATA should be on the same grid',1) call it_catch (nsst, tsst, nstart, it1, it2, tscl) isst = it2 call data_on_model_grid(idf_sst, lsst, 'sst') call read_zt (idf_sst, lsst, npt, 1, it1, 'sst', tp, sstf(1,1)) call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) call read_zt (idf_cld, lsst, npt, 1, it1, 'cld', tp, cldf(1,1)) call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) elseif (initq .eq. 5) then c.....*second* Richard-Benno formulation: Q = Q(T, solr, wndsp, clouds) call odb_open(idf_sst, fbsst(1:n_sst), 0) call odb_open(idf_cld, fbcld(1:n_cld), 0) call odb_open(idf_slr, fbslr(1:n_slr), 0) call odb_rddm(idf_sst, 'T', nsst) call mem_alloc(p_tsst, nsst, 2, 'tsst') call odb_rdgr(idf_sst, 'T', nsst, tsst) call odb_rddm(idf_cld, 'T', i) if (i .ne. nsst) * call perror1('H.flx & cloud data should be on the same grid',1) call odb_rddm(idf_slr, 'T', i) if (i .ne. nsst) * call perror1('H.flx & Sol.Rad. data should be on the same grid',1) call it_catch (nsst, tsst, nstart, it1, it2, tscl) isst = it2 call data_on_model_grid(idf_sst, lsst, 'sst') call read_zt (idf_sst, lsst, npt, 1, it1, 'sst', tp, sstf(1,1)) call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) call read_zt (idf_cld, lsst, npt, 1, it1, 'cld', tp, cldf(1,1)) call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) call read_zt (idf_slr, lsst, npt, 1, it1, 'solr',tp, slrf(1,1)) call read_zt (idf_slr, lsst, npt, 1, it2, 'solr',tp, slrf(1,2)) elseif (initq .eq. 6) then trans_coef = 0. elseif (initq .eq. 7) then c.....SST = Annual Mean SST; Cld = Annual Mean Cloud Cover: call odb_open(idf_sst, fbsst(1:n_sst), 0) call odb_open(idf_cld, fbcld(1:n_cld), 0) call odb_rddm(idf_cld, 'T', nsst) call odb_rddm(idf_cld, 'T', ncld) if (nsst .ne. ncld) * call perror1('SST & Cloud Cover DATA should have same grids', 1) call data_on_model_grid(idf_sst, lsst, 'sst') do k = 1, nsst call read_zt (idf_sst, lsst, npt, 1, k, 'sst', tp, sstf(1,2)) call read_zt (idf_cld, lsst, npt, 1, k, 'cld', tp, cldf(1,2)) do i = 1, npt sstf(i,1) = sstf(i,1) + sstf(i,2) cldf(i,1) = cldf(i,1) + cldf(i,2) enddo enddo coef = 1./real(nsst) do i = 1, npt sstf(i,1) = coef * sstf(i,1) cldf(i,1) = coef * cldf(i,1) enddo elseif (initq .eq. 8) then c.....PBL model Q = Q(T, solr, wndsp, clouds) call odb_open(idf_sst, fbsst(1:n_sst), 0) call odb_open(idf_cld, fbcld(1:n_cld), 0) call odb_open(idf_slr, fbslr(1:n_slr), 0) call odb_open(idf_wsp, fwsp(1:n_wsp), 0) call odb_open(idf_uwd, fuwd(1:n_uwd), 0) call odb_open(idf_vwd, fvwd(1:n_vwd), 0) call odb_open(idf_ah, fah(1:n_ah), 0) call odb_open(idf_at, fat(1:n_at), 0) call odb_rddm(idf_sst, 'T', nsst) call odb_rddm(idf_cld, 'T', ncld) call odb_rddm(idf_slr, 'T', nslr) call odb_rddm(idf_wsp, 'T', nwsp) call odb_rddm(idf_uwd, 'T', nuwd) call odb_rddm(idf_vwd, 'T', nvwd) call odb_rddm(idf_ah, 'T', nah) call odb_rddm(idf_at, 'T', nat) if (initq.eq.8 .and. nslr.ne.nsst) * call perror1('Solar radiation data is not on PBL grid', 1) if (nsst+ncld+nwsp+nuwd+nvwd+nah+nat .ne. 7*nsst) * call perror1('All PBL data should be on the same grid', 1) call mem_alloc(p_tsst, nsst, 2, 'tsst') call odb_rdgr(idf_sst, 'T', nsst, tsst) call it_catch (nsst, tsst, nstart, it1, it2, tscl) isst = it2 call data_on_model_grid(idf_sst, lsst, 'sst') call read_zt (idf_sst, lsst, npt, 1, it1, 'sst', tp, sstf(1,1)) call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) call read_zt (idf_cld, lsst, npt, 1, it1, 'cld', tp, cldf(1,1)) call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) call read_zt (idf_slr, lsst, npt, 1, it1, 'solr',tp, slrf(1,1)) call read_zt (idf_slr, lsst, npt, 1, it2, 'solr',tp, slrf(1,2)) call read_zt (idf_wsp, lsst, npt, 1, it1, 'wndspd', tp, wnsp(1,1)) call read_zt (idf_wsp, lsst, npt, 1, it2, 'wndspd', tp, wnsp(1,2)) call read_zt (idf_uwd, lsst, npt, 1, it1, 'uwnd', tp, uwnd(1,1)) call read_zt (idf_uwd, lsst, npt, 1, it2, 'uwnd', tp, uwnd(1,2)) call read_zt (idf_vwd, lsst, npt, 1, it1, 'vwnd', tp, vwnd(1,1)) call read_zt (idf_vwd, lsst, npt, 1, it2, 'vwnd', tp, vwnd(1,2)) NXY = nxp * nyp #ifdef gidon call read_zt (idf_ah, 0, NXY, 1, it1, 'spechum', tp, ahum(1,1)) call read_zt (idf_ah, 0, NXY, 1, it2, 'spechum', tp, ahum(1,2)) call read_zt (idf_at, 0, NXY, 1, it1, 'Tair', tp, atem(1,1)) call read_zt (idf_at, 0, NXY, 1, it2, 'Tair', tp, atem(1,2)) #else call read_zt (idf_ah, 0, NXY, 1, it1, 'airhum', tp, ahum(1,1)) call read_zt (idf_ah, 0, NXY, 1, it2, 'airhum', tp, ahum(1,2)) call read_zt (idf_at, 0, NXY, 1, it1, 'airtem', tp, atem(1,1)) call read_zt (idf_at, 0, NXY, 1, it2, 'airtem', tp, atem(1,2)) #endif drelax = real(krelax) do i = 1, npt ixy = iox(i) ix = mod (ixy -1 ,nxp) + 1 iy = (ixy - ix)/nxp + 1 dmin = nxp+nyp do j = 1, nrelax kxy = lrelax(j) kx = mod (kxy -1 ,nxp) + 1 ky = (kxy - kx)/nxp + 1 d = sqrt(float((ix-kx)**2 + (iy-ky)**2)) dmin = min(d,dmin) enddo relax(i) = max((drelax-dmin)/drelax,0.) enddo endif return end c --------------------------------------------------- subroutine evpr_init (nstart, npt, salt, sssf, evpf) c --------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' include 'comm_data.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch dimension salt(1), sssf(npt,1), evpf(npt,1) if (initep .eq. 0) then c given by EP = QCOF * (SATM - S) with Salt Transfer Coef.=30 o.e./m**2. do i = 1, npt sssf(i,1) = SATM sssf(i,3) = SATM enddo return elseif (initep .eq. 1) then c.....S_atm = initial S(i,1) = const(time) do i = 1, npt sssf(i,1) = salt(i) sssf(i,3) = salt(i) enddo elseif (initep .eq. 2) then c.....S_atm = average(SSS) = const(time) call odb_open(idf_sss, fbsss(1:n_sss), 0) call odb_rddm(idf_sss, 'T', nsss) if (nsst .ne. nsss) * call perror1('SST & SSS DATA should be on the same T grid',1) do k = 1, nsst call read_zt (idf_sss, lsst, npt, 1, k, 'sss', tp, sssf(1,2)) do i = 1, npt sssf(i,1) = sssf(i,1) + sssf(i,2) enddo enddo coef = 1./real(nsst) do i = 1, npt sssf(i,1) = coef * sssf(i,1) sssf(i,3) = sssf(i,1) enddo elseif (initep .eq. 3) then c.....S_atm = SSS(time) - climatology call odb_open(idf_sss, fbsss(1:n_sss), 0) call odb_rddm(idf_sss, 'T', nsss) if (nsst .ne. nsss) * call perror1('SST & SSS DATA should be on the same T grid',1) call it_catch (nsst, tsst, nstart, it1, it2, tscl) isss = it2 call read_zt (idf_sss, lsst, npt, 1, it1, 'sss', tp, sssf(1,1)) call read_zt (idf_sss, lsst, npt, 1, it2, 'sss', tp, sssf(1,2)) elseif (initep .eq. 4) then c.....read EP directly: call odb_open(idf_evp, fbevp(1:n_evp), 0) call odb_rddm(idf_evp, 'T', nevp) call mem_alloc(p_tevp, nevp, 2, 'evp') call odb_rdgr(idf_evp, 'T', nevp, tevp) call it_catch (nevp, tevp, nstart, it1, it2, tscl) ievp = it2 call data_on_model_grid(idf_evp, levp, 'evp') call read_zt (idf_evp, levp, npt, 1, it1, 'evp', tp, evpf(1,1)) call read_zt (idf_evp, levp, npt, 1, it2, 'evp', tp, evpf(1,2)) elseif (initep .eq. 6) then trans_coef = 0. elseif (initep.eq.8) then call odb_open(idf_sss, fbsss(1:n_sss), 0) call odb_open(idf_evp, fbevp(1:n_evp), 0) call odb_rddm(idf_sss, 'T', nsss) call odb_rddm(idf_evp, 'T', nevp) if(nevp.ne.nsst) call perror1('evp should have PBL T grid',1) if (nsss .ne. nsst) * call perror1('SST & SSS DATA should be on the same T grid',1) call it_catch (nsst, tsst, nstart, it1, it2, tscl) isss = it2 call read_zt (idf_sss, lsst, npt, 1, it1, 'sss', tp, sssf(1,1)) call read_zt (idf_sss, lsst, npt, 1, it2, 'sss', tp, sssf(1,2)) ievp = it2 call read_zt (idf_evp, lsst,npt,1,it1,'precip' ,tp, evpf(1,2)) call read_zt (idf_evp, lsst,npt,1,it2,'precip' ,tp, evpf(1,3)) endif return end c-------------------------------------------------------------------- subroutine qforc(nstep, npt, nx, ny, sstf, cldf, slrf, tpf, qbf) c--------------------------------------------------------------------- c update heat flux using current t(1), and SST(i) implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' include 'comm_data.h' include 'comm_pbl.h' dimension slrf(npt,1),sstf(npt,1),cldf(npt,1), tpf(npt,1), qbf(npt,1) if (initq .eq. 0) then do i = 1, npt q(i) = trans_coef * (TATM - t(i)) enddo elseif (initq .eq. 1 .or. initq .eq. 2) then do i = 1, npt q(i) = trans_coef * (sstf(i,1) - t(i)) enddo elseif (initq .eq. 3) then call it_catch (nsst, tsst, nstep, it1, it2, sst_tscl) if (it2 .ne. isst) then isst = it2 do i = 1, npt sstf(i,1) = sstf(i,2) enddo call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) endif do i = 1, npt sst_d = sstf(i,1) + sst_tscl * (sstf(i,2) - sstf(i,1)) q(i) = trans_coef * (sst_d - t(i)) sstf(i,3) = sst_d enddo elseif (initq .eq. 4) then call it_catch (nsst, tsst, nstep, it1, it2, tscl) if (it2 .ne. isst) then isst = it2 do i = 1, npt sstf(i,1) = sstf(i,2) cldf(i,1) = cldf(i,2) enddo call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) endif do i = 1, npt sstf(i,3) = sstf(i,1) + tscl * (sstf(i,2) - sstf(i,1)) cldf(i,3) = cldf(i,1) + tscl * (cldf(i,2) - cldf(i,1)) enddo tenso = enso_start + enso_scale * nstep call hflx_s89(tenso,npt,iox,t,sstf(1,3),cldf(1,3),ym, * taux,tauy,q,qr,qb,tpf(1,3)) elseif (initq .eq. 5) then c.....*new* Richard-Benno formulation using Solar Radiation & Clouds: call it_catch (nsst, tsst, nstep, it1, it2, tscl) if (it2 .ne. isst) then isst = it2 do i = 1, npt sstf(i,1) = sstf(i,2) cldf(i,1) = cldf(i,2) slrf(i,1) = slrf(i,2) enddo call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) call read_zt (idf_slr, lsst, npt, 1, it2, 'solr',tp, slrf(1,2)) endif do i = 1, npt sstf(i,3) = sstf(i,1) + tscl * (sstf(i,2) - sstf(i,1)) cldf(i,3) = cldf(i,1) + tscl * (cldf(i,2) - cldf(i,1)) slrf(i,3) = slrf(i,1) + tscl * (slrf(i,2) - slrf(i,1)) enddo call hflx_s94(npt,t,taux,tauy,sstf(1,3),cldf(1,3),slrf(1,3),q,qr,qb) elseif (initq .eq. 7) then tenso = enso_start + enso_scale * nstep call hflx_s89(tenso,npt,iox,t,sstf,cldf,ym,taux,tauy,q,qr,qb,tpf) elseif (initq .eq. 8) then c.....PBL model call it_catch (nsst, tsst, nstep, it1, it2, tscl) NXY = nx*ny newread = 0 if (it2 .ne. isst) then newread = 1 isst = it2 do i = 1, npt sstf(i,1) = sstf(i,2) cldf(i,1) = cldf(i,2) slrf(i,1) = slrf(i,2) wnsp(i,1) = wnsp(i,2) uwnd(i,1) = uwnd(i,2) vwnd(i,1) = vwnd(i,2) enddo do i = 1, NXY ahum(i,1) = ahum(i,2) atem(i,1) = atem(i,2) enddo call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) call read_zt (idf_slr, lsst, npt, 1, it2, 'solr',tp, slrf(1,2)) call read_zt (idf_wsp, lsst, npt, 1, it2, 'wndspd', tp, wnsp(1,2)) call read_zt (idf_uwd, lsst, npt, 1, it2, 'uwnd', tp, uwnd(1,2)) call read_zt (idf_vwd, lsst, npt, 1, it2, 'vwnd', tp, vwnd(1,2)) #ifdef gidon call read_zt (idf_ah, 0, NXY, 1, it2, 'spechum', tp, ahum(1,2)) call read_zt (idf_at, 0, NXY, 1, it2, 'Tair', tp, atem(1,2)) #else call read_zt (idf_ah, 0, NXY, 1, it2, 'airhum', tp, ahum(1,2)) call read_zt (idf_at, 0, NXY, 1, it2, 'airtem', tp, atem(1,2)) #endif endif if (newread.eq.1 .or.FIRST_STEP .or.mod(nstep, nstep_pbl).eq.0) then do i = 1, npt sstf(i,3) = sstf(i,1) + tscl * (sstf(i,2) - sstf(i,1)) cldf(i,3) = cldf(i,1) + tscl * (cldf(i,2) - cldf(i,1)) tpf(i,2) = uwnd(i,1) + tscl * (uwnd(i,2) - uwnd(i,1)) tpf(i,3) = vwnd(i,1) + tscl * (vwnd(i,2) - vwnd(i,1)) enddo do i = 1, npt wnd_speed = wnsp(i,1) + tscl * (wnsp(i,2) - wnsp(i,1)) if (wnd_speed .lt. pbl_wmin) then tpf(i,1) = pbl_wmin else tpf(i,1) = wnd_speed endif enddo do i = 1, NXY ahum(i,3) = ahum(i,1) + tscl * (ahum(i,2) - ahum(i,1)) atem(i,3) = atem(i,1) + tscl * (atem(i,2) - atem(i,1)) enddo call htflux_pbl (npt, nx, ny, iox, xm, ym, * t,cldf(1,3), tpf(1,1),tpf(1,2),tpf(1,3), ahum(1,3),atem(1,3), * qbf(1,2), qbf(1,3), qbf(1,4), amhum, amth) endif qcon_inv = 1./QCON qcon_gam = solr_gamma/QCON do i = 1, npt qsolr = slrf(i,1) + tscl * (slrf(i,2) - slrf(i,1)) qbf(i,1) = qsolr qcorr = trans_coef * (sstf(i,3) - t(i)) qbf(i,5) = QCON * qcorr c...........Total Heat Flux at the surface: c...........Q = (1-gamma)*Q_sol - Q_lh - Q_sh - Q_lw qr(i) = qcon_gam * qsolr qtot = qsolr - qbf(i,2) - qbf(i,3) - qbf(i,4) rx = relax(i) q(i) = (1.-rx) * (qcon_inv * qtot - qr(i)) + rx * qcorr enddo endif return end c--------------------------------------------------------- subroutine epforc(nstep, npt, salt, sssf, evpf, qbf) c--------------------------------------------------------- c update EP using current sal(1), and SSS(i) implicit real(a-h,o-z),integer(i-n) include 'comm_data.h' include 'comm_new.h' dimension salt(1),sssf(npt,1),evpf(npt,1), qbf(npt,1) parameter (R_MMDAY2MSEC = 1./(24. * 3600. * 1000.)) parameter (CLATHT2EVAP = 1./(2.5e6*1028.)) if (initep .eq. 0) then do i = 1, npt evpf(i,1) = trans_coef * (SATM - salt(i)) enddo elseif (initep .eq. 1 .or. initep .eq. 2) then do i = 1, npt evpf(i,1) = trans_coef * (sssf(i,1) - salt(i)) enddo elseif (initep .eq. 3) then if (isss .ne. isst) then isss = isst do i = 1, npt sssf(i,1) = sssf(i,2) enddo call read_zt (idf_sss, lsst, npt, 1, isss, 'sss', tp, sssf(1,2)) endif do i = 1, npt sss_d = sssf(i,1) + sst_tscl * (sssf(i,2) - sssf(i,1)) evpf(i,1) = trans_coef * (sss_d - salt(i)) sssf(i,3) = sss_d enddo elseif (initep .eq. 4) then call it_catch (nevp, tevp, nstep, it1, it2, tscl) if (it2 .ne. ievp) then ievp = it2 do i = 1, npt evpf(i,2) = evpf(i,3) enddo call read_zt (idf_evp, levp, npt, 1, it2, 'evp', tp, evpf(1,3)) endif do i = 1, npt c...........assumes that evp data in [mm/day]: E_P = evpf(i,2) + tscl * (evpf(i,3) - evpf(i,2)) evpf(i,1) = R_MMDAY2MSEC * salt(i) * E_P enddo elseif (initep.eq.8) then call it_catch (nsst, tsst, nstep, it1, it2, tscl) if (it2 .ne. ievp) then ievp = it2 do i = 1, npt evpf(i,2) = evpf(i,3) sssf(i,1) = sssf(i,2) enddo call read_zt (idf_evp, lsst, npt, 1, it2, 'precip', tp, evpf(1,3)) call read_zt (idf_sss, lsst, npt, 1, it2, 'sss', tp, sssf(1,2)) endif do i = 1, npt precip = R_MMDAY2MSEC *(evpf(i,2) + tscl*(evpf(i,3) - evpf(i,2))) #ifdef gidon evapor = CLATHT2EVAP * qbf(i,2) * 0.7 #else evapor = CLATHT2EVAP * qbf(i,2) #endif sss_d = sssf(i,1) + tscl * (sssf(i,2) - sssf(i,1)) ecorr = trans_coef * (sss_d - salt(i)) rx = relax(i) evpf(i,1) = (1.-rx)*(evapor - precip) * salt(i) + rx * ecorr enddo endif return end c--------------------------------------------- subroutine hbcset(npt, nzp, nsig, lok, hmf, hclf) c--------------------------------------------- c apply B.C. to the H field if relaxing to climatology. implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) dimension hmf(npt,1),hclf(npt,nzp,1) dimension lok(4*MAXSID,nz) nlo = nlok(1) if (icl_h .eq. 1) then do k = 1, nsig do n = 1, nlo i = lok(n,1) hmf(i,k) = hclf(i,k,1) enddo enddo elseif (icl_h .eq. 2) then do k = 1, nsig do n = 1, nlo i = lok(n,1) hmf(i,k) = hclf(i,k,1) + clm_tscl*(hclf(i,k,2) - hclf(i,k,1)) enddo enddo endif return end c----------------------------------------------------- subroutine tbcset(npt, nzp, lok, t0, hmf, tmf, tclf) c----------------------------------------------------- c apply B.C. to the temperature field. The land boundaries have zero c heat flux, the open ocean boundaries have a specified temperature. c c lok = (input) regular or compressed x-sort indices of the "open c ocean" boundary points at which t is constant. c nlok = (common) number of open ocean grid points. nlo .gt. 0 is c equivalent to having mtc=1 in previous versions c of the model. implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) dimension t0(1),tmf(npt,1),hmf(npt,1),tclf(npt,nzp,1) dimension lok(4*MAXSID,nz) c if (icl_ts .eq. 0) then do k = 1, nz nlk = nlok(k) if (nlk.eq.0) return tik = t0(k) do n = 1, nlk i = lok(n,k) tmf(i,k) = tik * hmf(i,k) enddo enddo elseif (icl_ts .eq. 1) then do k = 1, nz nlk = nlok(k) if (nlk.eq.0) return do n = 1, nlk i = lok(n,k) tmf(i,k) = tclf(i,k,1)*hmf(i,k) enddo enddo elseif (icl_ts .eq. 2) then do k = 1, nz nlk = nlok(k) if (nlk.eq.0) return do n = 1, nlk i = lok(n,k) tmf(i,k) = hmf(i,k) * * (tclf(i,k,1) + clm_tscl*(tclf(i,k,2) - tclf(i,k,1))) enddo enddo endif return end c---------------------------------------------------------------------- subroutine it_catch (NN, tt, nstep, it1, it2, tscl) c---------------------------------------------------------------------- c.....Returns relative shift & indexes which are bracket nstep. implicit real(a-h,o-z),integer(i-n) dimension tt(1) include 'comm_new.h' denso = enso_start + enso_scale * nstep tstep = tt(2) - tt(1) if (tt(nn)-tt(1)+tstep .eq. 12.) then c.....Periodic Climatology Data c# denso = denso - 12.*(int(denso)/12) denso = mod(denso, 12.) if (denso .lt. 0.) denso = denso + 12. do it2 = 1, NN if (denso .lt. tt(it2)) goto 100 enddo denso = denso - 12. it2 = 1 100 if (it2 .eq. 1) then it1 = NN tscl = (12. - tt(NN) + denso)/(12. - tt(NN) + tt(1)) else it1 = it2 - 1 tscl = (denso - tt(it1))/(tt(it2) - tt(it1)) endif else c.....Non-periodic Data do it2 = 1, NN if (denso .lt. tt(it2)) goto 200 enddo it2 = NN+1 tscl = 0. 200 if (it2 .eq. 1) then it1 = 1 tscl = 0. elseif(it2 .eq. NN+1) then it1 = NN it2 = NN tscl = 0. else it1 = it2 - 1 tscl = (denso - tt(it1))/(tt(it2) - tt(it1)) endif endif return end c-------------------------------------------------------- subroutine data_on_model_grid (idf, lret, tag) c-------------------------------------------------------- character*(*) tag common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch include 'comm_new.h' include 'comm_data.h' logical grids_equiv lret = 1 if (idatgr .eq. 0) then c........check if data on the same grid as the model: if ( grids_equiv(idf, nxp,nyp,nxyc, nsx,nsy, tp)) lret = 0 c........check if data on the same grid as previous data: elseif ( grids_equiv(idf, mxp,myp,mpack,msx,msy, tp)) then lret = 1 c........check if data on the same grid as the model: elseif ( grids_equiv(idf, nxp,nyp,nxyc, nsx,nsy, tp)) then lret = 0 else write(6, *) tag, 'Only one data GRID allowed! Stop.' stop endif return end c------------------------------------------------------------------- logical function grids_equiv (idf, kxp,kyp,kpack,ksx,ksy, tpp) c------------------------------------------------------------------- dimension tpp(1), kask(1000) logical odb_ifatt common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc include 'comm_new.h' include 'comm_data.h' m_p = 0 call odb_rddm(idf, 'NPACK', m_p) m_x = 0 call odb_rdgr(idf, 'X', m_x, tpp) xer = 1.e-6*(xm(nxp) - xm(1)) if (xm(1) .lt. tpp(1)-xer .or. xm(nxp) .gt. tpp(m_x)+xer) then write (6, *) '!!! X grid of DATA must cover the model region' stop endif m_sx = 0 if ( odb_ifatt(idf, 'X', 'stretched') ) * call odb_getiattr(idf, 'X', 'stretched', m_sx) m_y = 0 yer = 1.e-6*(ym(nyp) - ym(1)) call odb_rdgr(idf, 'Y', m_y, tpp(m_x+1)) if (ym(1).lt. tpp(m_x+1)-yer .or. ym(nyp) .gt. tp(m_x+m_y)+yer) then write (6, *) '!!! Y grid of DATA must cover the model region' stop endif m_sy = 0 if ( odb_ifatt(idf, 'Y', 'stretched') ) * call odb_getiattr(idf, 'Y', 'stretched', m_sy) m_seg = 0 call odb_rddm (idf, 'NMASK', m_seg) call odb_rdvar(idf, 'MASK', tpp(m_x+m_y+1)) if (m_p.ne.kpack .or. * m_x.ne.kxp .or. m_y.ne.kyp .or. * m_sx.ne.ksx .or. m_sy.ne.ksy ) then grids_equiv = .FALSE. if (idatgr .eq. 0) then mpack = m_p mxp = m_x msx = m_sx myp = m_y msy = m_sy mseg = m_seg call datagrid_memory(tp) call blin_indx(tp) call blin_coef(tp(mseg+1)) endif else grids_equiv = .TRUE. endif return end c----------------------------------------------------------------- subroutine read_zt (idf, key, npt, iz, it, tag, ftmp, fdata) c----------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension ftmp(1), fdata(1) character*(*) tag include 'comm_data.h' if (key .eq. 0) then !! data on MODEL grid call odb_rd1v3 (idf, iz, it, tag, fdata) else !! data on a different grid call odb_rd1v3 (idf, iz, it, tag, ftmp) call blin_intr(npt, ixd, im2d, blcf, ftmp, fdata) endif return end c------------------------------------------------------- integer function nearest(ixy, xd, yd, iseg) c------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension xd(1), yd(1), iseg(1) include 'comm_new.h' iy0 = 1 + (ixy-1)/mxp ix0 = ixy - mxp*(iy0-1) x0 = xd(ix0) y0 = yd(iy0) nearest = iseg(1) iy = 1 + (nearest-1)/mxp ix = nearest - (iy-1)*mxp dmin = (xd(ix)-x0)**2 + (yd(iy)-y0)**2 do j = 2, mseg i = iseg(j) iy = 1 + (i-1)/mxp ix = i - mxp*(iy-1) d = (xd(ix)-x0)**2 + (yd(iy)-y0)**2 if (d .lt. dmin) then dmin = d nearest = i endif enddo return end c-------------------------------------- subroutine blin_coef(iw) c-------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension iw(1) common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc include 'comm_data.h' include 'comm_new.h' call bracket(mxp, xd, nxp, xm, iw) call bracket(myp, yd, nyp, ym, iw(nxp+1)) do k = 1, nxyc j = 1 + (iox(k)-1)/nxp i = iox(k) - (j-1)*nxp c.....find the i,j location for the four surrounding DATA grid points. i1 = iw(i) j1 = iw(nxp+j) c.....x-sort index of four DATA points surrounding MODEL point (i,j). im2d(k) = i1 + (j1-1)*mxp c.....find the interpolation ratios. fx = (xm(i)-xd(i1))/(xd(i1+1)-xd(i1)) fy = (ym(j)-yd(j1))/(yd(j1+1)-yd(j1)) blcf(k) = (1.-fx)*(1.-fy) blcf(k+nxyc) = fx*(1.-fy) blcf(k+2*nxyc) = (1.-fx)*fy blcf(k+3*nxyc) = fx*fy enddo return end c ----------------------------------------------------------------- subroutine bracket(nx1,x1,nx2,x2,it) c ----------------------------------------------------------------- c find the elements of x1 which bracket each element of x2. c returns it(i), for i=1,nx2 such that: c x1(it(i)) .le. x2(i) .and. x2(i) .le. x1(it(i)+1) c nx1 = (input) length of x1. c x1 = (input) must have x1(i+1) .gt. x1(i), i=1,nx1-1. c nx2 = (input) length of x2. c x2 = (input) must have x2(i+1) .gt. x2(i), i=1,nx2-1. c it = (output) nx2 indices of the lower side of the pair of c consecutive elements of x1 which bracket x2(i). c c must input x1(1).le.x2(1) .and. x1(nx1).ge.x2(nx2). c dimension x1(1),x2(1),it(1) c i1 = 1 do 20 i2=1,nx2 10 if(x2(i2).ge.x1(i1) .and. x2(i2).le.x1(i1+1)) goto 20 i1 = i1 + 1 if(i1.lt.nx1-1) goto 10 20 it(i2) = i1 return c end of bracket. end c---------------------------------------------------------------- subroutine clim_updt(npt,nz,nstep, h0,sigma,dzin,hclf,tclf,sclf,dclf) c---------------------------------------------------------------- include 'comm_new.h' include 'comm_data.h' dimension h0(1),hclf(npt,nz,1),tclf(npt,nz,1),sclf(npt,nz,1) dimension dclf(npt,nz),sigma(nz),dzin(nz+1) common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch if (icl_ts .ne. 2) return call it_catch (ntclm, tclm, nstep, it1, it2, clm_tscl) c.....if we are still within bracketing months: if (it2 .eq. iclm) return iclm = it2 if (icl_h .eq. 2 ) then !!..H-clim is time dependent do k = 1, nz !!...save old time do i = 1, npt hclf(i,k,1) = hclf(i,k,2) enddo enddo if (icl_htop .eq. 1) * call read_zt (idf_hcl, lclm,npt, 1, it2, 'mltc', tp, hclf(1,1,2)) sigk = sigma(3) do i = 1, npt hclf(i,2,2) = 0.5*hclf(i,1,2) + sigk*(z_begin - 1.5*hclf(i,1,2)) enddo do k = 3, nsig - 1 sigkp = sigma(k+1) do i = 1, npt hclf(i,k,2) = (sigk+sigkp) * (z_begin - 1.5*hclf(i,1,2)) enddo sigk = sigkp enddo k = nsig do i = 1, npt hclf(i,k,2) = dzin(k+1) + sigma(k)*(z_begin - 1.5*hclf(i,1,2)) enddo endif do k = 1, nz !!...save old time do i = 1, npt tclf(i,k,1) = tclf(i,k,2) enddo enddo if (use_salt) then do k = 1, nz !!...save old time do i = 1, npt sclf(i,k,1) = sclf(i,k,2) enddo enddo endif k2_h = 1 if (icl_h .eq. 2) k2_h = 2 call read_linz(idf_t, lclm, npt,mpack,nz,nzclm, it2, * hclf(1,1,k2_h),tclf(1,1,2),zclm,tp, 'temp') if (use_salt) then call read_linz(idf_s, lclm, npt,mpack,nz,nzclm, it2, * hclf(1,1,k2_h),sclf(1,1,2),zclm,tp, 'salt') endif if (ipre.eq.1) then if (use_salt) call potn_dens (npt,nzi,tclf(1,1,2),sclf(1,1,2),dclf) call dconv_cl (npt,nz,nzi,hclf,tclf(1,1,2),sclf(1,1,2),dclf) endif return end c---------------------------------------------------------------- subroutine psi_updt(npt,nstep,psif) c---------------------------------------------------------------- include 'comm_new.h' include 'comm_data.h' dimension psif(npt,1) if (icl_psi .ne. 2) return call it_catch (ntpsi, tpsi, nstep, it1, it2, psi_tscl) if (it2 .eq. ipsi) return ipsi = it2 do i = 1, npt psif(i,1) = psif(i,2) enddo call read_zt (idf_psi, lpsi,npt, 1, it2, 'psi', tp, psif(1,2)) return end c----------------------------------------------------------------------- subroutine clim_relax(npt,nz,hmf,tmf,smf,hclf,tclf,sclf) c----------------------------------------------------------------------- include 'comm_new.h' include 'comm_data.h' dimension hmf(npt,1),tmf(npt,1),smf(npt,1), * hclf(npt,nz,1),tclf(npt,nz,1),sclf(npt,nz,1) if (icl_rlx .eq. 0) return !! NO RELAXATION - EXIT if (icl_h .eq. 1) then !! H-clim time independent do i = 1, npt coef = sponge(i) do k = 1, nzi(i) hmf(i,k) = hmf(i,k) - coef*(hmf(i,k)-hclf(i,k,1)) enddo enddo elseif (icl_h .eq. 2) then !! h_clim time varying do i = 1, npt coef = sponge(i) if (coef .ne. 0.) then do k = 1, nzi(i) hcl = hclf(i,k,1) + clm_tscl*(hclf(i,k,2) - hclf(i,k,1)) hmf(i,k) = hmf(i,k) - coef*(hmf(i,k) - hcl) enddo endif enddo endif if (icl_ts .eq. 1) then if (use_salt) then do i = 1, npt coef = sponge(i) if (coef .ne. 0.) then do k = 1, nzi(i) tmf(i,k) = tmf(i,k) - coef*(tmf(i,k)-tclf(i,k,1)) smf(i,k) = smf(i,k) - coef*(smf(i,k)-sclf(i,k,1)) enddo endif enddo else do i = 1, npt coef = sponge(i) if (coef .ne. 0.) then do k = 1, nzi(i) tmf(i,k) = tmf(i,k) - coef*(tmf(i,k)-tclf(i,k,1)) enddo endif enddo endif elseif (icl_ts .eq. 2) then !!...vary hmix/hthermo if (use_salt) then do i = 1, npt coef = sponge(i) if (coef .ne. 0.) then do k = 1, nzi(i) tcl = tclf(i,k,1) + clm_tscl*(tclf(i,k,2) - tclf(i,k,1)) scl = sclf(i,k,1) + clm_tscl*(sclf(i,k,2) - sclf(i,k,1)) tmf(i,k) = tmf(i,k) - coef*(tmf(i,k) - tcl) smf(i,k) = smf(i,k) - coef*(smf(i,k) - scl) enddo endif enddo else do i = 1, npt coef = sponge(i) if (coef .ne. 0.) then do k = 1, nzi(i) tcl = tclf(i,k,1) + clm_tscl*(tclf(i,k,2) - tclf(i,k,1)) tmf(i,k) = tmf(i,k) - coef*(tmf(i,k) - tcl) enddo endif enddo endif endif return end c----------------------------------------------------------------------- subroutine psi_relax(npt,pmf,psif,psib,nbx,lxx,nby,lyy) c----------------------------------------------------------------------- include 'comm_new.h' include 'comm_data.h' dimension pmf(npt),psif(npt,1),psib(npt),lxx(1),lyy(1) if (icl_psi .eq. 0) return c keep boundary conditions for psi: do i = 1, npt psib(i) = pmf(i) enddo if (icl_psi .eq. 1) then do i = 1, npt c# coef = 1. coef = clm_psi*sponge(i) pmf(i) = pmf(i) - coef*(pmf(i)-psif(i,1)) enddo elseif (icl_psi .eq. 2) then do i = 1, npt coef = clm_psi*sponge(i) p = psif(i,1) + psi_tscl*(psif(i,2) - psif(i,1)) pmf(i) = pmf(i) - coef*(pmf(i) - tcl) enddo endif c restore boundary conditions for psi: do i = 1, nbx ib = lxx(i) pmf(ib) = psib(ib) enddo do i = 1, nby ib = lyy(i) pmf(ib) = psib(ib) enddo return end c--------------------------------- subroutine afill(n, a, v) c--------------------------------- dimension a(1) do i = 1, n a(i) = v enddo return end c----------------------------------------------------------------------------- subroutine read_linz(idf,key,NPT,MPT,NZ,MZ,it, hdat,fdat,zvert,fvert,tag) c----------------------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension hdat(npt,1),fdat(npt,1), zvert(1),fvert(1) character*(*) tag include 'comm_new.h' include 'comm_data.h' dimension aa(npt,1), bb(mpt,1) pointer (p_aa, aa), (p_bb, bb) if (key .eq. 0) then call mem_alloc(p_aa, MZ*npt, 2, 'AA space in read_linz') do k = 1, MZ call odb_rd1v3(idf, k, it, tag, aa(1,k)) enddo do i = 1, npt do k = 1, mz fvert(k) = aa(i,k) enddo call zlin_intrp (i, npt,nz,mz, hdat,fdat,zvert,fvert) enddo call mem_free(p_aa, MZ*npt, 2) else call mem_alloc(p_bb, MZ*mpt, 2, 'BB space in read_linz') do k = 1, MZ call odb_rd1v3(idf, k, it, tag, bb(1,k)) enddo call zlin_blin(NPT,MPT,NZ,MZ,ixd,im2d,blcf,bb,hdat,fdat,zvert,fvert) call mem_free(p_bb, MZ*mpt, 2) endif return end c----------------------------------------------------------------------- subroutine zlin_blin(NPT,MPT,NZ,MZ,ixd,im2d,blcf,aa,h,f,zval,fval) c----------------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension ixd(1),im2d(1),blcf(npt,1) dimension aa(mpt,1), h(npt,1),f(npt,1), zval(1),fval(1) do i = 1, npt i1 = im2d(i) n1 = ixd(i1) n2 = ixd(i1+1) n3 = ixd(i1+mxp) n4 = ixd(i1+mxp+1) b1 = blcf(i,1) b2 = blcf(i,2) b3 = blcf(i,3) b4 = blcf(i,4) do k = 1, mz fval(k) = b1*aa(n1,k) + b2*aa(n2,k) + b3*aa(n3,k) + b4*aa(n4,k) enddo call zlin_intrp (i, npt,nz,mz, h,f,zval,fval) enddo return end c------------------------------------------------------------------------ subroutine blin_intr(npt, ixd, im2d, blcf, fd, f) c------------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) dimension ixd(1), im2d(1), blcf(npt,1), f(1), fd(1) include 'comm_new.h' do i = 1, npt i1 = im2d(i) f(i) = blcf(i,1)*fd(ixd(i1)) + blcf(i,2)*fd(ixd(i1+1)) * + blcf(i,3)*fd(ixd(i1+mxp)) + blcf(i,4)*fd(ixd(i1+mxp+1)) enddo return end c------------------------------------------------------- subroutine blin_indx (iseg) c------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension iseg(2,1) include 'comm_data.h' include 'comm_new.h' c.....fill in ixd() according with the data compression iseg(2,mseg/2): k = 0 do i = 1, mseg/2 do j = iseg(1,i), iseg(2,i) k = k + 1 ixd(j) = k enddo enddo c.....continue data to all points do k = 1, mxp*myp if (ixd(k) .eq. 0) ixd(k) = ixd(nearest(k, xd, yd, iseg)) enddo return end c------------------------------------------------------------- subroutine zlin_intrp(i, npt, nz, mz, h, f, zval, fval) c------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension h(npt,1), f(npt,1), zval(1), fval(1) zbot = zval(mz) fbot = fval(mz) mnext = 2 scale = (fval(mnext)-fval(mnext-1))/(zval(mnext)-zval(mnext-1)) shift = fval(mnext-1) - scale*zval(mnext-1) dlay = 0.5*h(i,1) zlay = dlay do k = 1, nz if (zlay .gt. zval(mnext)) then if (zlay .gt. zbot) then shift = fbot scale = 0. else do m = mnext+1, mz if (zlay .le. zval(m)) then scale = (fval(m) - fval(m-1))/(zval(m) - zval(m-1)) shift = fval(m-1) - scale*zval(m-1) mnext = m goto 100 endif enddo endif endif 100 f(i,k) = shift + scale * zlay dlay = h(i,k) - dlay zlay = zlay + 2.*dlay enddo return end c------------------------------------------------------------- subroutine t_limit(npt, nzi, t) c------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension t(npt,1), nzi(npt) do i = 1, npt do k = 1, nzi(i) t(i,k) = max(-1.7,t(i,k)) enddo enddo return end dyn_glob.f/ 839513370 1572 1572 100444 3158 ` subroutine set_pbc (nxp, nyp, npbc, lpbcw, lpbce, mask) c---------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' dimension lpbcw(1), lpbce(1), mask(nxp*nyp) npbc = 0 do j = 1, nyp j1 = 1 + (j-1)*nxp jnx = j*nxp ierr = 0 if ( mask(j1) .ne. 0 ) then if ( mask(jnx) .eq. 0 ) then ierr = nxp+1 else do i = 1, MINSEG - 1 if (ierr.eq.0 .and. mask(j1+i).eq.0) then ierr = i elseif (ierr.eq.0 .and. mask(jnx-i).eq.0) then ierr = nxp+1-i endif enddo endif if (ierr .ne. 0) then write (6, *) 'A land is too close for PBC [i,j]=',ierr,j else npbc = npbc + 1 lpbcw(npbc) = mask(j1) lpbce(npbc) = mask(jnx) endif endif enddo return end c ------------------------------------------------------------------ subroutine set_bpx (nxp, nyp, mask, maxnb,minseg,nbx,lxx,snx) c ------------------------------------------------------------------ c find the boundary indices for a x-sort in presence of periodic B.C.. c a replacement for bound() in bndxy() c maxnb = (input) max. storage space for lxx and snx. c minseg = (input) required minimum # of consecutive ocean points c nbx = (output) # of x/y boundary indices of the x or y sort. c lxx = (output) x or y bndry indices of a compressed x or y sort. c snx = (output) nbx signs for the boundaries:=1 if the land -> ocean c implicit real(a-h,o-z),integer(i-n) character*72 msg dimension mask(nxp,1), lxx(1),snx(1) logical prev, curr c nbx = 0 do irow = 1, nyp prev = (mask(1, irow) .eq. 0) ista = 1 do icol = 2, nxp c ista = 1 ixy = mask(icol, irow) curr = (ixy .eq. 0) if ( curr .ne. prev ) then nbx = nbx + 1 if (nbx .gt. MAXNB) then write (msg, 101) MAXNB 101 format ('set_pbx: insufficient space' * ' for lbx, inrease MAXNB=', i10, '$') call perror1 (msg, 1) endif if ( prev ) then lxx(nbx) = ixy snx(nbx) = 1. ista = icol else if (icol-ista .lt. minseg) then write (msg, 102) icol-ista, ista, irow 102 format ('set_bpx: only', i3, * ' consecutive ocean grid pts', * ' next to (i,j)= ', 2i5, '$') call perror1(msg, 1) endif lxx(nbx) = mask(icol-1, irow) snx(nbx) = -1. endif prev = curr endif enddo enddo c end of set_bpx end dyn_hflx.f/ 839513370 1572 1572 100444 27731 ` c ------------------------------------------------------------------------- subroutine hflx_s89(tenso,npt,iox,t,tclim,cloudy,y,taux,tauy,q,qr,qb,tp) c ------------------------------------------------------------------------- c update the model heat flux using the 1989 Seager et al. formulation. c t = (input) model sst in degrees c. c cloudy = (input) cloud cover as a fraction (0 to 1). c y = (input) model grid latitudes in degrees. c q = (output) heat flux. dimension iox(1),t(1),tclim(1),cloudy(1),y(1),taux(1),tauy(1), * q(1),qr(1), qb(npt,1),tp(nyp,1) complex CPI18,EXLAT,EXPHI,EX2PHI common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /new_hfxevp/ trans_coef, QCON, rlx_time, solr_gamma, TATM, SATM save jmon parameter (RTODEG = 180./3.14159265) data TAUA/.017/,TAUCON/10300./,UVMIN/4.0/ data cpi18 /(0.98481,-0.17365)/ c......for the tropic pacific: data al,acld /0.06,0.75/ data aalpha,rh,asst,ct0 /0.0020,0.78,1.667,-5.0/ c......for the tropical atlantic: c data al,acld /0.06,0.66/ c data aalpha,rh,asst,ct0 /0.0019,0.735,1.8,-5.0/ c.....parameter definitions: c rjuldy = julian day (0 = 1 jan). c uvmin = minimum wind speed in m/s. c al = albedo. c acld = cloud coefficient. c aalpha = alpha coefficient. c rh = pseudo relative humidity. c asst = sst coefficient. c cto = sst coefficient times offset. c cpi18 = cexp( (0,1)*(-pi/18.0) ). c c.....set constants used to find heat flux. a1mrh = 1.0 - rh a1mal = 1.0 - al c.....get the current model time in julian days: call DayOfYear(tenso, juld, july) call enso2date(tenso, id,imon,iy) rjuldy = juld-1 pha = 6.28318/real(july) phi = pha*(rjuldy - 21.0) exphi = cexp((0,1)*phi) cosphi = real(exphi) sinphi = aimag(exphi) ex2phi = exphi**2 cos2phi = real(ex2phi) sin2phi = aimag(ex2phi) arg = 23.45*sin((rjuldy-82.0)*pha) c the formulae from Weare 1980 are converted to w/m**2 and radians. c e.g. a1 from Weare is now a1=9.63 + 192.44*cos(rlat+90) and c in the calculatiion for the noon solar angle c alpha = arcsin(cos(rlat)*cos(arg1) + sin(rlat)*sin(arg1)) c = arcsin(cos(rlat - arg1)) c = arcsin(sin(rlat - arg1 + 90.)). c c.....compute the latitude dependent coefficients. do j = 1, nyp rlat = y(j)/rtodeg exlat = cexp((0,1)*rlat) cosrlat = real(exlat) sinrlat = aimag(exlat) c........set the coefficients for the clear sky solar radiation function. a0 = -15.82 + 326.87*cosrlat a1 = 9.63 - 192.44*sinrlat b1 = -3.27 + 108.7*sinrlat a2 = -0.64 -7.8*real(exlat**2) b2 = -0.5 + 14.42*real((exlat**2)*cpi18) c........tp(j,1) = q0 ! find q0, the clear sky radition. tp(j,1) = a0 + a1*cosphi + b1*sinphi + a2*cos2phi + b2*sin2phi c........find alpha, the noon solar altitude or angle. alpha = arg - y(j) + 90. tp(j,2) = alpha enddo c c this if statement is equivalent to arcsin(sin(x)) for the range c of alpha encountered. do 20 j = 1, nyp 20 if(tp(j,2) .gt. 90.0) tp(j,2) = 180. - tp(j,2) taud2 = sqrt(TAUCON/TAUA) qcon_inv = 1. / qcon qcon_gam = SOLR_GAMMA / qcon cnst1 = 2500000.0 / 461.0 cnst2 = 1.0 / 273.15 cnst3 = 0.622*6.11 cnst4 = 4.59373*a1mrh c.....compute the heat flux. do k = 1, npt j = (iox(k)-1)/nxp + 1 i = iox(k) - (j-1)*nxp c........set a minimum wind speed of UVMIN(m/s) to avoid underestimate c of wind magnitude due to use of monthly averages. tc = amax1(taud2*(taux(k)**2 + tauy(k)**2)**.25, UVMIN) exparg = cnst1*(cnst2 - 1.0/(t(k)+273.15)) qs = cnst3 * exp(exparg) c = a1mal*(1.0 - acld*cloudy(k) + aalpha*tp(j,2)) qsolr = c*tp(j,1) qb(k,1) = qsolr qr(k) = qcon_gam * qsolr qb(k,2) = cnst4 * tc * qs qb(k,3) = asst*t(k) + ct0 qb(k,5) = 30.*(tclim(k)-t(k)) qtot = qsolr - qb(k,2) - qb(k,3) q(k) = qcon_inv * qtot - qr(k) c if ( imon.ne.jmon .and. j.eq.nyp/2 .and. i.eq.nxp/2) c * write (2, '(1hq,i2,5(1pg12.4))') imon,qtot,qb(k,1), c * qb(k,2), qb(k,3), qb(k,5) enddo jmon = imon return end subroutine hflx_s94 (npt, t, taux,tauy,sst,cld,solr, q,qr,qb) c------------------------------------------------------------------------- c according to R.Seager & B.Blumental, December 1994, Journal of Climate. c q = (output) heat flux = f(t,cld,solr) - gamma*solr dimension t(1),taux(1),tauy(1),sst(1),cld(1),solr(1),q(1),qr(1),qb(npt,1) common /new_hfxevp/ trans_coef, QCON, rlx_time, solr_gamma, TATM, SATM data TAUA/.017/,TAUCON/10300./,UVMIN/4.0/ data AL,ALATENT,CE,RHOA/0.06,2.5e06,1.24e-03,1.225/ data EPS,SIG,TSTA,D /0.97,5.6696e-08,0.71,0.78/ data CP /1004/ cnst1 = 0.622*6.112/1000. cnst2 = RHOA*CE*ALATENT*(1.- D) cnst3 = RHOA*CE*CP*TSTA cnst4 = D*1000./0.622 cnst5 = EPS*SIG cnst6 = 4.*tsta taud2 = sqrt(TAUCON/TAUA) qcon_inv = 1./QCON qcon_gam = SOLR_GAMMA / QCON do i = 1, npt c........Solar Radiation (for output only): qsol = solr(i) qb(i,1) = qsol c........Latent heat: wnsp = amax1(taud2*(taux(i)**2 + tauy(i)**2)**.25, UVMIN) qsat = cnst1*exp(17.67*t(i)/(t(i)+243.5)) qlh = cnst2 * wnsp * qsat qb(i,2) = qlh c........Sensible heat: qsh = cnst3 * wnsp qb(i,3) = qsh c........Long Wave Back Radiation: ts = t(i) + 273.15 sqeth = sqrt(cnst4 * qsat) ts3 = cnst5*ts*ts*ts cnst = 0.8 if( t(i) .gt. 28.) cnst = 0.4 qlw = ts3*(ts*(1.-cnst*cld(i)**2)*(0.417-0.0486*sqeth) + cnst6) qb(i,4) = qlw c........Heat Flux Deficit (for output only): qb(i,5) = 30.*(sst(i)-t(i)) c........The Total Heat Flux at the Surface: qr(i) = qcon_gam * qsol qtot = qsol - qlh - qsh - qlw c c........Since this is in W/m2, we need to convert it to dyn/m3 q(i) = qcon_inv * qtot - qr(i) enddo return end c------------------------------------------------------------------------- subroutine hflx_s94b(npt, t, taux,tauy,sst,cld,solr, q,qr,qb) c------------------------------------------------------------------------- c according to R.Seager & B.Blumental, December 1994, Journal of Climate. c q = (output) heat flux = f(t,cld,solr) - gamma*solr dimension t(1),taux(1),tauy(1),sst(1),cld(1),solr(1),q(1),qr(1),qb(npt,1) common /new_hfxevp/ trans_coef, QCON, rlx_time, solr_gamma, TATM, SATM data TAUA/.017/,TAUCON/10300./,UVMIN/4.0/ data AL,ALATENT,CE,RHOA/0.06,2.5e06,1.24e-03,1.225/ data EPS,SIG,TSTA,D /0.97,5.6696e-08,0.71,0.78/ data CP/1004/ cnst1 = 0.622*6.112/1000. cnst2 = RHOA*CE*ALATENT cnst3 = RHOA*CE*CP*TSTA cnst4 = 1000./0.622 cnst5 = EPS*SIG cnst6 = 4.*tsta taud2 = sqrt(TAUCON/TAUA) qcon_inv = 1./QCON qcon_gam = SOLR_GAMMA/QCON do i = 1, npt c........Solar Radiation (for output only): qsol = solr(i) qb(i,1) = qsol c........Latent heat: wnsp = amax1(taud2*(taux(i)**2 + tauy(i)**2)**.25, UVMIN) qsat = cnst1*exp(17.67*t(i)/(t(i)+243.5)) qair = (-9.42 + 0.97*t(i))/1000. qlh = cnst2 * wnsp * (qsat - qair) qb(i,2) = qlh c........Sensible heat: qsh = cnst3 * wnsp qb(i,3) = qsh c........Long Wave Back Radiation: ts = t(i) + 273.15 sqeth = sqrt(cnst4 * qair) ts3 = cnst5*ts*ts*ts cnst = 0.8 if( t(i) .gt. 28.) cnst = 0.4 qlw = ts3*(ts*(1.-cnst*cld(i)**2)*(0.417-0.0486*sqeth) + cnst6) qb(i,4) = qlw c........Heat Flux Deficit (for output only): qb(i,5) = 30.*(sst(i)-t(i)) c........The Total Heat Flux at the Surface: qr(i) = qcon_gam * qsol qtot = qsol - qlh - qsh - qlw c c........Since this is in W/m2, we need to convert it to dyn/m3 q(i) = qcon_inv * qtot - qr(i) enddo return end c--------------------------------------------------------------------------- subroutine init_pbl(npt, NX, NY, xm, ym, iox) c--------------------------------------------------------------------------- implicit real*4(a-h,o-z),integer(i-n) include 'comm_pbl.h' dimension iox(1), lsm1d(1), xm(nx), ym(ny) pointer (p_lsm1d, lsm1d) parameter (TORAD = 3.14159265/180., REARTH = 6378000.) nxy = nx*ny call mem_alloc (p_up, nxy, 2, 'up') call mem_alloc (p_vp, nxy, 2, 'vp') call mem_alloc (p_thv, nxy, 2, 'thv') call mem_alloc (p_the, nxy, 2, 'the') call mem_alloc (p_thve, nxy, 2, 'thve') call mem_alloc (p_thvs, nxy, 2, 'thvs') call mem_alloc (p_pnuxp, nxy, 2, 'pnuxp') call mem_alloc (p_pnuyp, nxy, 2, 'pnuyp') call mem_alloc (p_qe, nxy, 2, 'qe') call mem_alloc (p_qs, nxy, 2, 'qs') call mem_alloc (p_c0, nxy, 2, 'c0') call mem_alloc (p_dx, nxy, 2, 'dx') call mem_alloc (p_dy, ny, 2, 'dy') call mem_alloc (p_lsm, nxy, 1, 'lsm') c determine grid spacing in m ipbl_jsta = 0 ipbl_jend = 0 do j = 1, ny-1 dy(j) = TORAD * REARTH * (ym(j+1)-ym(j)) if (ipbl_jsta .eq. 0 .and. ym(j).gt.pbl_south) ipbl_jsta = j if (ipbl_jend .eq. 0 .and. ym(j).gt.pbl_north) ipbl_jend = j-1 deg2met = TORAD * REARTH * cos(TORAD * 0.5*(ym(j) + ym(j+1))) do i = 1, nx-1 dx(i,j) = deg2met * (xm(i+1) - xm(i)) enddo dx(nx,j) = dx(nx-1,j) enddo if (ym(1) .ge. pbl_south) ipbl_jsta = 2 if (ym(ny) .le. pbl_north) ipbl_jend = ny-1 p_lsm1d = p_lsm do i = 1, npt lsm1d(iox(i)) = i enddo return end c--------------------------------------------------------------------------- subroutine htflux_pbl (npt,nx,ny, iox,xm,ym, sst,cldfr, wspd,u,v, * q,t, rlh,sh,qlw, qa,th) c--------------------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_pbl.h' dimension xm(nx), ym(ny), iox(1), idim(2) dimension sst(npt), cldfr(npt), wspd(npt), u(npt), v(npt), * qlw(npt), rlh(npt), sh(npt), * q(nx,ny), t(nx,ny), th(nx,ny), qa(nx,ny) logical FIRST_PBL, ADVEC save FIRST_PBL data FIRST_PBL /.true./ if ( FIRST_PBL ) then call init_pbl(npt, NX, NY, xm, ym, iox) FIRST_PBL = .false. endif c set model parameters: ADVEC = (ipbl_advec .eq. 1) pnu = pbl_pnu delta = pbl_delta pml = pbl_pml depth = pbl_depth betav = pbl_betav qrad = pbl_grad / 86400. c set constants: r = 287.04 psfc = 100000. rl = 2.5e+6 cp = 1004. rhoa = 1.225 stef = 5.6696e-8 eps = 0.97 idim(1) = nx idim(2) = ny jstart = ipbl_jsta jend = ipbl_jend c Two iterations are performed. A smaller exchange coefficient is c used on second iteration if mixed layer is stable. c First find equilibrium values of theta_V and q. These are set to c their observed values over land. do 24 j = 1, ny do 24 i = 1, nx c0(i,j) = .0014 k = lsm(i,j) if (k .ne. 0) then qs(i,j)=.622*6.11*exp(17.67*(1.-243.5/(sst(k)+243.5)))/1000. endif 24 continue iter = 1 itermx = 3 99 continue do 25 j=jstart,jend do 25 i=1,nx if(iter.gt.1 .and. (thv(i,j).gt.thvs(i,j))) then c0(i,j)=.00075 endif k = lsm(i,j) if (k .eq. 0) then thve(i,j) = (t(i,j)*(psfc/(psfc-.5*pml))**(r/cp))*(1.+.61*q(i,j)) qe(i,j) = q(i,j) th(i,j) = t(i,j) else w0 = wspd(k)*pml/depth thvs(i,j) = (sst(k)+273.15) * (1.+.61*qs(i,j)) thve(i,j) = thvs(i,j)+pml*qrad/((1.+betav)*c0(i,j)*w0) qe(i,j) = qs(i,j)/(1.+delta) endif 25 continue c Set equilibrium values to observed at northernmost and southernmost c points. This is required because advection/diffusion cannot be computed c when there is no poleward point. Actual values of air temperature and c air humidity are also set equal to observed values and used in flux c calculation. do 26 i=1,nx do 27 j=1,jstart up(i,j)=0. vp(i,j)=0. pnuxp(i,j)=0. pnuyp(i,j)=0. qe(i,j)=q(i,j) thve(i,j)=(t(i,j)*(1017./(1000.))**(r/cp))*(1.+.61*q(i,j)) qa(i,j)=q(i,j) thv(i,j)=thve(i,j) th(i,j)=t(i,j)*(1017./(1000.))**(r/cp) 27 continue do 26 j=jend,ny up(i,j)=0. vp(i,j)=0. pnuxp(i,j)=0. pnuyp(i,j)=0. qe(i,j)=q(i,j) thve(i,j)=(t(i,j)*(1017./(1000.))**(r/cp))*(1.+.61*q(i,j)) qa(i,j)=q(i,j) thv(i,j)=thve(i,j) th(i,j)=t(i,j)*(1017./(1000.))**(r/cp) 26 continue c Set diffusion and advecting wind speed. Over land both are c set to zero to ensure derived theta_V and q are observed c values. In addition, diffusion is set to zero close to c coastline. do 29 j=jstart,jend do 29 i=1,nx k = lsm(i,j) if ( k .eq. 0 ) then up(i,j) = 0. vp(i,j) = 0. pnuxp(i,j) = 0. pnuyp(i,j) = 0. else w0=wspd(k)*pml/depth ip1=i+1 if(ip1.eq.(nx+1)) ip1=nx ip2=i+2 if(ip2.eq.(nx+2) .or. ip2.eq.(nx+1)) ip2=nx im1=i-1 if(im1.eq.0) im1=1 im2=i-2 if(im2.eq.0 .or. im2.eq.-1) im2=1 jm1=j-1 jm2=j-2 if(jm2.eq.0) jm2=1 jp1=j+1 jp2=j+2 if(jp2.eq.(ny+1)) jp2=ny if( lsm(ip1,j) + lsm(im1,j) + lsm(i,jp1) + lsm(i,jm1) + * lsm(ip2,j) + lsm(im2,j) + lsm(i,jp2) + lsm(i,jm2) .eq. 0 ) then pnuxp(i,j)=0. pnuyp(i,j)=0. else if(i.eq.1 .or. i.eq.nx) then twodx2=dx(i,j)**2. else twodx2=.25*(dx(i,j)+dx(i+1,j))**2. endif pnuxp(i,j)=pnu*pml/((1.+betav)*c0(i,j)*w0*twodx2) pnuyp(i,j)=pnu*pml/((1.+betav)*c0(i,j)*w0*.25* $ (dy(j)+dy(j-1))*(dy(j)+dy(j-1))) endif if ( advec ) then if (up(i,j) .gt. 0.) then i1=i else i1=i+1 if (i.eq.nx) i1=nx endif up(i,j) = u(k)*pml/((1.+betav)*c0(i,j)*w0*dx(i1,j)) if (v(k) .gt. 0.) then vp(i,j) = v(k)*pml/((1.+betav)*c0(i,j)*w0*dy(j-1)) else vp(i,j) = v(k)*pml/((1.+betav)*c0(i,j)*w0*dy(j)) endif else up(i,j)=0. vp(i,j)=0. endif endif 29 continue c call subroutine that solves for theta_V call adv2Deq1(idim,up,vp,pnuxp,pnuyp,thve,thv) c repeat one time iter=iter+1 if(iter.lt.itermx) goto 99 c set scaled advecting velocities for humidity calculation and c impose no diffusion across continental boundaries do 39 j=jstart,jend do 39 i=1,nx k = lsm(i,j) if (k .ne. 0) then w0=wspd(k)*pml/depth ip1=i+1 if(ip1.eq.(nx+1)) ip1=nx ip2=i+2 if(ip2.eq.(nx+2) .or. ip2.eq.(nx+1)) ip2=nx im1=i-1 if(im1.eq.0) im1=1 im2=i-2 if(im2.eq.0 .or. im2.eq.-1) im2=1 jm1=j-1 jm2=j-2 if(jm2.eq.0) jm2=1 jp1=j+1 jp2=j+2 if(jp2.eq.(ny+1)) jp2=ny if( lsm(ip1,j) + lsm(im1,j) + lsm(i,jp1) + lsm(i,jm1) + * lsm(ip2,j) + lsm(im2,j) + lsm(i,jp2) + lsm(i,jm2) .eq. 0 ) then pnuxp(i,j)=0. pnuyp(i,j)=0. else if(i.eq.1 .or. i.eq.nx) then twodx2=dx(i,j)**2. else twodx2=.25*(dx(i,j)+dx(i+1,j))**2. endif pnuxp(i,j)=pnu*pml/((1.+delta)*c0(i,j)*w0*twodx2) pnuyp(i,j)=pnu*pml/((1.+delta)*c0(i,j)*w0*.25*(dy(j)+dy(j-1))* $ (dy(j)+dy(j-1))) endif if(advec) then if(up(i,j).gt.0.) then i1=i else i1=i+1 if(i.eq.nx) i1=nx endif up(i,j)=u(k)*pml/((1.+delta)*c0(i,j)*w0*dx(i1,j)) if(v(k).gt.0.) then vp(i,j)=v(k)*pml/((1.+delta)*c0(i,j)*w0*dy(j-1)) else vp(i,j)=v(k)*pml/((1.+delta)*c0(i,j)*w0*dy(j)) endif else up(i,j)=0. vp(i,j)=0. endif endif 39 continue c call solver to derive q call adv2Deq1(idim,up,vp,pnuxp,pnuyp,qe,qa) c calculate theta from theta_V and q c calculate fluxes of sensible and latent heat do j = 1, ny do i = 1, nx k = lsm(i,j) if ( k .ne. 0 ) then th(i,j) = thv(i,j) / (1.+.61*qa(i,j)) co1 = rhoa * c0(i,j) * wspd(k) sstk = sst(k) + 273.15 co2 = sstk - th(i,j) co3 = eps*stef*sstk*sstk*sstk rlh(k) = co1*rl*(qs(i,j)-qa(i,j)) sh(k) = co1*cp*co2 c qlw(k) = eps*stef*(th(i,j)**4.)*(.39-.05*sqrt(qa(i,j)*1000./.622)) c * *(1.-.55*cldfr(k)) + 4.*eps*stef*(th(i,j)**3.)*co2 if ( sstk .gt. 301.15 ) then aout =.4 else aout =.8 endif qlw(k) = co3 * ( sstk * (.417-.0486*sqrt(qa(i,j)*1000./.622)) * * (1. - aout*cldfr(k)*cldfr(k)) + 4.*co2) endif enddo enddo return end c This subroutine computes surface fluxes of latent and sensible heat c in units of W/m^2. The fluxes are computed by a forced advection- c diffusion equation. It solves a equations for the virtual potential c temperature and the air humidity and then inverts the first to get c the air temperature. In both case the balance is one of diffusion, c horizontal advection, surface fluxes and a flux at the mixed layer top. c The mixed layer is a constant depth. c c The model also computes long wave cooling with the Berliand and c Berliand bulk formula (see Seager and Blumenthal, J. Climate, Dec '94 c for example). c c Note added 11/7/94: To date the model has been coupled to an ocean c GCM developed by Ragu Murtugudde, now at GSFC. The results have c been good. Some care is needed at open ocean boundaries it turns out. c In the version as I give it here you will see the computation is done c only for meridional index j=jstart,jend with jstart=25 and jend =ny-1. c This is like putting a boundary in the middle of the southern ocean. c For points poleward of the end points the air humidity and temperature c are set equal to observed values ensuring that values advected in are c realistic. We used ECMWF data at 1000mb. We found that the air-sea c temperature difference given by this data was too large (probably c 'cos the SLP is greater than the lowest ananlysis level of 1000mb) so c we correct it to by a dry adiabaltic lapse rate to an slp of 1017 mb c which corresponded to a reasonable SLP at 40S which is where our ocean c GCM began. Clearly users are free to do whatever they want but c *be cautious*!. c c The limits are to set jstart =2 and jend=ny-1. The end points cannot be c included because of the diffusion operator that would otherwise look c out of array bounds. c c The inputs are: c c sst = array containing the model or observed SST c u = array containing observed low level zonal wind velocity c v = array containing observed low level meridional wind velocity c wspd = array containing observed low level wind speed c lsm = a land sea mask (1=land, 0= ocean) c q = observed low level air humidity (kg/kg) c t = observed low level temperature (K) c cldfr= observed cloud cover c wlat = western latitude of input grid, in degree (e.g. 220.) c slat = southern latitude of input grid, in degrees (e.g. -30.) c dxd = grid spacing in degrees longitude. dxd(i) equals the distance from c the longitude at i-1 to the longitude at i which allows for c uneven grid spacing. c dyd = grid spacing in degrees latitude. dyd(j) equals the distance from c the latitude at j to the latitude at j+1 which allows for c uneven grid spacing. c nx = number of x grid points c ny = number of y grid points c c c The outputs are: c c sh = array containing the sensible heat flux (W/m^2) c rlh = array containing the latent heat flux (W/m^2) c qa = atmospheric mixed layer humidity in kg/kg c th = atmospheric mixed layer potential temperature in K c qlw = longwave radiative heat flux c c Parameters are: c c pnu=diffusivity (m^2/s) c delta - equilibrium q = q0/(1+delta) where q0 is saturation humidity c at the SST c pml=pressure depth (Pa) of the mixed layer c depth=geometric depth of mixed layer = (pml/(rhoa*grav) c qrad=radiative cooling K/s c betav=ratio of downward theta_V flux at mixed layer top to the c surface flux c c0=surface exchange coefficient SUBROUTINE adv2Deq1(p,UP,VP,NUXP,NUYP,QE,QA) STRUCTURE /advqS/ INTEGER NX INTEGER NY END STRUCTURE RECORD /advqS/ p REAL UP(p.NX,p.NY),VP(p.NX,p.NY), QE(p.NX,p.NY) REAL NUXP(p.NX,p.NY),NUYP(p.NX,p.NY) REAL QA(p.NX,p.NY) C variables are dimensioned with X first NXSKP = 1 NYSKP = p.NX C does X advection C loops over all latitudes IX = 1 DO IY = 1 , p.NY CALL ADVDIFQ1DX(UP(1,IY),NUXP(1,IY),p.NX,QE(1,IY),QE(1,IY), * QE(p.NX,IY),QA(1,IY)) END DO C does Y advection C loops over all longitudes IY = 1 DO IX = 1 , p.NX C boundary conditions QLEFT = QE(IX,1) QRIGHT = QE(IX,p.NY) CALL ADVDIFQ1D(VP(IX,1),NUYP(IX,1),p.NY,QA(IX,1), * QLEFT,QRIGHT,NYSKP,QA(IX,1)) END DO RETURN END SUBROUTINE ADVDIFQ1DX(U2,NU2,NX,QE0,QLEFT,QRIGHT,QA) REAL U2(NX), NU2(NX),QE0(NX), QA(NX), QLEFT, QRIGHT INTEGER NX PARAMETER (MAXDIM=800) REAL*4 AC(MAXDIM),BC(MAXDIM),CC(MAXDIM),QE(MAXDIM) * AUTOMATIC AC,BC,CC,QE IF(NX.GT.MAXDIM)STOP 12 C does inside points NXL1 = NX - 1 DO K = 2 , NXL1 QE(K) = QE0(K) IF(U2(K).GE.0) THEN AC(K) = -U2(K) - NU2(K) BC(K) = 1. + U2(K) + 2*NU2(K) CC(K) = -NU2(K) ELSE C wind blows left AC(K) = -NU2(K) BC(K) = 1. - U2(K) + 2*NU2(K) CC(K) = U2(K) - NU2(K) ENDIF END DO C does left point IF(U2(1).GT.0.0)THEN C boundary condition matters QE(1) = QE0(1) + U2(1)*QLEFT BC(1) = 1. + U2(1) CC(1) = 0.0 ELSE C boundary condition doesn't matter QE(1) = QE0(1) BC(1) = 1. - U2(1) CC(1) = U2(1) ENDIF C does right point IF(U2(NX).GT.0.0)THEN C boundary condition doesn't matter QE(NX) = QE0(NX) BC(NX) = 1. + U2(NX) AC(NX) = -U2(NX) ELSE C boundary condition matters QE(NX) = QE0(NX) - U2(NX)*QRIGHT BC(NX) = 1.0 - U2(NX) AC(NX) = 0.0 ENDIF CALL TRIDAGQA(AC,BC,CC,QE,CC,QE,QA,1,NX) RETURN END C \end{fortran} C \subsection{advq1d} C C Inputs C \begin{variablelist} C \v U U scaled version of $U = (Hu)/(C_e |v| dx)$ C \v NX n_x number of points C \v QE q_e equilibrium (forcing) Q C \v QLEFT {} Qa beyond the left boundary C \v QRIGHT {} Qa beyond the right boundary C \v NXSKP {} integer spacing between consecutive elements of QA C \end{variablelist} C C Output C \begin{variablelist} C \v QA q_a solution for QA C \end{variablelist} C \begin{fortran} SUBROUTINE ADVDIFQ1D(U2,NU2,NX,QE0,QLEFT,QRIGHT,NXSKP,QA) REAL U2(NXSKP,NX), QE0(NXSKP,NX), QA(NXSKP,NX), QLEFT, QRIGHT REAL NU2(NXSKP,NX) INTEGER NX PARAMETER (MAXDIM=800) REAL*4 AC(MAXDIM),BC(MAXDIM),CC(MAXDIM),QE(MAXDIM) * AUTOMATIC AC,BC,CC,QE IF(NX.GT.MAXDIM)STOP 12 C does inside points NXL1 = NX - 1 DO K = 2 , NXL1 QE(K) = QE0(1,K) IF(U2(1,K).GE.0) THEN AC(K) = -U2(1,K) - NU2(1,K) BC(K) = 1. + U2(1,K) + 2*NU2(1,K) CC(K) = - NU2(1,K) ELSE C wind blows left AC(K) = -NU2(1,K) BC(K) = 1. - U2(1,K) + 2*NU2(1,K) CC(K) = U2(1,K)-NU2(1,K) ENDIF END DO C does left point IF(U2(1,1).GT.0.0)THEN C boundary condition matters QE(1) = QE0(1,1) + U2(1,1)*QLEFT BC(1) = 1. + U2(1,1) CC(1) = 0.0 ELSE C boundary condition doesn't matter QE(1) = QE0(1,1) BC(1) = 1. - U2(1,1) CC(1) = U2(1,1) ENDIF C does right point IF(U2(1,NX).GT.0.0)THEN C boundary condition doesn't matter QE(NX) = QE0(1,NX) BC(NX) = 1. + U2(1,NX) AC(NX) = -U2(1,NX) ELSE C boundary condition matters QE(NX) = QE0(1,NX) - U2(1,NX)*QRIGHT BC(NX) = 1.0 - U2(1,NX) AC(NX) = 0.0 ENDIF CALL TRIDAGQA(AC,BC,CC,QE,CC,QE,QA,NXSKP,NX) RETURN END C \end{fortran} C \subsection{tridagqa} C Same as tridag2 in the multiple mode linear equatorial model. Solves C a tridiagonal system. C \begin{fortran} C SUBROUTINE TRIDAGQA(A,B,C,D,E,F,X,NXSKP,N) PARAMETER (JS=1) C C SOLVES THE TRIDIAGONAL SYSTEM C A(I)*X(I-1)+B(I)*X(I)+C(I)*X(I+1)=D(I)...I=JS,N A(JS)=0,C(N)=0 C solves in two passes C pass1 computes E(i), F(i) such that x(i) = E(i)*x(i+1) + F(i) C pass2 computes x(i) from E(i), F(i) C array C can be used as E C array D can be used as F C DIMENSION A(*), B(*), C(*), D(*), E(*), F(*), X(NXSKP,*) C E(JS) = C(JS) / B(JS) F(JS) = D(JS) / B(JS) C JN = JS + 1 DO 10 I = JN, N DN = B(I) - A(I) * E(I-1) E(I) = C(I) / DN F(I) = ( D(I) - A(I) * F(I-1) ) / DN 10 CONTINUE X(1,N) = F(N) XOLD = F(N) IMAX = N-1 DO 20 I = IMAX,JS,-1 XOLD = F(I) - E(I) * XOLD X(1,I) = XOLD 20 CONTINUE RETURN END C \end{fortran} C \end{document} dyn_io.f/ 839513370 1572 1572 100444 31219 ` #define ITYPE_RST 0 #define MACHINE_WORD 4 #define c_str(s) ('s\0') subroutine init_rstrt (nxp, nyp, nz, npt, zin, iseg) c--------------------------------------------------------- include 'comm_new.h' include 'comm_data.h' character*100 str common /run/ nstart,nlaststart,nskip,nsteps,nergy,nskipo,nlast common /new_save/ iword, nruns, nscpu, nswll, inf(100), rnf(100) dimension zin(1), zz(50), iseg(1) equivalence (inf(20),kd_sta), * (inf(21),kd_xy), (inf(22),kd_z), (inf(23),kd_time), * (inf(24),kd_seg), (inf(25),kd_uv), (inf(26),kd_temp), * (inf(27),kd_salt),(inf(28),kd_tr), (inf(29),kd_phi), * (inf(30),kd_conv), (inf(31),kd_means), * (inf(100),kd_end) call opda (1, 1, fbo(1:n_out)) do i = 1, 100 inf(i) = 0 rnf(i) = 0. enddo iword = MACHINE_WORD kd = iword * 200 str = 'Resrart file for '//finp(1:mlen(finp)) call wrda (1, 1, kd, len(str), str) kd = iword * 200 + 100 kd_sta = kd kd_xy = kd call wrda (1, iword, kd, nxp, xm) call wrda (1, iword, kd, nyp, ym) kd_z = kd do i = 1, nz zz(i) = -zin(i) enddo call wrda (1, iword, kd, nz, zz) call segm_from_iox (npt, nseg, iox, iseg) kd_seg = kd call wrda (1, iword, kd, 2*nseg, iseg) kd_uv = kd nstart = 1 nlaststart = 1 nlast = nsteps nscpu = 0 nswll = 0 inf(1) = 120 inf(2) = nxp inf(3) = nyp inf(4) = nz inf(5) = 1 inf(6) = npt inf(7) = nseg inf(8) = ntrac inf(11) = nstart inf(15) = nlaststart inf(16) = nsteps inf(17) = nlast rnf(1) = delt rnf(2) = enso_start rnf(3) = enso_scale rnf(4) = rnf(2) return end subroutine read_rstrt (nxp, nyp, nz, npt) c-------------------------------------------------------------------- include 'comm_new.h' include 'comm_data.h' common /run/ nstart,nlaststart,nskip,nsteps,nergy,nskipo,nlast common /new_save/ iword, nruns, nscpu, nswll, inf(100), rnf(100) equivalence (inf(20),kd_sta), * (inf(21),kd_xy), (inf(22),kd_z), (inf(23),kd_time), * (inf(24),kd_seg), (inf(25),kd_uv), (inf(26),kd_temp), * (inf(27),kd_salt),(inf(28),kd_tr), (inf(29),kd_phi), * (inf(30),kd_conv), (inf(31),kd_means), * (inf(100),kd_end) iword = MACHINE_WORD call opda (1, 0, fbi(1:n_in)) kd = 0 call rdda (1, iword, kd, 100, inf) kd = irdda (iword, 100, rnf) ntype = idig(inf(1),1) if (ntype .ne. ITYPE_RST) then write (6, *) 'The file <' ,fbi(1:n_in),'> is not a RESTART-TYPE one !!' stop endif if (nxp.ne.inf(2) .or. nyp.ne.inf(3) .or. * nz.ne.inf(4) .or. npt.ne.inf(6) ) then write(6,*)'The model dimensions are different from the restart data!' stop endif nptz = inf(4)*inf(6) mtra = inf(8) nstart = inf(11) nruns = inf(12) nscpu = inf(13) nswll = inf(14) if (irest .eq. 1) then nlaststart = inf(15) else nlaststart = nstart endif nlast = nlaststart + nsteps - 1 enso_start = rnf(2) rnf(4) = rnf(2) + rnf(3)*nstart if (irest .ne. 3) then ekf1 = rnf(10) epf1 = rnf(11) hcf1 = rnf(12) wcf1 = rnf(13) vlf1 = rnf(14) do k = 1, inf(4)+1 hsave(k) = rnf(20+k) enddo endif kd = kd_uv call rdda (1, iword, kd, nptz, u) kd = irdda (iword, nptz, v) kd = irdda (iword, nptz, uc) kd = irdda (iword, nptz, vc) kd = irdda (iword, nptz, h) kd = irdda (iword, inf(6), psi) if (kd_temp .ne. 0) then kd = kd_temp call rdda (1, iword, kd, nptz, t) endif if (use_salt .and. kd_salt .ne. 0) then kd = kd_salt call rdda (1, iword, kd, nptz, sal) kd = irdda (iword, nptz, dens) endif if (use_trac .and. kd_tr .ne. 0) then kd = kd_tr call rdda (1, iword, kd, nptz*mtra, tr) endif if (kd_conv .ne. 0) then kd = kd_conv call rdda (1, iword, kd, nptz, convn) endif if (kd_means .ne. 0) then kd = kd_means call rdda (1, iword, kd, nptz, um) kd = irdda (iword, nptz, vm) kd = irdda (iword, nptz, tm) if (use_salt .and. kd_salt .ne. 0) then kd = irdda (iword, nptz, salm) kd = irdda (iword, nptz, densm) endif if (use_trac .and. kd_tr .ne. 0) kd = irdda (iword, nptz*mtra, trm) endif call clda(1) call opda (1, 1, fbo(1:n_out)) inf(8) = ntrac inf(12) = nruns + 1 inf(15) = nlaststart inf(16) = nsteps inf(17) = nlast rnf(1) = delt return end subroutine keep_rstrt (nstep, nskip) c-------------------------------------------------------------------- include 'comm_new.h' include 'comm_data.h' common /new_save/ iword, nruns, nscpu, nswll, inf(100), rnf(100) equivalence (inf(20),kd_sta), * (inf(21),kd_xy), (inf(22),kd_z), (inf(23),kd_time), * (inf(24),kd_seg), (inf(25),kd_uv), (inf(26),kd_temp), * (inf(27),kd_salt),(inf(28),kd_tr), (inf(29),kd_phi), * (inf(30),kd_conv), (inf(31),kd_means), * (inf(100),kd_end) if (nskip.eq.0) return if (mod(nstep, nskip) .ne. 0) goto 100 nptz = inf(4)*inf(6) kd = kd_uv call wrda (1, iword, kd, nptz, u) kd = iwrda (iword, nptz, v) kd = iwrda (iword, nptz, uc) kd = iwrda (iword, nptz, vc) kd = iwrda (iword, nptz, h) kd = iwrda (iword, inf(6), psi) kd_temp = kd kd = iwrda (iword, nptz, t) if ( use_salt ) then kd_salt = kd kd = iwrda (iword, nptz, sal) kd = iwrda (iword, nptz, dens) endif if ( use_trac ) then kd_tr = kd kd = iwrda (iword, nptz*ntrac, tr) endif kd_conv = kd kd = iwrda(iword, nptz, convn) if ( save_mean ) then kd_means = kd kd = iwrda (iword, nptz, um) kd = iwrda (iword, nptz, vm) kd = iwrda (iword, nptz, tm) if ( use_salt ) then kd = iwrda (iword, nptz, salm) kd = iwrda (iword, nptz, densm) endif if ( use_trac ) kd = iwrda (iword, nptz*ntrac, trm) endif kd_end = kd inf(11) = nstep rnf(10) = ekf1 rnf(11) = epf1 rnf(12) = hcf1 rnf(13) = wcf1 rnf(14) = vlf1 do k = 1, inf(4)+1 rnf(20+k) = hsave(k) enddo 100 continue inf(18) = nstep inf(13) = nscpu + ipast_scpu() inf(14) = nswll + ipast_swll() kd = 0 call wrda (1, iword, kd, 100, inf) kd = iwrda (iword, 100, rnf) call flda (1) return end subroutine close_rstrt c--------------------------------- call clda(1) return end subroutine dump_rstrt c------------------------------------------------------------------ include 'comm_new.h' include 'comm_data.h' character*100 str character*4 mname(12) common /new_save/ iword, nruns, nscpu, nswll, inf(100), rnf(100) save mname data mname /'Jan.','Feb.','Mar.','Apr.','May ','Jun.', * 'Jul.','Aug.','Sep.','Oct.','Nov.','Dec.'/ iword = MACHINE_WORD call opda (1, 0, fbi(1:n_in)) kd = 0 call rdda (1, iword, kd, 100, inf) kd = irdda (iword, 100, rnf) kd = irdda (1, 100, str) call clda(1) write (6, *) 'Dump of the data file <',fbi(1:n_in),'>:' write (6, *) 'LABEL: ', str write (6, *) 'TYPE', inf(1) write (6, *) 'NX =', inf(2) write (6, *) 'NY =', inf(3) write (6, *) 'NZ =', inf(4) write (6, *) 'NT =', inf(5) write (6, *) 'NPACK =', inf(6) write (6, *) 'NSEGM =', inf(7) write (6, *) 'NTRACERS =', inf(8) call enso2date (rnf(2), id, im, iy) write (6, 101) 'Model Starting Date: ', mname(im), id, iy call enso2date (real(rnf(2)+rnf(3)*inf(17)), id, im, iy) write (6, 101) 'Scheduled End of the Run: ', mname(im), id, iy call enso2date (real(rnf(2)+rnf(3)*inf(18)), id, im, iy) write (6, 101) 'Current End of the Run: ' , mname(im), id, iy call enso2res (real(rnf(3)*inf(17)), id, im, iy) write (6, 201) 'Scheduled Length of the Run:', iy, im, id, inf(17) call enso2res (real(rnf(3)*inf(18)), id, im, iy) write (6, 201) 'Elapsed Model Time: ', iy, im, id, inf(18) write (6, *) 'Number of restarts:', inf(12) call enso2date (rnf(4), id, im, iy) write (6, 101) 'Last Re-start: ', mname(im), id, iy call enso2date (real(rnf(2) + rnf(3)*inf(15)), id, im, iy) write (6, 101) 'Last New Run: ', mname(im), id, iy call enso2date (real(rnf(2) + rnf(3)*inf(11)), id, im, iy) write (6, 101) 'Last Save: ', mname(im), id, iy i = inf(13) if (i/3600 .eq. 1) then write (6, 301) 'Total CPU time:', i/3600, mod(i,3600)/60, mod(i,60) else write (6, 302) 'Total CPU time:', i/3600, mod(i,3600)/60, mod(i,60) endif i = inf(14) if (i/3600 .eq. 1) then write (6, 301) 'Total WALL time:', i/3600, mod(i,3600)/60, mod(i,60) else write (6, 302) 'Total WALL time:', i/3600, mod(i,3600)/60, mod(i,60) endif 101 format (a30, a4, i2, ',' , i5) 201 format (a30, i5, ' Years', i3, ' months', i3, ' days. (', i7, ' steps.)') 301 format (a20, i5, ' hour ', i3, ' min', i3, ' sec.') 302 format (a20, i5, ' hours', i3, ' min', i3, ' sec.') return end subroutine segm_from_iox (npt, nseg, iox, iseg) c------------------------------------------------------ dimension iox(1), iseg(2,1) ista = iox(1) inext = ista + 1 nseg = 0 icount = 0 do i = 2, npt icurr = iox(i) icount = icount + 1 if (inext .ne. icurr) then nseg = nseg + 1 iseg(1,nseg) = ista iseg(2,nseg) = ista + icount - 1 ista = icurr icount = 0 endif inext = icurr + 1 enddo nseg = nseg + 1 iseg(1,nseg) = ista iseg(2,nseg) = ista + icount return end subroutine model_input(npt) c------------------------------------------------------------ c.....read model parameters and grid from file. implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' include 'comm_new.h' include 'comm_data.h' character*50 ubeg,vbeg,hbeg,tbeg,uout,vout,hout,tout,eout, + blk,wndx,wndy,cwndx,cwndy,cloud,ccloud,wout common/files/ubeg,vbeg,hbeg,tbeg,uout,vout,hout,tout,eout,wout common/run/ nstart,nlaststart,nskip,nsteps,nergy,nskipo,nlast common/param0/iyear,iday,isec,delt,ncyc,mbc,nonlin,label(20), + itherm,mlc,limp common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch common/winds/mtau,matau,tausc,atau,froude,icloud common/wnfils/wndx,wndy,cwndx,cwndy,cloud,ccloud common/shapi/nord,nshapu,nshaph,nshapt,mshapu,mshaph,mshapt common /vert/ zin(MAXNZ+1), hin(MAXNZ), t_in(MAXNZ+1), s_in(MAXNZ+1), * bint(MAXNZ), cint(MAXNZ), dzin(MAXNZ+1), sigma(MAXNZ) common/strech/xs(MAXXS),alpha(MAXXS),beta(MAXXS) common /errors/ ioerr, nstep common /new_filt/ MAXFO, nbxk, nbyk, nfxk, nfpxk, nfyk c------------------------------------------------------------------------------- common /pbl_param/ pbl_pnu,pbl_delta,pbl_pml,pbl_depth,pbl_betav, * pbl_grad,nstep_pbl, ipbl_advec, ipbl_jsta,ipbl_jend, * pbl_south,pbl_north, pbl_wmin c------------------------------------------------------------------------------- character*80 f_bar common /baro_files/ n_bar, f_bar integer iflag(12), RM12_NN real aflag(12) common /y12m_input/ RM12_NN, aflag, iflag common /baro_input/ n_def_cor, mod_scheme, mod_solver, BAR_DELTA, * BAR_DSINK, ibar_key, nbaro, rayl c------------------------------------------------------------------------------- real inp_flt, inp_days logical inp_def dimension flt(100) save flt character*80 fbdir external time, ctime integer time character*24 ctime c------------------------------------------------------------------------------- call inp_file(finp) call inp_vrnt(c_str(Variant), inp_int(c_str(Use_variant), -1)) if (inp_int(c_str(Trace),0) .ne. 0) * call inp_trace(finp(1:mlen(finp))//'.tr\0') n_dir= inp_str(c_str(Output_dir),c_str(output), fbdir) n_tios= inp_str(c_str(Base_file), * fbdir(1:n_dir)//'/'//finp(1:mlen(finp))//'\0',fbt) n_out = inp_str(c_str(Save_file), fbt(1:n_tios)//'.save\0', fbo) n_in = inp_str(c_str(Restart_file), fbo(1:n_out)//'\0', fbi) n_wnd = inp_str(c_str(Wind_file), c_str(wind_data), fbwnd) n_tem = inp_str(c_str(Temp_file) , c_str(temp_data), fbtem) n_sal = inp_str(c_str(Salt_file), c_str(salt_data), fbsal) n_psi = inp_str(c_str(Psi_file), c_str(psi_data), fbpsi) n_sst = inp_str(c_str(SST_file), c_str(sst_data), fbsst) n_sss = inp_str(c_str(SSS_file), c_str(sss_data), fbsss) n_cld = inp_str(c_str(Cloud_file), c_str(cld_data), fbcld) n_slr = inp_str(c_str(Solar_file), c_str(slr_data), fbslr) n_evp = inp_str(c_str(EP_file), c_str(ep_data), fbevp) n_hcl = inp_str(c_str(MxlTcl_file),c_str(mltc_data), fbhcl) n_wsp = inp_str(c_str(Wndspd_file),c_str(wndspd_data), fwsp) n_uwd = inp_str(c_str(Uwnd_file),c_str(uwnd_data), fuwd) n_vwd = inp_str(c_str(Vwnd_file),c_str(vwnd_data), fvwd) n_ah = inp_str(c_str(Airhum_file),c_str(ahum_data), fah) n_at = inp_str(c_str(Airtem_file),c_str(atem_data), fat) n_dep = inp_str(c_str(Bath_file), c_str(bath_data), fbdep) if ( inp_def(c_str(Map_file)) ) * n_map = inp_str(c_str(Map_file), c_str(map_data), fbmap) ipre = inp_int(c_str(Pre_proc), 0) ! 0- normal run; 1- pre-processing irest = inp_int(c_str(Restart), 0) ! 0 - start; 1 - restart lev_err = inp_int(c_str(Error_level), 1) if (irest .eq. 0) then open (unit = iout, file = fout) if (lev_err .ge. 1) then write (iout, *) 'Run with control file <',finp(1:mlen(finp)),'>' write (iout, *) 'STARTED: ', ctime(time()) endif else open (unit = iout, file = fout, access='APPEND') if (lev_err .ge. 1) then write (iout, *) 'RE-STARTED: (code=',irest,' at:', ctime(time()) endif endif ncyc = inp_int(c_str(Ncycles), 4) delt = inp_days (c_str(Time_step), 1./24.) stpd = 1./delt minseg = inp_int(c_str(MINSEG), 4) mtmp = stpd - ncyc if (mtmp .lt. 0) mtmp = 0 nsteps = nint(stpd * inp_days(c_str(Run_time), 365.)) + mtmp nskip = nint(stpd * inp_days(c_str(Save_step), 5.)) save_mean = inp_int(c_str(Save_mean), 1) .eq. 1 nergy = nint(stpd * inp_days(c_str(Energy_step), 1.)) call inp_date (c_str(Starting_date), 1,1,2000, imon,iday,iyear) enso_start = date2enso (iday, imon, iyear) enso_scale = delt * 12./365. land = 0 iglob = inp_int(c_str(Periodic), 0) mbc = inp_int(c_str(BC_type), 1) NXP = inp_int(c_str(NX), 10) NYP = inp_int(c_str(NY), 10) NZ = inp_int(c_str(NZ), 2) nsig= inp_int(c_str(Nsigma), 0) if (nsig.eq.1.or.nsig.eq.2.or.nsig.gt.nz.or.nsig.lt.0)then print*,'number of sigma layers must be 0 or between 3 and nz' stop endif if(max0(nxp,nyp).gt.MAXSID) call wspace('MAXSID', max0(nxp,nyp)) if(NZ .gt. MAXNZ) call wspace('MAXNZ', NZ) alat = inp_flt(c_str(South), 0.) blat = inp_flt(c_str(North), real(nyp-1)) alon = inp_flt(c_str(West), 0.) blon = inp_flt(c_str(East), real(nxp-1)) mgrid = inp_int(c_str(Grid_type), 1) nsx = inp_rarr(c_str(X_stretch_pnts), 0, xs, xs) nsx = inp_rarr(c_str(X_alpha), 0, alpha, alpha) nsx = inp_rarr(c_str(X_beta), 0, beta, beta) nystrch = inp_int(c_str(Y_stretch_type), 1) if (nystrch.eq.1) then nsy = inp_rarr(c_str(Y_stretch_pnts), 0, xs(nsx+1), xs(nsx+1)) nsy = inp_rarr(c_str(Y_alpha), 0, alpha(nsx+1), alpha(nsx+1)) nsy = inp_rarr(c_str(Y_beta), 0, beta(nsx+1), beta(nsx+1)) if(nsx+nsy.gt.maxxs) call wspace('MAXXS', nsx+nsy) endif ibaro = inp_int(c_str(Baro_solv), 0) if (ibaro .ne. 0) then nbaro = inp_int(c_str(Baro_step), 6) n_def_cor = inp_int(c_str(Baro_defcor_step), 0) mod_scheme = inp_int(c_str(Baro_scheme), 9) mod_solver = inp_int(c_str(Baro_solver), 1) BAR_DSINK = inp_flt(c_str(Baro_depsink), 500.) BAR_DELTA = inp_flt(c_str(Baro_delta), 50.) rayl = inp_flt(c_str(Baro_rayl), .002) ibar_key = inp_int(c_str(Baro_err), 1) if (ibar_key .ne. 0) * n_bar = inp_str(c_str(Baro_errfile), * finp(1:mlen(finp))//'.bar\0', f_bar) c------------FROM ".y12m"-------------------------------------------- c RM12_NN : size of workspace in numbers of NONZ c iflag(11) : number of iterations c iflag : see y12m documentation c aflag : see y12m documentation c default values: do i = 1, 12 iflag(i) = 0 aflag(i) = 0 enddo RM12_NN = inp_int(c_str(Baro_nnonz), 4) iflag(11) = inp_int(c_str(Baro_niter), 100) iflag(1) = 1 iflag(2) = 3 iflag(3) = 1 iflag(5) = 2 aflag(1) = 2. aflag(2) = 1.e-4 aflag(3) = 1.e6 aflag(4) = 1.e-12 aflag(5) = -1000. call inp_iarr (c_str(Baro_iflag), 5, iflag, iflag) call inp_rarr (c_str(Baro_aflag), 5, aflag, aflag) endif nonlin= inp_int(c_str(Nonlin), 1) if (nonlin.ne.1) then print*, 'Nonlin disabled (ie, always nonlinear), please do not use' stop endif itemp = inp_int(c_str(Thermo), 1) if (itemp.eq.0) then print*, 'Thermo = 0 disabled' stop endif isalt = inp_int(c_str(Salinity), 0) isolrp = inp_int(c_str(Solar_penrad), 0) if (isolrp .eq. 1) solr_gamma = inp_flt(c_str(Solar_gamma), .333333) icl_h = inp_int(c_str(Clim_H), 0) ! 0-init from hin;1-Cnst;2-Vary; icl_psi = inp_int(c_str(Clim_psi),0) ! 0-don't use;1-Cnst;2-Vary; if (icl_h .ne. 0.and.nsig.eq.0) then print*,'must use Nsigma > 2 if Clim_H <> 0' stop endif icl_htop = inp_int(c_str(Clim_htop), 0) ! 0-Const; 1-Vary; icl_ts = inp_int(c_str(Clim_TS), 0) ! 0-init from Tin;1-Cnst;2-Vary; if (icl_h.eq.2 .and. icl_ts.ne.2) * write (ioerr, *) 'Warning: check Clim_H vs. Clim_TS...' if (icl_ts.eq.0 .and. initt.ne.0) * write (ioerr, *) 'Warning: to initialize temp, use icl_ts <> 0' if (icl_ts.eq.0 .and. inits.ne.0) * write (ioerr, *) 'Warning: to initialize salt, use icl_ts <> 0' icl_rlx = inp_int(c_str(Clim_relax), 0) ! 0-no relax; 1-relax N-S; ksponge = inp_int(c_str(Sponge_width), 5) krelax = inp_int(c_str(Relax_width), 5) clm_time = inp_days (c_str(Clim_coef), 30.) clm_time_psi = inp_days (c_str(Clim_coef_psi), 30.) clm_coef = delt/clm_time clm_psi = nbaro*ncyc*clm_time/clm_time_psi clm_no = inp_flt(c_str(Clim_nlat), 90.) ! North relaxation latitude. clm_so = inp_flt(c_str(Clim_slat), -90.) ! South relaxation latitude. imix = inp_int(c_str(Mixing), 0) if (imix .ne. 0) limp = inp_int(c_str(Mix_step), 3*ncyc) cm_mix = inp_flt(c_str(Mix_cm), 1.25) ! "m" turbulence coefficient cn_mix = inp_flt(c_str(Mix_cn), 0.17) ! "n" turbulence coefficient cn_mix = 1. - cn_mix hmin_mix = inp_flt(c_str(Mix_hmin), 10.) ! H1 - min hmax_mix = inp_flt(c_str(Mix_hmax), 100.) ! H1 - max ric1_mix = inp_flt(c_str(Mix_ric1), .65) ! Ri for k = 1 ric2_mix = inp_flt(c_str(Mix_ric2), .25) ! Ri for k = 2:NZ iuse_gam = inp_int(c_str(Mix_usegam), 0) ! 1 - use gammas in jpmix gam1_mix = inp_flt(c_str(Mix_gam1), 1.) ! Gamma for k = 1 gam2_mix = inp_flt(c_str(Mix_gam2), 1.) ! Gamma for k = 2:NZ iwnd_mix = inp_int(c_str(Mix_wnd), 0) ! 0:use tau; 1: use windspeeds if (initq .ne. 8) iwnd_mix = 0 ! valid only if PBL is "ON" mix_wtop = inp_int(c_str(Mix_wtop), 2) if (imix .eq. 4.and.nsig .eq. 0) then print*, 'must set Nsigma>1 to use variable depth mixed layer' stop endif ntrac = inp_int(c_str(Tracers), 0) use_salt = (isalt .ne. 0) use_trac = (ntrac .ne. 0) iv_top = inp_int(c_str(Vert_Top), 1) if (iv_top.ne.1.and.nsig.eq.0) then print*, 'must use Sigma layers for non-constant depth mixed layer' endif iv_bot = inp_int(c_str(Vert_Bot), 99) !! 1-CNST;2-Sigm;3-W=0;4-No Motion if (iv_bot.ne.99) then print*, 'Vert_Bot ignored, use Nsigma to determine last layer type' endif iv_bump = inp_int(c_str(Vert_Bump), 0) !! 0-Sigm;2-Sm.bmp;3-Lg.bmp;4-Exp. if (iv_bump.ne.0) then print*, 'no interface bumps allowed, reset Vert_Bump = 0' stop endif iv_fix = inp_int(c_str(Vert_Fix), 1) !! 0-Free Surface; 1-Fixed Depth if (iv_fix.ne.1) then print*, 'reduced gravity runs disabled, reset Vert_Fix = 1' stop endif iv_sys = inp_int(c_str(Vert_Sys), 99) !! disabled if (iv_sys.ne.99) then print*, 'Vert_Sys ignored, H is filtered only in sigma layers' endif mbot_bc = inp_int(c_str(BC_bot_temp), 0) !! 0-constant temp; 1 - d/dz=0 if (mbot_bc.ne.1) then print*, 'do you REALLY want constant bottom temp with bathymetry?' print*, 'reconsider using BC_bot_temp = 1' stop endif shap_vel_cnst = inp_flt(c_str(Shap_vel_constant), 1.0) shap_scl_cnst = inp_flt(c_str(Shap_vel_constant), 1.0) nordu = inp_int(c_str(Shap_vel_order), 4) mshapu = inp_int(c_str(Shap_vel_type), 3) nshapu = inp_int(c_str(Shap_vel_step), 3*ncyc) nordh = inp_int(c_str(Shap_scl_order), 4) mshaph = inp_int(c_str(Shap_scl_type), 1) nshaph = inp_int(c_str(Shap_scl_step), 3*ncyc) nord = max(nordu,nordh) MAXFO = nord mtau = inp_int(c_str(Wind_forc), 0) if (mtau .eq. 5) itau_cos = inp_int(c_str(Wind_cos), 0) call inp_rarr (c_str(Wind_tauxy), 2, flt, flt) tausc = flt(1) atau = flt(2) initt = inp_int(c_str(Temp_init), 0) temp_coef = inp_flt(c_str(Temp_coef), 0.) if (initt.ne.0.and.initt.ne.3) then print*,'must use Temp_init = 0 or 3' stop endif inits = inp_int(c_str(Salt_init), 0) if (inits.ne.0.and.inits.ne.3) then print*,'must use Salt_init = 0 or 3' stop endif froude = inp_flt(c_str(Temp_froude), 0.01) initq = inp_int(c_str(Heat_forc), 0) initep = inp_int(c_str(EP_forc), 0) icloud = inp_int(c_str(Cloud_forc), 0) qcon = inp_flt (c_str(Rho_CP), 4.12e6) rlx_time = 86400.*inp_days (c_str(Rlx_time), 30.) if (initq .ge. 8) then nstep_pbl = nint(stpd * inp_days(c_str(PBL_step), 5.)) ipbl_advec = inp_int(c_str(PBL_advec), 1) pbl_wmin = inp_flt(c_str(PBL_wmin), 4.) pbl_pnu = inp_flt(c_str(PBL_pnu), 0.4e+7) pbl_delta = inp_flt(c_str(PBL_delta), 0.25 ) pbl_pml = inp_flt(c_str(PBL_pml), 6000.) pbl_depth = inp_flt(c_str(PBL_depth), 600. ) pbl_betav = inp_flt(c_str(PBL_betav), 0.17 ) pbl_grad = inp_flt(c_str(PBL_grad), -2.) pbl_south = inp_flt(c_str(PBL_south), -200.) pbl_north = inp_flt(c_str(PBL_north), 200.) endif iherr = inp_int(c_str(Layer_volume), 0) initb = inp_int(c_str(Bathymetry), 0) initbt = inp_int(c_str(Bath_type), 0) dep_min = inp_flt(c_str(Bath_min), 100) nzz = inp_rarr(c_str(Z_profile), nz, zin, zin) nzh = inp_rarr(c_str(H_profile), nz, hin, hin) if (nz .gt. nzz .and. nz .gt. nzh) then call perror1('Z_profile or H_profile: not enough terms...',-1) stop endif zin(1) = hin(1)/2. z_bot = hin(1) do k = 2, nz zin(k) = - zin(k-1) + 2.*z_bot z_bot = z_bot + hin(k) enddo zin(nz+1) = z_bot dzin(1) = zin(1) do j = 2, nz dzin(j) = (zin(j)-zin(j-1))/2. enddo dzin(nz+1) = zin(nz+1)-zin(nz) c Z_profile specification overrides H_profile zdum = inp_flt(c_str(Z_bot), 0) if (zdum.eq.0.and.z_bot.eq.0) then print*,'must specifiy Z_bot as well as Z_profile' stop elseif (zdum.gt.0) then c reread Z_profile ndum = inp_rarr(c_str(Z_profile), nz, zin, zin) zin(1) = zin(2)/3. ! enforce this condition zin(nz+1) = zdum dzin(1) = zin(1) do j = 2, nz dzin(j) = (zin(j)-zin(j-1))/2. if (dzin(j).lt.0.)then print*,'negative layer depths, check Z_profile' stop endif enddo dzin(nz+1) = zin(nz+1)-zin(nz) if (dzin(nz+1).lt.0.)then print*,'negative depth of last layer, check Z_bot' stop endif hin(1) = 2.*dzin(1) do j = 1, nz hin(j) = dzin(j) + dzin(j+1) enddo endif do j = 1, nz if (hin(j).le.0) then print*,'a layer depth is negative, check Z_profile or H_profile' stop endif enddo z_begin = zin(nsig) sigma(1) = -1./3. sigma(2) = sigma(1) do j = 3, nsig sigma(j) = dzin(j)/(z_begin-3.*dzin(1)) enddo do j = nsig + 1, nz sigma(j) = 0. enddo trans_coef = (zin(1)+zin(2))/2./rlx_time i = inp_rarr(c_str(T_profile), nz, t_in, t_in) if (i .lt. nz) then call perror1('T_profile: not enough terms...',-1) elseif (i .eq. nz) then t_in(nz+1) = inp_flt(c_str(Temp_bot), 0.) endif TATM = inp_flt(c_str(Temp_atm), 30.) i = inp_rarr(c_str(S_profile), nz, s_in, s_in) if (i .lt. nz) then call perror1('S_profile: not enough terms...',-1) elseif (i .eq. nz) then s_in(nz+1) = inp_flt(c_str(Salt_bot), 36.) endif SATM = inp_flt(c_str(Salt_atm), 35.4) TEMP_BOT = t_in(nz+1) SALT_BOT = s_in(nz+1) POTND_BOT = inp_flt(c_str(Dens_bot), pdens_pnt (TEMP_BOT, SALT_BOT)) c.....Bi & Ci are now *real* "Nu" & "Ka" (not scaled by depth): bi = inp_flt (c_str(Bint), 1.e-3) ci = inp_flt (c_str(Cint), 1.e-4) do i = 1, nz bint(i) = bi cint(i) = ci enddo call inp_str(c_str(Grid_label),'Data: '//finp(1:mlen(finp))//'\0',label) call mem_alloc (p_mask, NXP*NYP*NZ, 1, 'mask') if (n_map .ne. 0) call inp_file(fbmap(1:n_map)//'\0') call read_mask ('Grid_mask', nxp, nyp, nxyc, mask) call mem_alloc (p_iox, nxyc, 1, 'iox') npt = nxyc npt1 = 1 npt2 = 1 + npt npt3 = 1 + 2*npt npt4 = 1 + 3*npt first_step = .true. if (lev_err .ge. 1 .and. irest .eq. 0) then write (iout, *) 'NX =', nxp write (iout, *) 'NY =', nyp write (iout, *) 'NZ =', nz write (iout, *) 'NPACK =', nxyc write (iout, *) 'NTRACERS =', ntrac if (ibaro .eq. 0) then write (iout, *) 'BARO OFF' else write (iout, *) 'BARO ON' endif call flush(iout) endif return end subroutine read_mask (tag, nx, ny, npack, mask) c----------------------------------------------------- character*(*) tag dimension mask(nx, 1) character*1 ch, buff(1000) character*465 number logical inp_def equivalence (ch, buff(1)), (number, buff(2)) if ( inp_def(tag//'\0') ) then ix = 1 jy = ny ic0 = ichar('0') do while ( inp_wnxt(buff) .gt. 0) if (ch.eq.'0' .or. ch.eq.'1' .or. ch.eq.'2') then do i = 1, nx mask(i,jy) = ichar(buff(i)) - ic0 enddo jy = jy - 1 elseif (ch.eq.'w'.or.ch.eq.'z'.or.ch.eq.'x'.or.ch.eq.'s' * .or.ch.eq.'b'.or.ch.eq.'t') then read (number, *) kx ix = ix + kx if (ix - 1 .gt. NX) goto 200 if (ch.eq.'w') ich = 1 if (ch.eq.'x') ich = 2 if (ch.eq.'s') ich = 3 if (ch.eq.'t') ich = 4 if (ch.eq.'b') ich = 5 if (ch.eq.'z') ich = 0 do i = ix-kx, ix-1 mask(i,jy) = ich enddo if (ix-1 .eq. NX) then ix = 1 jy = jy - 1 endif elseif (ch .eq. 'r') then read (number, *) ky jy = jy - ky + 2 if (jy .lt. 1) goto 200 do j = jy+ky-2, jy, -1 do i = 1, nx mask(i,j) = mask(i,j+1) enddo enddo jy = jy - 1 else goto 200 endif if (jy .eq. 0) goto 100 enddo 100 npack = 0 do j = 1, ny do i = 1, nx if (mask(i,j) .ne. 0) npack = npack + 1 enddo enddo else npack = nx*ny do j = 1, ny do i = 1, nx mask(i,j) = 1 enddo enddo endif return 200 write (6, *) '!!!read_mask: wrong mask data, i,j:', ix,jy stop end dyn_main.f/ 839523564 1572 1572 100444 14231 ` ************************************************************************ program !MCPG implicit real(a-h,o-z),integer(i-n) c************************************************************************ include 'comm_para.h' include 'comm_new.h' include 'comm_data.h' dimension * en(MPTEN*(MAXNZ+1)), * lxxk(MXBDY*MAXNZ),lyyk(MXBDY*MAXNZ), * lxyk(MAXNB*MAXNZ),lyxk(MAXNB*MAXNZ),lsponge(MAXSP), * lrelax(MAXSP), * snxk(MAXNB*MAXNZ),snyk(MAXNB*MAXNZ),lok(4*MAXSID*MAXNZ), * lpbcwk(MAXSID*MAXNZ),lpbcek(MAXSID*MAXNZ), * ifxk(9*MAXSID*MAXNZ), ifpxk(5*MAXSID*MAXNZ), ifyk(9*MAXSID*MAXNZ) logical NEWRUN, non_stable common /param0/iyear,iday,isec,delt,ncyc,mbc,nonlin,label(20), * itherm,mlc,limp common /run/ nstart,nlaststart,nskip,nsteps,nergy,nskipo,nlast common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch common /winds/ mtau,matau,tausc,atau,froude,icloud common /shapi/ nord,nshapu,nshaph,nshapt,mshapu,mshaph,mshapt common /vert/ zin(MAXNZ+1), hin(MAXNZ), t_in(MAXNZ+1), s_in(MAXNZ+1), * bint(MAXNZ), cint(MAXNZ), dzin(MAXNZ+1), sigma(MAXNZ) common /strech/ xs(MAXXS), alpha(MAXXS), beta(MAXXS) common /errors/ ioerr, nstep common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) common /baro_input/ n_def_cor, mod_scheme, mod_solver, BAR_DELTA, * BAR_DSINK, ibar_key, nbaro, rayl common /main/npt data ioin,iout,ioerr /1,2,2/, k15flag /0/ npten = MPTEN c...............getting input & output filenames from the command line call inout (ioin) c...............input model parameters. call model_input(npt) call model_memory (nxp, nyp, nz, npt) call make_iox (nxp, nyp, mask, iox, nlok, lok, nsponge, lsponge, * nrelax, lrelax, iglob) if (nrelax.gt.MAXSP) then print*,'increase MAXSP' stop endif call scaset (iox,xm,ym,xp,yp,f,emx,emy,emxy,emx2,emy2,tp) call depth_init (npt, zin) call new_topo (nxp, nyp, nz, npt, zin, dzin, hin, nsig, sigma, dept, * h, nptk, nzi) call bndrys(npt,iox,tp,isxk,isyk,mask,h,nzi, * isk,iyk,lxxk,lyyk,lxyk,lyxk,snxk,snyk,lok, * lpbcwk,lpbcek,ifxk,ifpxk,ifyk,dept) call baro_dept(npt,nz,nzi,nzi_b,h,lxxk,lyyk,mbc,dept,tp,tp(npt2)) call data_init (npt,nptk,nz,isk,u,v,uc,vc,fu,fv,ft,fsal,bdiv,ubar,vbar,use_salt) c..............compute some geometry stuff call aarea (lxxk,lyxk,emx,emy,emxy,area,basin) if (irest .eq. 0) then NEWRUN = .true. call init_rstrt (nxp, nyp, nz, npt, zin, tp) else NEWRUN = irest .eq. 3 if (irest.eq.1 .or. irest.eq.2) CALL TIOS_CNTRL (3, 1) if (ibaro .ne. 0) ibaro = 1 call read_rstrt (nxp, nyp, nz, npt) endif c..............initialize Temperature/Salinity Climatology (for sponges): call clim_init(npt,nstart,hin,sigma,dzin,h, * hclim,tclim,sclim,dclim,pclim,tp,nsponge,lsponge) if (irest .eq. 0) then call h_init (npt, nz, nzi, nstart, h, hclim) call temp_init (npt,nz,nzi,nstart,t_in,t,tclim) if (use_salt) call salt_init (npt,nz,nzi,nstart,s_in,sal,sclim) endif c..............initialize Heat/EP forcing: call hflx_init (nstart, npt, nxp, nyp, t, sst, cld, solr,nrelax,lrelax) if (use_salt) then call evpr_init (nstart, npt, sal, sss, ep) call dens_init (npt, nz, nzi, t, sal, dens, h) endif c..............initialize Wind forcing: call tau_init (nstart, npt, dtx, dty) dnt = delt * real(ncyc) * D2SEC dtmix = delt * real(limp) * D2SEC DLT_MIX = 2.0 * dtmix c..............initialize TIOS io-system call init_data_out (ftios, fbt, nxp, nyp, npt, xm, ym, en) c istep = 0 iday_new = int(nstart*delt) iday_curr = iday_new if (ibaro .ne. 0) then eps1 = 1./dnt eps2 = eps1 if (ibaro .eq. 2) eps1 = 0. call baro_sum (npt, nz, nzi_b, uc, vc, ubar, vbar) call baro_scale (npt, ubar, vbar, dept) mem0 = mem_get() call baro_init (iglob,eps1,nxp,nyp,nxyc,iox,nbxk,lxxk, * nbyk,lyxk,alon,blon,alat,blat,xm,ym,dept,dep_max,mgrid) write(iout, *)'Barotropic solver memory = ',mem_get()-mem0,' bytes.' if (ibaro .eq. 2) then call baro_tau (npt, uforc, vforc, taux, tauy) call baro_rhs (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,snxk,snyk, * isyk,isk,mbc,lpbcwk,lpbcek,uforc,vforc,tp,tp(npt2),dept) call baro_solv (nxp,nyp,npt,iox,tp,uforc,vforc,psi) call psi_relax (npt,psi,pclim,tp,nbxk,lxxk,nbyk,lyyk) call curl_of_psi (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,snxk,snyk, * isyk,isk,mbc,lpbcwk,lpbcek,psi,tp(npt1),tp(npt2),tp(npt3),dept) call baro_updat(npt,nz,nzi_b,h,uc,vc, * tp(npt1),tp(npt2),uforc,vforc,ubar,vbar) call decap (npt, nz, nzi, u,v,uc,vc,h) endif call baro_div (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,mbc,lpbcwk,lpbcek,ubar,vbar,bdiv,tp,dept) c if (eps1.ne.eps2) call baro_rinit (eps2) call baro_rinit (eps2) endif write(iout, *)'Total allocated memory = ',mem_get(),' bytes.' call bcset (mbc,lxxk,lyyk,npt,u,v,nzi,nzi_b) call baro_shap(nstep,npt,nz,nzi,nzi_b,dept,h,uc,vc,ubar,vbar,u,v,lxxk,lyyk) c...............compute w from the initial fields. call ddiv(npt,nzi_b,uc,vc,emx,emy,emxy,w,fhd,lxxk,lyyk,lxyk,lyxk,snxk,snyk, * isyk,isk,tp,mbc,lpbcwk,lpbcek,h,bdiv) call wtop (npt, w, fhd, fh, h, ncyc, istep, dnt) call dwcal (npt,nz,nsig,nzi,w,fhd,sigma) c......................................................................... c.....MAIN LOOP .......use an n-cycle Lorentz scheme for the timestep loop. call cpulog (fcpu, 0, iday_curr) DO NSTEP = NSTART, NLAST tenso = enso_start + enso_scale * nstep c if (nstep.eq.2) then c call data_out (tenso, nxp, nyp, npt, en) c stop c endif if (mtau .eq. 1) then call tau_lin(nstep,npt, ixd,im2d,blcf, taux,tauy,dtx,dty,tp) endif call clim_updt(npt,nz,nstep,hin,sigma,dzin,hclim,tclim,sclim,dclim) call qforc(nstep, npt, nxp,nyp,sst,cld,solr, wnd, qb) if (use_salt) call epforc(nstep, npt, sal, sss, ep, qb) call vertu (npt,nz,nsig,nzi,nzi_b,bint,taux,tauy,u,v,w,h,fu,fv,fh, * vertx,verty,zfu,zfv) if (use_salt) then call vertts (npt,nz,nzi,cint,q,qr,ep,w,h,t,ft,sal,fsal) else call vertt (npt,nz,nzi,cint,q,qr,w,h,t,ft) endif if (use_trac) call verttr (npt,nz,nzi,cint,w,h,tr,ftr) call dhoriz (npt,u,v,uc,vc,f,fu,fv,fhd,emx,emy,emxy,tp,mbc,zfu,zfv, * lxxk,lyyk,lxyk,lyxk,snxk,snyk,isyk,isk,lpbcwk,lpbcek,nzi_b, * corx,cory,xnl,ynl,fh) call btpgf (npt, nzi_b, h, t,dens,fu,fv,emx,emy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,lok,tp,u,v,lpbcwk,lpbcek,zfu,zfv,pgfx,pgfy) call thoriz (npt,uc,vc,t,ft,fhd,emx,emy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,lok,tp,mbc,lpbcwk,lpbcek) call capt (npt,nz,nzi,t,h) if (use_salt) then call thoriz (npt,uc,vc,sal,fsal,fhd,emx,emy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,lok,tp,mbc,lpbcwk,lpbcek) call capt(npt,nz,nzi,sal,h) endif do i = 1, ntrac it = npt*nz*(i-1)+1 call thoriz (npt,uc,vc,tr(it),ftr(it),fhd,emx,emy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,lok,tp,mbc,lpbcwk,lpbcek) call capt (npt,nz,nzi,tr(it),h) enddo binv = dnt/(ncyc-istep) istep = mod(istep+1,ncyc) abinv = -(istep/dnt)*binv call baro_sum(npt,nz, nzi_b, fu,fv,u,v) call baro_scale (npt, u, v, dept) call fixed_dep(npt,nzi_b,h,fu,fv,u,v,rhsx,rhsy,crhsx,crhsy) call vel_updat (npt,nz,nzi_b,binv,abinv,uc,vc,fu,fv) if (ibaro .ne. 0) then call baro_comp(npt,dnt,abinv,binv,nbaro,uforc,vforc,u,v,zfu,zfv,dept) if (mod(nstep, nbaro*ncyc) .eq. 0) then call baro_rhs(npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,snxk,snyk, * isyk,isk,mbc,lpbcwk,lpbcek,uforc,vforc,u,tp,dept) call baro_solv (nxp,nyp,npt,iox,u,uforc,vforc,psi) call psi_updt(npt,nstep,pclim) call psi_relax (npt,psi,pclim,tp,nbxk,lxxk,nbyk,lyyk) call curl_of_psi (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,mbc,lpbcwk,lpbcek,psi,u,v,tp,dept) call baro_updat(npt,nz,nzi_b,h,uc,vc,u,v,uforc,vforc,ubar,vbar) call baro_div (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,mbc,lpbcwk,lpbcek,ubar,vbar,bdiv,tp,dept) endif endif call bcset (mbc,lxxk,lyyk,npt,uc,vc,nzi,nzi_b) call shap_vec (nstep,npt,nz,uc,vc,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp) call decap (npt, nz, nzi, u,v,uc,vc,h) if (nsig.gt.0) then call h_updat (npt,nsig, binv,abinv,h,fh) call hbcset (npt, nz, nsig, lok, h, hclim) call shap_scl(nstep,npt,nsig,h,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp) endif call tupdat(npt,nz,nzi,binv,abinv,t,ft) call tbcset(npt,nz,lok,t_in,h,t,tclim) !reset temp at open boundaries call shap_scl(nstep,npt,nz,t,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp) call tdecap (npt, nzi, t, h) call t_limit (npt, nzi, t) if (use_salt) then call tupdat(npt,nz,nzi,binv,abinv,sal,fsal) call tbcset(npt,nz,lok,s_in,h,sal,sclim) call shap_scl(nstep,npt,nz,sal,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp) call tdecap (npt, nzi, sal, h) endif do i = 1, ntrac it = npt*nz*(i-1)+1 call tupdat(npt,nz,nzi,binv,abinv,tr(it),ftr(it)) call tdecap (npt,nzi, tr(it), h) enddo if (imix.ne.0 .and. mod(nstep, limp).eq.0) then if (use_salt) call potn_dens (npt, nzi, t, sal, dens) if (imix .eq. 1) then !! Convective Adjustment call dconv (npt,nz,nzi,u,v,uc,vc,h,t,sal,dens,tr,convn) elseif (imix .eq. 2) then !! Ri Number Mixing call decap (npt, nz, nzi, u,v,uc,vc,h) call drich_mix (npt, nz, nzi, h, u,v,uc,vc,t,sal,dens) elseif (imix .eq. 3) then !! Combination of (1) & (2) call decap (npt, nz, nzi, u,v,uc,vc,h) call drich_mix (npt, nz, nzi, h, u,v,uc,vc,t,sal,dens) call dconv (npt,nz,nzi,u,v,uc,vc,h,t,sal,dens,tr,convn) elseif (imix .eq. 4) then !! Dake Chen's Scheme call decap (npt, nz, nzi, u,v,uc,vc,h) call comp_bncy(npt,nzi,dens,tp) call cvmix(npt,nzi,h,t,sal,tp,u,v) call jpmix(npt,nz,nzi,h,t,sal,tp,u,v) call ktmix(npt,nsig,dtmix,h,t,sal,tp,u,v,q,qr,ep,taux,tauy,sigma,uc) call capfrm(npt,nz,nzi,u,v,uc,vc,h) elseif (imix .eq. 5) then !! Dake Chen's Conv. Adjustment only call decap (npt, nz, nzi, u,v,uc,vc,h) call comp_bncy(npt,nzi,dens,tp) call cvmix(npt,nzi,h,t,sal,tp,u,v) call capfrm(npt,nz,nzi,u,v,uc,vc,h) endif endif call clim_relax (npt,nz,h,t,sal,hclim,tclim,sclim) if (use_salt) call situ_dens (npt, nz, nzi, t, sal, dens, h) call bcset (mbc,lxxk,lyyk,npt,u,v,nzi,nzi_b) call baro_shap(nstep,npt,nz,nzi,nzi_b,dept,h,uc,vc,ubar,vbar,u,v,lxxk,lyyk) call ddiv(npt,nzi_b,uc,vc,emx,emy,emxy,w,fhd,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,tp,mbc,lpbcwk,lpbcek,h,bdiv) call wtop (npt, w, fhd, fh, h, ncyc, istep, dnt) call dwcal (npt,nz,nsig,nzi,w,fhd,sigma) if (NEWRUN .or. (nergy.ne.0 .and. mod(nstep, nergy).eq.0)) then call knergy(npt,nz,nptk,isk,area,basin,h,u,v,en) call pnergy (NEWRUN,npt,nptk,nz,isk,h,area,t,dens,w,basin,en,tp) endif if (non_stable(iout, npt, nxp, nz, iox, t, u, v)) then call cpulog (fcpu, nstep, iday_curr) write (iout, *) 'Stable:ERROR, step', nstep, ' temp or velocity is bizarre' print*, 'Stable:ERROR, step', nstep, ' temp or velocity is bizarre' goto 333 else if ( mod(nstep,ncyc) .eq. 0 ) then iday_new = int(nstep*delt) call add_mean call keep_rstrt(nstep, nskip) call data_out (tenso, nxp, nyp, npt, en) if (NEWRUN .or. (iday_new .ne. iday_curr)) then iday_curr = iday_new call cpulog (fcpu, nstep, iday_curr) if (NEWRUN) NEWRUN = .false. endif endif endif call flush(iout) if ( first_step ) first_step = .false. c.....END of the MAIN LOOP ENDDO goto 444 c.............ABnormally finished run: 333 CALL TIOS_CNTRL (1, 1) call data_out (tenso, nxp, nyp, npt, en) c.............normally finished run: 444 call close_rstrt write (iout, *) 'Finished at step =', nstep call enso2date (tenso, id, im, iy) write (iout, *) ' <', tenso, '>' write (iout, *) ' <',id,':',im,':',iy,'>' stop end dyn_main.o/ 839864676 1572 1572 100644 29512 ` ELFl0@@ $ * )1 )8?EP [e(p(x` ,$0 H x(-(3,;BIOXW_8f rx )4?JU_dsw&.7BIQX`gow~ )07>FR]emw(0/@Paq.symtab.shstrtab.strtab.comment.data.sdata.rodata.srdata.lit4.text.MIPS.events.text.rel.MIPS.events.text.rela.text.rel.text.MIPS.options.debug_info.debug_line.debug_abbrev.debug_frame.debug_aranges.debug_pubnames.debug_weaknames.rel.debug_line.rel.debug_frame.rel.debug_info.rel.debug_aranges.rel.debug_pubnames.rel.debug_weaknames.data.sdata.rodata.srdata.lit4.textMAIN___main_s_stoppara_new_logic_new_param_new_dims_new_files_new_io_new_time_new_misc_new_baro_new_shap_dake_mix_new_forc_new_forcgr_new_hfxevp_new_energy_pbl_files_new_vert_data_addr_grid_addr_mosf_data_geom_non_stable_param0_run_grid_coords_winds_shapi_vert_strech_errors_gridk_baro_input_main_inout_model_input_model_memory_make_iox_scaset_depth_init_new_topo_bndrys_baro_dept_data_init_aarea_init_rstrt_tios_cntrl_read_rstrt_clim_init_h_init_temp_init_salt_init_hflx_init_evpr_init_dens_init_tau_init_realinit_data_out_intbaro_sum_baro_scale_mem_get_baro_init_baro_tau_baro_rhs_baro_solv_psi_relax_curl_of_psi_baro_updat_decap_baro_div_baro_rinit_bcset_baro_shap_ddiv_wtop_dwcal_cpulog_tau_lin_clim_updt_qforc_epforc_vertu_vertts_vertt_verttr_dhoriz_btpgf_thoriz_capt_modfixed_dep_vel_updat_baro_comp_psi_updt_shap_vec_h_updat_hbcset_shap_scl_tupdat_tbcset_tdecap_t_limit_potn_dens_dconv_drich_mix_comp_bncy_cvmix_jpmix_ktmix_capfrm_clim_relax_situ_dens_knergy_pnergy_add_mean_keep_rstrt_data_out_flush_close_rstrt_enso2date_e_wsle64s_wsle64__kai_do_lio64new_io_errors_.debug_info.debug_line.debug_abbrev.debug_frame.debug_aranges.debug_pubnames.debug_weaknames.rel.debug_line.rel.debug_frame.rel.debug_info.rel.debug_aranges.rel.debug_pubnames.rel.debug_weaknamesbe::6.02:dyn_main.o-G8 -TENV:PIC -m1 -O2 -TARG:abi=64:isa=mips4increase MAXSPBarotropic solver memory = Total allocated memory = Stable:ERROR, step temp or velocity is bizarreFinished at step = < < bytes.>:G@?<K$!\%/-<$!9-0߂$ߙhA gߙߓ ` %Xߕf`8%`f f ߙf  %Hg<P<ߗ$BQ8p$!\H--g߂<dHX$!xߒx-fߙ %G8F@  X%$߁߂d%dD߁dG|d#$߁dEXd(߂dFd$߁d'߂<ߙdC $!(-<x$"!<0-$!8 -<$"T<-$!8 (-<($"<0 -$!8-<@$"<H-$!P-<X$"X<`-$"h-(!#)p !ȯ g$$ߙߦg gߙ !(%ߙ g!!A ߐD8ߙ(  ߅  ܨܧܦܥ ߙ߁` % (%ߨC`B8Aߙ ߃ߡ`8%0%߫ %ߪߩ ߥBXAPHpGhK`J8CF E8I@ߙpߣphߣh`ߣ`XߣXPߣPHߣ@ߣH8ߣ@0ߣ8(ߣ0 ߣ(߰ ` % ߤ(A ߂GxF`H8BCP%ߙH%"-(%߫xd!` % ߤߡONML`CPB(AK JIHGPߙߘ80( 0%(%` % ߢߡ8I0H (%ߙGF % g`8%$ߙ߈( !0%I  % ߥ!!!$:,"$!g ߙ gߙ0%`8%ߐ$! % ߥ(ߙg _ _0__ KJ(I8ߨ` %ߧߦ ߅` %ߙ(%ߐ!I(F`H8 8%IHJ8%(%ߙF`` %߁ d(ߙ` %(%߁ߟgp! !IXJ F` ߇KJIHH0%ߙg`(%ߧ ߄`(%ߙ߁! !HGFX ߄IhHXGH(%ߙF`J8 ` %!!GߙF`(%ߖ  %ߑ?tDF?DF` FFǁF$P ߙFB߁ǀFߧ`@%0%߂*gdE)ߐdD8 Ǥ(%ߙDǃFF` DžFF Dߟ%߂dCxdB. JI߁H $!G"!Fx ` %FߙEG ` %߄% ߇JI8 %ߙߐd d@dd ߧ8ߧ߫ ߌߪߧݍ݌fPH(f0%g8 0߅ߙg $ߤ$dߗg%g  %ߤ% $ggߨg %H@# %$gg  %ߙ !ߙ$!HGFE ` %_ ECBPApFߙXH@8ߣX0ߣP(ߣx ߡHߣ@ߡ8ߐ` %߷0߶( X%P%߂H%߱  @%G-FEg PKJI`0%ߙH G8 % ߥEF0X% H%ߙG ` %ߪ ߨ߿8ߩXߨPߥߤxߣHߡ@NMPLpBܧܦܥ0( X%P%ߙH%XB 8A-_-C- @%dB` %gPd!H @JCK_I HFxG8ߙ(%` %_ --g d*J IHG(%ߙF`K8 ` %!ECFBPApHG ߙXPH@8ߣX0ߣP(ߣx ߡHߡ@߫8ߪ0߁ߩ(ߨ ` %'& %ߙ g!!gߟߙg $߿$g0ߖg%g  %ߙ $gg%g  %$gg  %ߙ !IHKx߱(`8%ߙ 0%߰ J`(%߶x  %BA_ KDCHxG`J8I0(ߙ 0%`(% ߤ_XK0IG FExBPApH8C PgߙphߨX`ߨPXH@8ߡH0ߡ@(ߡ8 ߡ0߁` %*) (G@FX` %ߙgE0H8g ߩIXH0(%ߙG`` %ߪ ߦߙ$Pߦg ߤ߄ߟd߉A*@%߂߃dhA߁߂dgdd%xd$dadcp߁dB!D0F5 `(%'(Lߙ߉$ )*HGFJILKM  ߤ!A_ KJ(ߙ(%ߩߨ` %ߧ߰ 0%_@KHJIH0%`(%ߙ % ߧ`(%ߙߟ!I@HGFX ߤ!MLIGF@KJC(BA_HxߙPH@80( B8B0(%` %ߩG` ߦ` %(%ߟPPߙQHCߧ`@%B8JAXF` @H%A8K0 F`!!@H%ߙ`@%(%K8J0` %ߧ F`` %ߙ(%ߟ !K0J(H0F`I8 ߧ!!_@___x_p_x_Px_pp_8_0_ _X߿X߿P߿Hh߿@`߿8X߿0P߿(H߱ ߐ@߿x(K(JH GߙFE` % ߿(ߦXߥPߤHߣ@ߢ8ߡ0ph0( _h_`__x_`_X_ P_P@_p8߿HHhGHJ(IExߙF8  ` %߿(ߨXߧPߦxߥߤHߣ@ߢ8ߡ0`XP@( _ H_P8_p0IXGHHPF ߙE` %  GHߙF`H8(% ` %` %ߙߟߪX*!IXGXH`F EBPApC `ߪPXߪxPHߣ@80ߡH(ߡ@ ߡ8ߡ0ߢ(߁ߢ + *GX(%ߙF`H8 ` %ߧX` %ߟߙ $0*E!!!!IXF EBPApC h`ߧPXߧx PHߣ@80ߣH&(ߣ@" ߣ8ߣ0ߣ(ߣ ߇$!A(B0#-C-dH d'ߢ(%` %ߙA(F`H8"- d'` %ߧXߙ&0* !ߟ$"_#DHFJ`DPFRǫF ZCF RF JBH(GJIFx(%ߙFJG` % FߙEG ` %B_AKH(GJIExF8ߙ` % A(K@%J 8%(%ߙIFx` % 0%8%ߙߟߨ` %!CBJIAKE g` %߂߁߰ ߱(@% H%B!ߙ"߁!" !_X_ P_H_@_8_P_p߿X0߿P(߿x ߿H߿@ߡ8߿0 X%߁P%'& %KJI`0%ߙHG8 % ߥߙF0` % ߥEF0 X%H%ߙG ` %ߪ ߨ߿0ߧXߦPߥxߤHߣ@ߢߡ80( CXC PCHC@C8CPCp X%GP% H%ߙFE@% ` %____I HKJߙFxG8(% ` %߿0ߧXߦPߥxߤHߣ@ߢߡ80( CXC PCHC@C8CPCp` % X%GP% H%ߙFE@% !!I HKx`8%ߙ߰ J`ߦ((% ߤxH GAPKpB ߙ ߢpߢhߢ`H%0%`(%ߪ8 ߤJ IHGߙF`K8(% ` %ߙ0%8%߁߰` %!$ !I@H8 (%0%(%ߙI(H8` % ߧKPJpG8_ ߙ߿p߿h߿`0%ߩ8`(%ߨ  ߤIH@%8%ߙ$JPF`(% ` %IHJ(%ߙH8` %ߧ ߦGHKPJpA ߙߡpߡhߡ`0%`(%ߩ8ߨ  ߤFHߙE`G8 ` %ߙFHE` ` %ߙ8%@%߁(%! )!IXJ`F` ` %IXJ (%ߙH8` %ߧ ߦGXKPJp_ ߙ߿p߿h߿`0%`(%ߩ8ߨ  ߤFXߙE`G8 ` %!!&@%߁1 0* &!! x8%(%'` %X(_0F`ߙ--g g ߿` %ߙX(E`G8- g@%&&0*!߃߁߄߂ߙ0!ctBC@! !HhGXFHE` ` %߅(%ߙ$!ML(ChBXAHJ IHGF`K8 ` % !!!(%ߙ$!J IHGF`K8 ` %ChBXAHK JIHF`G8ߙ(%` % !!(%ߙ$0!J IHGF`K8 ` %ChBXAHK JIHF`G8ߙ(%` % ML(ChBXAHJ IHGF`K8ߙ (%` % z!!(%ߙ$L!J IHGF`K8 ` %FhߙE`G  ` %HXGHKJE`ߙF8I  ` %IXHHAKF`(%ߙG8J ` % C8BLFEIXHHMAKG8J ߙ8߭0( ` %g ߥJ IHG(%ߙF`K8 ` %*!!(%ߙ$$!J IHGF`K8 ` %FhߙE`G  ` %HXGHKJE`ߙF8I  ` %J IHG(%ߙF`K8 ` %!HXGHK JߙI(F8(% ` %` %ߙ(%ߟ!IhHXGHJ8 F`!KxߙJ`߱(`8%I 0%߰ H(%ߡx %BA_ KDCHxG`J8I0(ߙ 0%`(% ߤߤx_XK0IG FExBPApH8C PߙphߨX`ߨPXH@8ߡH0ߡ@(ߡ8 ߡ0߁` %*) (G@FX` %ߙgE0H8g ߩIXH0(%ߙG`` %ߪ ߦ߂߁ !B!A+,B++"$ (!GPJ8ߙgC(%Kg` % H%ߐ߃0% h0ߦD0ChKH0HPgI8L ߙ8% 0%`(% g!IHH88%0%ߙ`(%KJ ߄ߙ߁߃@f!ߙ$P߰ߦ(% ߤ߁ߟg!%@ %  $$߲8%fFPߖg%g  %$8%0%g%g   %$fFh%g  %ߐ% !gߡ % %$ $8%fFP% g   %$߿ 8%0%%(g(  %%$fFh0g0  %% !ߙg  g `8%(%ߙgߦ gH!!!߂B!" +!cD`Fc`߃l  F fߙߥ ߤF `8%(%ߙgߦ gߟD`! !!!ߙߦ߁$Pߥߤ 0 % !ߙ ߄%߃a$"߁ߤD!* F ߁?b߉!׸(ߙ !g߁g$8g$!ߙg   %$$߷fg8ߙ8g  %$%@ߦg@ g ߙ   %ggggߙg @ߢ8ߡ %@ %B $ f%HgH  %ߡ@8% 0%%PgP g$$$g%XgX  %% !ߣ ߡ8g`%@ %! $ 8%f߷H%`g`  %8%g%hgh  %@8%g%pgp  %8%g%xgx  %@8%g%g  %8%߶Pg%g  %ߵX%ߴ`@8%g߳hg߲p  %߱x%߰ !ߙ(% g߿0ߡ߼% % , - . /   $ (0 ,1 02 43 84 <5 @6 D7 H8 L9 P: T; X< \= `> d? h@ lA pC tE xF |G H G I J K L M N O P Q G R S T U V W X Y Z [ \ ] ^  _ ` a b c  b $c (b ,c 0E 4F 8e <f @g DJ HK Lh PL TM XN \P `R di hO lj pk tl xm |n l o p m n l o m o q r O s O s r O t u v w x O t u x y z R S T U V { |   W     $ ( , 0 4 8 <8 @ D} H~ L PW T X \ ` d h l p t x |            ( 4, H- L+\"x. )/ & #$ 4(DP\ T l | 0 1 &2 )x3  4 5  6 7 &T8 `9 l: !; !$< 0&<= H L&p!> !?  !@ A ! TC \xE)DFXG h#|H  $ I J $  < K L ,M N O ,P | Q  G D dR ST\UVW*!(&)!H(tXx$YZ0[4 \ ]\^_ \`Tabcb c bcb \ExFefgX \*xJ(4KLhpLMLNPR@iOj#klLmtnlopm @nhlo m<op t x |(q rDOsOs`rOtu v dw x O!t!0u!Xx!y!z! !R"4S"T"#U#,V#D(#L!#{#)##|$0$D$H}$L($P($\W$x$ $ % %8 %% & &(~&D&X&W&&&&(& & &' ' '< 'd ' ' )l DhP\D` 4 ` |   0$$%%'0'@'l'( (,(()<)x( T d/home/naomi/work/LOAM/NEW/dyn_main.f/home/naomi/work/LOAM/NEW-G8 -TENV:PIC -m1 -O2 -col120 -TARG:abi=64:isa=mips4 -include=/usr/include -original_filename=dyn_main.f -fB,/usr/tmp/ctmB.BAAa000cL MAIN__MAINn)(x /home/naomi/work/LOAM/NEWdyn_main.f침ocomm_para.hӉcomm_new.hأcomm_data.hÚ  (<NLT1&=% L L @(( } |*!$$40hY((`4=8 L<]<4<EA1y94u(Q%0 !DH)X,M4((Lp !!!' stop endif if (key .eq. 0) then !! 1-byte allocation p_bte = p_tr do i = 1, msize bte(i) = char(0) enddo else if (key .eq. 1) then !! INTEGER allocation p_int = p_tr do i = 1, msize int(i) = 0 enddo else if (key .eq. 2) then !! REAL allocation p_flt = p_tr c x = sqrt(-1.) do i = 1, msize flt(i) = 0. c flt(i) = x c flt(i) = -987654321. enddo else if (key .eq. 3) then !! DOUBLE allocation p_dbl = p_tr do i = 1, msize dbl(i) = 0d0 enddo endif memory_used = memory_used + mem_request c write(91,*)object,p_tr,msize,mem_request,memory_used return end c------------------------------------------- subroutine mem_free (p_tr, msize, key) c------------------------------------------- pointer (p_tr, tr) common /all_loc/ memory_used if (p_tr .eq. 0) then write (6, *) 'mem_free: Invalid pointer...Stop!' stop endif call free(p_tr) if (key .eq. 0) then !! 1-byte allocation mem_request = msize else if (key .eq. 1) then !! INTERGER allocation mem_request = msize * NB_INTW else if (key .eq. 2) then !! REAL allocation mem_request = msize * NB_REAW else if (key .eq. 3) then !! DOUBLE allocation mem_request = msize * NB_DBLW endif memory_used = memory_used - mem_request c write(91,*)'mem_free',p_tr,msize,mem_request,memory_used return end c----------------------------------------------------------- subroutine mem_realloc (p_old, mold, mnew, mcopy, key) c----------------------------------------------------------- common /all_loc/ memory_used byte b1(1), b2(1) integer i1(1), i2(1) real f1(1), f2(1) double precision d1(1), d2(1) pointer (p_b1, b1), (p_i1, i1), (p_f1, f1), (p_d1, d1), * (p_b2, b2), (p_i2, i2), (p_f2, f2), (p_d2, d2), * (p_new, new), (p_old, old) mmin = min(mold, mnew) if (mmin .le. 0) * call perror1('mem_realloc: Wrong rallocation request...Stop!',1) if (key .eq. 0) then !! 1-byte allocation mem_request_new = mnew mem_request_old = mold else if (key .eq. 1) then !! INTERGER allocation mem_request_new = mnew * NB_INTW mem_request_old = mold * NB_INTW else if (key .eq. 2) then !! REAL allocation mem_request_new = mnew * NB_REAW mem_request_old = mold * NB_REAW else if (key .eq. 3) then !! DOUBLE allocation mem_request_new = mnew * NB_DBLW mem_request_old = mold * NB_DBLW endif p_new = malloc(mem_request_new) mmin = min(mmin, mcopy) if (key .eq. 0) then !! 1-byte allocation p_b1 = p_new p_b2 = p_old do i = 1, mmin b1(i) = b2(i) enddo else if (key .eq. 1) then !! INTERGER allocation p_i1 = p_new p_i2 = p_old do i = 1, mmin i1(i) = i2(i) enddo else if (key .eq. 2) then !! REAL allocation p_f1 = p_new p_f2 = p_old do i = 1, mmin f1(i) = f2(i) enddo else if (key .eq. 3) then !! DOUBLE allocation p_d1 = p_new p_d2 = p_old do i = 1, mmin d1(i) = d2(i) enddo endif call free(p_old) p_old = p_new memory_used = memory_used + mem_request_new - mem_request_old c write(91,*)'mem_realloc',p_new,mem_request_new,mem_request_old,memory_used return end c--------------------------------------------------- function mem_get () c--------------------------------------------------- common /all_loc/ memory_used mem_get = memory_used return end c------------------------------------------------- subroutine model_memory (nx, ny, nz, npt) c------------------------------------------------- include 'comm_new.h' include 'comm_data.h' include 'comm_pbl.h' nptz = npt * nz mptz = npt * max(4,nz) nxy = nx*ny call mem_alloc (p_u, mptz, 2, 'u') call mem_alloc (p_uc, nptz, 2, 'uc') call mem_alloc (p_fu, nptz, 2, 'fu') call mem_alloc (p_um, nptz, 2, 'um') call mem_alloc (p_v, mptz, 2, 'v') call mem_alloc (p_vc, nptz, 2, 'vc') call mem_alloc (p_fv, nptz, 2, 'fv') call mem_alloc (p_vm, nptz, 2, 'vm') call mem_alloc (p_w, nptz, 2, 'w') call mem_alloc (p_wm, nptz, 2, 'wm') call mem_alloc (p_h, nptz, 2, 'h') call mem_alloc (p_fh, nptz, 2, 'fh') call mem_alloc (p_fhd, nptz, 2, 'fhd') call mem_alloc (p_hm, nptz, 2, 'hm') call mem_alloc (p_pgfx, nptz, 2, 'pgf_x') call mem_alloc (p_pgfy, nptz, 2, 'pgf_y') call mem_alloc (p_corx, nptz, 2, 'cor_x') call mem_alloc (p_cory, nptz, 2, 'cor_y') call mem_alloc (p_xnl, nptz, 2, 'nonlin_x') call mem_alloc (p_ynl, nptz, 2, 'nonlin_y') #ifdef dump_all call mem_alloc (p_vertx, nptz, 2, 'vert_x') call mem_alloc (p_verty, nptz, 2, 'vert_y') call mem_alloc (p_rhsx, nptz, 2, 'rhs_x') call mem_alloc (p_rhsy, nptz, 2, 'rhs_y') call mem_alloc (p_crhsx, nptz, 2, 'crhs_x') call mem_alloc (p_crhsy, nptz, 2, 'crhs_y') #endif call mem_alloc (p_t, nptz, 2, 'tem') call mem_alloc (p_ft, nptz, 2, 'ftem') call mem_alloc (p_tp, mptz, 2, 'tp') call mem_alloc (p_tm, nptz, 2, 'tm') call mem_alloc (p_convn, nptz, 2, 'convn') call mem_alloc (p_dens, nptz, 2, 'dens') call mem_alloc (p_densm, nptz, 2, 'densm') call mem_alloc (p_dclim, nptz, 2, 'dclim') call mem_alloc (p_hclim, 2*nptz, 2, 'hclim') call mem_alloc (p_tclim, 2*nptz, 2, 'tclim') if (icl_psi.gt.0) then call mem_alloc (p_pclim, 2*npt, 2, 'pclim') endif if (use_salt) then call mem_alloc (p_sal, nptz, 2, 'sal') call mem_alloc (p_fsal, nptz, 2, 'fsal') call mem_alloc (p_salm, nptz, 2, 'salm') call mem_alloc (p_sss, 3*npt, 2, 'sss') call mem_alloc (p_ep, 3*npt, 2, 'ep') call mem_alloc (p_sclim, 2*nptz, 2, 'sclim') endif c 2D--------------------------------------------- if (use_trac) then call mem_alloc (p_tr, nptz*ntrac, 2, 'tr') call mem_alloc (p_ftr, nptz*ntrac, 2, 'ftr') call mem_alloc (p_trm, nptz*ntrac, 2, 'trm') endif call mem_alloc (p_sponge, npt, 2, 'sponge') call mem_alloc (p_relax, npt, 2, 'relax') call mem_alloc (p_f, npt, 2, 'f') call mem_alloc (p_emx, npt, 2, 'emx') call mem_alloc (p_emy, npt, 2, 'emy') call mem_alloc (p_emxy, npt, 2, 'emxy') call mem_alloc (p_emx2, npt, 2, 'emx2') call mem_alloc (p_emy2, npt, 2, 'emy2') call mem_alloc (p_taux, npt, 2, 'taux') call mem_alloc (p_tauy, npt, 2, 'tauy') call mem_alloc (p_area, npt, 2, 'area') call mem_alloc (p_q, npt, 2, 'q') call mem_alloc (p_qr, npt, 2, 'qr') call mem_alloc (p_qb, 5*npt, 2, 'qb') call mem_alloc (p_wnd, 3*npt, 2, 'wnd') call mem_alloc (p_sst, 3*npt, 2, 'sst') call mem_alloc (p_cld, 3*npt, 2, 'cld') call mem_alloc (p_solr, 3*npt, 2, 'solr') call mem_alloc (p_dtx, 2*npt, 2, 'dtx') call mem_alloc (p_dty, 2*npt, 2, 'dty') call mem_alloc (p_dept, npt, 2, 'dept') call mem_alloc (p_ubar, npt, 2, 'ubar') call mem_alloc (p_vbar, npt, 2, 'vbar') call mem_alloc (p_uforc, npt, 2, 'uforc') call mem_alloc (p_vforc, npt, 2, 'vforc') call mem_alloc (p_psi, npt, 2, 'psi') call mem_alloc (p_zfu, npt, 2, 'zfu') call mem_alloc (p_zfv, npt, 2, 'zfv') call mem_alloc (p_bdiv, npt, 2, 'bdiv') call mem_alloc (p_xm, nx, 2, 'x') call mem_alloc (p_ym, ny, 2, 'y') call mem_alloc (p_xp, nx, 2, 'xp') call mem_alloc (p_yp, ny, 2, 'yp') call mem_alloc (p_hsave, nz+1, 2, 'hsave') call mem_alloc (p_isk, npt*nz, 1, 'isk') call mem_alloc (p_iyk, npt*nz, 1, 'iyk') call mem_alloc (p_isxk, npt*nz, 1, 'isyk') call mem_alloc (p_isyk, npt*nz, 1, 'isyk') call mem_alloc (p_nzi, npt, 1, 'nzi') call mem_alloc (p_nzi_b, npt, 1, 'nzi_b') if (initq .eq. 8) then call mem_alloc (p_wnsp, 2*npt, 2, 'wnsp') call mem_alloc (p_uwnd, 2*npt, 2, 'uwnd') call mem_alloc (p_vwnd, 2*npt, 2, 'vwnd') call mem_alloc (p_ahum, 3*nxy, 2, 'ahum') call mem_alloc (p_atem, 3*nxy, 2, 'atem') call mem_alloc (p_amhum, nxy, 2, 'amhum') call mem_alloc (p_amth, nxy, 2, 'amth') endif call mem_alloc (p_wint, nz*ny, 2, 'zonal ave w') call mem_alloc (p_psiw, (nz+1)*ny, 2, 'meridional sf') return end c-------------------------------------- subroutine datagrid_memory (tmp) c-------------------------------------- dimension tmp(1) include 'comm_new.h' include 'comm_data.h' call mem_alloc (p_xd, mxp, 2, 'xd') do i = 1, mxp xd(i) = tmp(i) enddo call mem_alloc (p_yd, myp, 2, 'yd') do i = 1, myp yd(i) = tmp(mxp+i) enddo c.....shift SEGMENTS array to begining of tmp do i = 1, mseg tmp(i) = tmp(mxp+myp+i) enddo call mem_alloc (p_ixd, mxp*myp, 1, 'ixd') call mem_alloc (p_im2d, npt2, 1, 'im2d') call mem_alloc (p_blcf, 4*npt2, 2, 'blcf') idatgr = 1 return end dyn_new.f/ 839856827 1572 1572 100444 44956 ` c$Source: /usr/our/senya/work/model/MC_PG/senq/RCS/dyn_new.f,v $ c$Author: senya $ c$Revision: 0.4 $ c$Date: 94/01/24 11:04:47 $ c$State: Exp $ c idig.f / "uphi" - model/ c-------------------------------------- function idig(xxxxx, n) integer xxxxx, n, res integer idig c res = xxxxx if (n .gt. 1) res = xxxxx / 10**(n-1) idig = mod (res, 10) return end function mlen (string) c--------------------------- character*(*) string integer mlen data LMAX /80/ k = 1 do while ( * k .le. LMAX .and. * int(string(k:k)) .ge. 33 .and. * int(string(k:k)) .le. 126) k = k + 1 enddo mlen = k-1 return end c ------------------------------------------------------------------ subroutine inout (ioin) c ------------------------------------------------------------------ c unix routine for opening the input parameter file and the output c logfil from the command line arguments. include 'comm_new.h' character*80 arg narg = iargc() i = 0 in = 0 do while (i .lt. narg) i = i + 1 call getarg (i, arg) if (arg .eq. '-h' .or. arg .eq. '-help') then goto 100 elseif (arg .eq. '-i') then i = i + 1 call getarg (i, finp) open (unit = ioin, file = finp) fout = finp(1:mlen(finp))//'.log' fcpu = finp(1:mlen(finp))//'.cpu' ftios = '.tios\0' in = 1 elseif (arg .eq. '-o') then i = i + 1 call getarg (i, fout) elseif (arg .eq. '-t') then i = i + 1 call getarg (i, ftios) elseif (arg .eq. '-d') then i = i + 1 call getarg (i, fbi) n_in = mlen(fbi) call dump_rstrt stop endif enddo if (in .eq. 0) goto 100 open (unit = iout, file = fout) goto 200 100 call getarg (0, arg) write (6, *) * 'usage: '//arg(1:mlen(arg))//' [-i file][-t ftios][-d file]' write (6,*) 'where: -i file - for model control ' write (6,*) ' -t file - for tios control (deflt:<.tios>)' write (6,*) ' -d file - make a dump of data/restart ' stop 200 return end c ------------------------------------------------------------------ subroutine ddiv (npt,nzi,uc,vc,emx,emy,emxy,w,fhd,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,tp,mbc,lpbcwk,lpbcek,h,bdiv) csenq ------------------------------------------------------------------ c compute the divergence (fhd) for all layers and put the Sum in w(1,nz). implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz), * snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz), * lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz) dimension uc(npt,nz),vc(npt,nz),emx(npt),emy(npt),emxy(npt),w(npt,nz), * fhd(npt,nz), tp(npt,4),h(npt,nz), bdiv(npt), nzi(npt) c c set boundary condition flag based on whether interior corners are c treated as boundaries. see bcset and dfdx. c nbu = 0 nbv = 0 if(mbc.eq.1 .or. mbc.eq.4) nbu = 1 if(mbc.eq.1 .or. mbc.eq.3) nbv = 1 c........compute d(hv)/dy & d(hu)/dx.. nxk = nbxk(1) nyk = nbyk(1) nck = ncsk(1) npbk = npbck(1) call dfdx1(uc,tp(1,3),npt,nbu,nxk,nyk,nck,lxxk,lyxk, * snxk,npbk,lpbcwk,lpbcek) call dfdy1(vc,tp(1,4),npt,nbv,nyk,nxk,nck, * lyyk,lxyk,snyk,isyk) if (mgrid .ne. 2) then do i = 1, npt fhd(i,1) = emx(i)*tp(i,3) + emy(i)*tp(i,4) enddo else do i = 1, npt fhd(i,1) = emx(i)*tp(i,3) + emy(i)*tp(i,4) + emxy(i)*vc(i,1) enddo endif do k = 2, nz npk = nptk(k) c........mud points have zero transport: call zero_em (npt, tp) call zero_em (npt, tp(1,2)) do j = 1, npk i = isk(j,k) tp(i,1) = uc(i,k) tp(i,2) = vc(i,k) enddo call dfdx1(tp,tp(1,3),npt,nbu,nxk,nyk,nck,lxxk,lyxk, * snxk,npbk,lpbcwk,lpbcek) call dfdy1(tp(1,2),tp(1,4),npt,nbv,nyk,nxk,nck, * lyyk,lxyk,snyk,isyk) c........now multiply by the appropriate scale factors to find divergence. c........div(u) = (1/mx)*(du/dx) + (1/my)*(dv/dy) + myx*u + mxy*v c........we also accumulate the sum of layer divergences in w(nz) if (mgrid .ne. 2) then do i = 1, npt fhd(i,k) = emx(i)*tp(i,3) + emy(i)*tp(i,4) enddo else do i = 1, npt fhd(i,k) = emx(i)*tp(i,3) + emy(i)*tp(i,4) + * emxy(i)*tp(i,2) enddo endif enddo do i = 1, npt mz = nzi(i) fhd(i,1) = fhd(i,1) - h(i,1)*bdiv(i) w(i,1) = fhd(i,1) do k = 2, mz fhd(i,k) = fhd(i,k) - h(i,k)*bdiv(i) w(i,k) = w(i,k-1) + fhd(i,k) enddo enddo do k = 1, nz do i = 1, npt w(i,k) = 0. enddo enddo return end c ---------------------------------------------------------- subroutine wtop (npt, w, fhd, fh, h, ncyc, istep, dnt) c ---------------------------------------------------------- include 'comm_new.h' c.....subroutine to set W at first interface. dimension fhd(1), w(1), fh(1), h(1) if (imix .eq. 4) then if (mix_wtop .eq. 1) then do i = 1, npt w(i) = 0. enddo elseif (mix_wtop .eq. 2) then binv1 = real(ncyc-istep)/dnt do i = 1, npt dmin = fh(i) + binv1 * (h(i) - hmax_mix) dmax = fh(i) + binv1 * (h(i) - hmin_mix) divw = fhd(i) divw = amin1(divw, dmax) divw = amax1(divw, dmin) w(i) = fhd(i) - divw enddo endif else if (iv_top .eq. 1) then do i = 1, npt w(i) = fhd(i) enddo elseif (iv_top.eq.3) then do i = 1, npt w(i) = 0. enddo endif endif return end c ------------------------------------------------------------------ subroutine dwcal (npt, nz, nsig, nzi, w, fhd, sigma) c ------------------------------------------------------------------ c.....find w(k+1/2) at each intermideate sigma-layer interface c.....uses sum of div() from w(nz) implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension w(npt,nz),fhd(npt,nz),sigma(nz),nzi(npt) do i = 1, npt win = - fhd(i,1) + w(i,1) do k = 2, nzi(i) - 1 w(i,k) = w(i,k-1) + fhd(i,k) - 1.5*(sigma(k)+sigma(k+1))*win enddo c to check that w(k=last) = 0. c k = nzi(i) c w(i,k) = w(i,k-1) + fhd(i,k) - 1.5*sigma(k)*win enddo return end c ------------------------------------------------------------------ subroutine vertu (npt,nz,nsig,nzi,nzi_b,bint,taux,tauy,u,v,w,h, * fu,fv,fh,vertx,verty,zfu,zfv) c----------------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension bint(1), taux(npt), tauy(npt), u(npt,nz),v(npt,nz), * w(npt,nz), h(npt,nz), fu(npt,nz), fv(npt,nz), nzi(npt) * , zfu(npt), zfv(npt), nzi_b(npt), fh(npt,nz) #ifdef dump_all * , vertx(npt,nz), verty(npt,nz) #endif c.....surface layer: #ifdef dump_all do i = 1, npt do k = 1, nz vertx(i,k) = 0. verty(i,k) = 0. enddo enddo #endif do i = 1, npt fu(i,1) = fu(i,1) + taux(i) fv(i,1) = fv(i,1) + tauy(i) enddo do k = 1, nsig k1 = k + 1 do i = 1, npt w_add = w(i,k) fh(i,k) = fh(i,k) + w_add fh(i,k1) = fh(i,k1) - w_add enddo enddo c.....going by layer interfaces: do i = 1, npt mz = nzi(i) dz = h(i,1) do k = 1, mz - 1 b2 = bint(k) k1 = k + 1 dz = 2.*h(i,k) - dz h_ave = b2/dz u_ave = 0.5*(u(i,k) + u(i,k1)) v_ave = 0.5*(v(i,k) + v(i,k1)) w_add = w(i,k) u_add = h_ave*(u(i,k1) - u(i,k)) + w_add*u_ave v_add = h_ave*(v(i,k1) - v(i,k)) + w_add*v_ave fu(i,k) = fu(i,k) + u_add fu(i,k1) = fu(i,k1) - u_add fv(i,k) = fv(i,k) + v_add fv(i,k1) = fv(i,k1) - v_add if (k.eq.nzi_b(i)) then zfu(i) = zfu(i) + u_add zfv(i) = zfv(i) + v_add endif #ifdef dump_all vertx(i,k) = vertx(i,k) + u_add vertx(i,k1) = vertx(i,k1) + -u_add verty(i,k) = verty(i,k) + v_add verty(i,k1) = verty(i,k1) - v_add #endif enddo enddo return end subroutine vertt (npt,nz,nzi,cint,q,qr,w,h,t,ft) c---------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension cint(nz),q(npt),qr(npt),w(npt,nz),h(npt,nz), * t(npt,nz),ft(npt,nz),tp(1) dimension nzi(npt) parameter (H_ATT1 = -1./17.) do i = 1, npt ft(i,1) = ft(i,1) + q(i) + qr(i) dz = h(i,1) do k = 1, nzi(i) - 1 dz = 2.*h(i,k) - dz k1 = k + 1 c2 = cint(k) tk = t(i,k) tk1 = t(i,k1) h_ave = c2/dz t_ave = 0.5*(tk + tk1) t_add = h_ave*(tk1 - tk) + w(i,k)*t_ave ft(i,k) = ft(i,k) + t_add ft(i,k1) = ft(i,k1) - t_add enddo enddo if (isolrp .eq. 1) then c.....add penetrating solar radiation: do i = 1, npt z = 0. do k = 1, nzi(i) - 1 k1 = k + 1 z = z + h(i,k) t_add = qr(i)*exp(H_ATT1*z) ft(i,k) = ft(i,k) - t_add ft(i,k1) = ft(i,k1) + t_add enddo enddo endif return end subroutine vertts (npt,nz,nzi,cint,q,qr,ep,w,h,t,ft,s,fs) c------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension cint(nz), q(npt), qr(npt), ep(npt), w(npt,nz), h(npt,nz), * t(npt,nz), ft(npt,nz), s(npt,nz), fs(npt,nz), tp(1) dimension nzi(npt) parameter (H_ATT1 = -1./17.) do i = 1, npt ft(i,1) = ft(i,1) + q(i) + qr(i) fs(i,1) = fs(i,1) + ep(i) dz = h(i,1) do k = 1, nzi(i) - 1 dz = 2.*h(i,k) - dz k1 = k + 1 c2 = cint(k) h_ave = c2/dz tk = t(i,k) tk1 = t(i,k1) t_ave = 0.5*(tk + tk1) sk = s(i,k) sk1 = s(i,k1) s_ave = 0.5*(sk + sk1) wik = w(i,k) t_add = h_ave*(tk1 - tk) + wik*t_ave s_add = h_ave*(sk1 - sk) + wik*s_ave ft(i,k) = ft(i,k) + t_add ft(i,k1) = ft(i,k1) - t_add fs(i,k) = fs(i,k) + s_add fs(i,k1) = fs(i,k1) - s_add enddo enddo if (isolrp .eq. 1) then c.....add the penetrating solar radiation: do i = 1, npt z = 0. do k = 1, nzi(i) - 1 k1 = k + 1 z = z + h(i,k) t_add = qr(i)*exp(H_ATT1*z) ft(i,k) = ft(i,k) - t_add ft(i,k1) = ft(i,k1) + t_add enddo enddo endif return end subroutine verttr (npt,nz,nzi,cint,w,h,tr,ftr) c------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension cint(nz), w(npt,nz), h(npt,nz), tr(npt,nz,1), ftr(npt,nz,1) dimension nzi(npt) parameter (H_ATT1 = -1./17.) do i = 1, npt dz = h(i,1) do k = 1, nzi(i) - 1 dz = 2.*h(i,k) - dz k1 = k + 1 c2 = cint(k)/2. h_ave = c2/dz wik = w(i,k)/2. do n = 1, ntrac trk = tr(i,k,n) trk1 = tr(i,k1,n) tr_ave = trk + trk1 tr_add = h_ave*(trk1 - trk) + wik*tr_ave ftr(i,k,n) = ftr(i,k,n) + tr_add ftr(i,k1,n) = ftr(i,k1,n) - tr_add enddo enddo enddo return end subroutine enso2date (enso, id, im, iy) c---------------------------------------------------- #define LEAP_YEAR(y) (mod(y,4) .eq. 0) integer*2 norm(12) data norm /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ iy = 1960 + jint(enso/12.) res = enso - (iy - 1960.)*12. im = jint(res) + 1 if (im .eq. 2 .and. LEAP_YEAR(iy) ) then id = 1 + int(29 * (res - int(res))) else id = 1 + int(norm(im) * (res - int(res))) endif return end function date2enso (id, im, iy) c-------------------------------------- #define LEAP_YEAR(y) (mod(y,4) .eq. 0) integer*2 norm(12) data norm /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ if (im .eq. 2 .and. LEAP_YEAR(iy) ) then date2enso = (iy - 1960.) * 12. + 1. + real((id-1))/29. else date2enso = (iy - 1960.) * 12. + real(im-1) + real((id-1))/norm(im) endif return end subroutine DayOfYear(enso, idoy, idiy) c------------------------------------------------ #define LEAP_YEAR(y) (mod(y,4) .eq. 0) integer*2 norm(12) data norm /0, 31, 59, 90,120,151,181,212,243,273,304,334/ call enso2date(enso, id, im, iy) if (LEAP_YEAR(iy)) then idiy = 366 else idiy = 365 endif if (im .gt. 2 .and. LEAP_YEAR(iy) ) then idoy = norm(im) + id + 1 else idoy = norm(im) + id endif return end subroutine enso2res (renso, id, im, iy) c---------------------------------------------------- #define LEAP_YEAR(y) (mod(y,4) .eq. 0) integer*2 norm(12) data norm /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ iy = jint(renso/12.) res = renso - real(12*iy) im = jint(res) res = abs(res - real(im)) id = jint(res*norm(im+1)) return end c ------------------------------------------------------------------ subroutine knergy(npt,nz,nptk,isk,area,basin,h,u,v,en) c ------------------------------------------------------------------ c subroutine to compute the kinetic energy c c the kinetic energy is given by c k.e. = sum < 1/2 h(k)*u(k)^2 >. c c en(1,k) = (output) kinetic energy for layer k. c en(2,k) = not used c note: area(i) = .5*dx*dy c note: basin = sum(area) (i.e., half the surface area) c implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension u(npt,1),v(npt,1),h(npt,1),area(1),en(npten,1), * nptk(1),isk(npt,1) c........Compute the Kinetic Energy, each layer and total eksum = 0.0 do k = 1, nz ek = 0.0 do j = 1, nptk(k) i = isk(j,k) uu = u(i,k) vv = v(i,k) ek = ek + area(i) * h(i,k) * (uu*uu + vv*vv) enddo en(1,k)= 0.5 * ek / basin eksum = eksum + en(1,k) enddo en(1,nz+1) = eksum return end c ------------------------------------------------------------------ subroutine pnergy (ifrst,npt,nptk,nz,isk,h,area,t,dens,w,basin,en,tp) c ------------------------------------------------------------------ c subroutine to compute the potential energy, the heat content, c and the temperature variance and total mass. c en(k,3) = (output) Potential Energy for layer k. c en(k,4) = (output) Heat Content for layer k. c en(k,5) = (output) Mass Content for layer k. c en(k,6) = (output) Volume for layer k. c p.e. = sum - 1/2 g , c b(k) = alpha*g*(t(k)-t(b)) c Heat Content = sum c Mass Content = sum c Volume = sum c include 'comm_para.h' include 'comm_new.h' logical ifrst dimension h(npt,1),area(1),t(npt,1),dens(npt,1),w(npt,1), * en(npten,1), tp(1), tmp(npt,1), nptk(1), isk(npt,1) pointer (ptmp, tmp) if (use_salt) then ptmp = loc(dens) base = SITUD_BOT shift = 1000. else ptmp = loc(t) base = TEMP_BOT shift = 1. endif do i = 1, npt tp(i) = h(i,1) enddo epsum = 0. hcsum = 0. wcsum = 0. vlsum = 0. c.......................integrate over each layer. do k = 1, nz epk = 0. hck = 0. wck = 0. vlk = 0. do j = 1, nptk(k) i = isk(j,k) hk = h(i,k) ahk = area(i) * hk ahbk = ahk * (tmp(i,k) - base) epk = epk + ahbk * (hk - w(i,nz) + tp(i)) hck = hck + ahbk wck = wck + ahk * (shift + tmp(i,k)) vlk = vlk + ahk enddo en(3,k) = epk en(4,k) = hck en(5,k) = wck en(6,k) = vlk epsum = epsum + epk hcsum = hcsum + hck wcsum = wcsum + wck vlsum = vlsum + vlk c find 2*(sum h(j)+h(k)/2) for the next layer. if (k .lt. nz) then do j = 1, nptk(k) i = isk(j,k) tp(i) = tp(i) + h(i,k) + h(i,k+1) enddo endif enddo if ( ifrst ) then epf1 = 1./epsum hcf1 = 1./hcsum wcf1 = 1./wcsum vlf1 = 1./vlsum endif do k = 1, nz en(3,k) = epf1 * en(3,k) en(4,k) = hcf1 * en(4,k) en(5,k) = wcf1 * en(5,k) en(6,k) = vlf1 * en(6,k) enddo en(3,nz+1) = epf1 * epsum en(4,nz+1) = hcf1 * hcsum en(5,nz+1) = wcf1 * wcsum en(6,nz+1) = vlf1 * vlsum return end c subroutine vel_updat(npt,nz,nzi,binv,abinv,uc,vc,fu,fv) c ---------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension uc(npt,nz),vc(npt,nz),fu(npt,nz),fv(npt,nz),nzi(npt) do i = 1, npt do k = 1, nzi(i) uc(i,k) = uc(i,k) + binv*fu(i,k) vc(i,k) = vc(i,k) + binv*fv(i,k) fu(i,k) = abinv*fu(i,k) fv(i,k) = abinv*fv(i,k) enddo enddo return end c ------------------------------------------------------------------ subroutine dhoriz(npt,u,v,uc,vc,f,fu,fv,fhd,emx,emy,emxy,tp,mbc,zfu,zfv, * lxxk,lyyk,lxyk,lyxk,snxk,snyk,isyk,isk,lpbcwk,lpbcek,nzi * ,corx,cory,xnl,ynl,fh) c ------------------------------------------------------------------ c subroutine that calculates the horizontal terms in the momentum c equation. e.g. the coriolis terms and the horizontal advection c terms. c c npt = (input) # of grid points per model layer (nxyc or nxy). c u,v = (input) zonal & merid. velocity for time step n. c uc,vc = (input) mass transport. c fu,fv = (input/output) update transport arrays c emx,emy= (input) factor for x,y-differencing, d(psix)/dx*1/delx. c lxx,...= (input) nbx+ncs indices of the ocean x,y-segment end points c snx,sny= (input) nbx+ncs signs (+1 or -1) c isy = (input) indices to convert from an x-sort to a y-sort. c tp = (input) temporary space. c mbc = (input) type of boundary condition on u and v c implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' common /baro_input/ n_def_cor, mod_scheme, mod_solver, BAR_DELTA, * BAR_DSINK, ibar_key, nbaro, rayl common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch dimension u(npt,nz),v(npt,nz),uc(npt,nz),vc(npt,nz),f(npt),fu(npt,nz),fv(npt,nz), * emx(npt),emy(npt),emxy(npt), tp(npt,1), zfu(npt), zfv(npt), fhd(npt,nz) * , corx(npt,nz), cory(npt,nz) * , xnl(npt,nz), ynl(npt,nz), fh(npt,nz) dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz), * snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz), * lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz),nzi(npt) c c set boundary condition flag for differencing at or near the c boundary. c c for cases where the derivative is in the direction to the flow c for the cases where u slips along zonal boundaries (mbc=2,3), c interior corners are not used. c nbu = 0 c c for no-slip everywhere (mbc=1) or at zonal boundaries (mbc=0), c interior corners are used for a one-sided difference. c if(mbc.eq.1 .or. mbc.eq.4) nbu = 1 c c for the cases where v slips along meridional boundaries (mbc=2,4), c interior corners are not used. c nbv = 0 c c for no-slip everywhere (mbc=1) or at meridional boundaries c (mbc=3), interior corners are used. c c.....update fh in sigma layers: do k = 1, nsig do i = 1, npt fh(i,k) = fh(i,k) - fhd(i,k) enddo enddo if(mbc.eq.1 .or. mbc.eq.3) nbv = 1 do k = 1, nz npk = nptk(k) nxk = nbxk(k) nyk = nbyk(k) nck = ncsk(k) npbk = npbck(k) c.....add coriolis terms: do j = 1, npk i = isk(j,k) tmp = f(i)*vc(i,k) fu(i,k) = fu(i,k) + tmp corx(i,k) = tmp tmp = -f(i)*uc(i,k) fv(i,k) = fv(i,k) + tmp cory(i,k) = tmp enddo c.....add d(hu^2)/dx do j = 1,npk i = isk(j,k) tp(i,2) = uc(i,k)*u(i,k) ynl(i,k) = 0. enddo call dfdxk(tp(1,2),tp,npt,npk,nbu,nxk,nyk,nck,lxxk(1,k),lyxk(1,k), * snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k)) do j = 1, npk i = isk(j,k) tmp = emx(i)*tp(i,1) fu(i,k) = fu(i,k) - tmp xnl(i,k) = -tmp enddo if (mgrid .eq. 2) then do j = 1, npk i = isk(j,k) tmp = emxy(i)*tp(i,2) fv(i,k) = fv(i,k) + tmp ynl(i,k) = +tmp enddo endif c.....find dv**2h/dy do j = 1, npk i = isk(j,k) tp(i,2) = vc(i,k)*v(i,k) enddo call dfdyk(tp(1,2),tp,npt,npk,nbv,nyk,nxk,nck,lyyk(1,k),lxyk(1,k), * snyk(1,k),isyk(1,k)) do j = 1, npk i = isk(j,k) tmp = emy(i)*tp(i,1) fv(i,k) = fv(i,k) - tmp ynl(i,k) = ynl(i,k)-tmp enddo if (mgrid .eq. 2) then do j = 1, npk i = isk(j,k) tmp = emxy(i)*tp(i,2) fv(i,k) = fv(i,k) - tmp ynl(i,k) = ynl(i,k)-tmp enddo endif c.....find d(u*h*v)/dx do j = 1, npk i = isk(j,k) tp(i,3) = uc(i,k)*v(i,k) enddo call dfdxk(tp(1,3),tp,npt,npk,1,nxk,nyk,nck,lxxk(1,k),lyxk(1,k), * snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k)) do j = 1, npk i = isk(j,k) tmp = emx(i)*tp(i,1) fv(i,k) = fv(i,k) - tmp ynl(i,k) = ynl(i,k)-tmp enddo c.....find d(u*h*v)/dy call dfdyk(tp(1,3),tp,npt,npk,1,nyk,nxk,nck,lyyk(1,k),lxyk(1,k), * snyk(1,k),isyk(1,k)) do j = 1, npk i = isk(j,k) tmp = emy(i)*tp(i,1) fu(i,k) = fu(i,k) - tmp xnl(i,k) = xnl(i,k)-tmp enddo if (mgrid .eq. 2) then do j = 1, npk i = isk(j,k) tmp = 2.*emxy(i)*tp(i,3) fu(i,k) = fu(i,k) - tmp xnl(i,k) = xnl(i,k)-tmp enddo endif enddo c..... add bottom drag c do i = 1, npt c mz = nzi(i) c do k = 1, mz c c bfric = rayl * uc(i,k) c fu(i,k) = fu(i,k) - bfric c zfu(i) = zfu(i) - bfric c c bfric = rayl * vc(i,k) c fv(i,k) = fv(i,k) - bfric c zfv(i) = zfv(i) - bfric c enddo c enddo do i = 1, npt mz = nzi(i) do k = 1, mz c uncomment next 2 lines to take out the nonlinear terms in the barotropic part zfu(i) = zfu(i) + xnl(i,k) zfv(i) = zfv(i) + ynl(i,k) zfu(i) = zfu(i) + corx(i,k) zfv(i) = zfv(i) + cory(i,k) enddo enddo return c end of dhoriz. end c ------------------------------------------------------------------ subroutine thoriz(npt,uc,vc,t,ft,fhd,emx,emy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,lok,tp,mbc,lpbcwk,lpbcek) c ------------------------------------------------------------------ c note: mtc is not used in this version of the code. rather c n.grad(t)=0 is set at all closed boundaries. at open boundaries c determined in the input grid file (see rdgrid), the temperature c derivative is not zeroed and t is set in tbcset. c c subroutine that calculates the horizontal terms in the c temperature equation. c implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) dimension uc(npt,nz),vc(npt,nz),t(npt,nz),ft(npt,nz),emx(npt),emy(npt), * tp(npt,3),fhd(npt,nz) dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz), * snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz), * lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz),lok(4*MAXSID,nz) c c in order to impose the zero heat flux condition at the boundaries c the divergence operator is broken up. c c set boundary condition flag for differencing the mass transport c at or near the boundary in the direction of the flow. c c for the cases where u slips along zonal boundaries (mbc=2,3), c interior corners are not used. c nbu = 0 c c for no slip everywhere (mbc=1) or at zonal boundaries (mbc=4), c interior corners are used for a one-sided difference. c if(mbc.eq.1 .or. mbc.eq.4) nbu = 1 c c for the cases where v slips along meridional boundaries c (mbc=2,4), interior corners are not used. c nbv = 0 c c for no slip everywhere (mbc=1) or at meridiional boundaries c (mbc=3), interior corners are used. c if(mbc.eq.1 .or. mbc.eq.3) nbv = 1 c do k = 1, nz npk = nptk(k) nxk = nbxk(k) nyk = nbyk(k) nck = ncsk(k) npbk = npbck(k) nok = nlok(k) c.....compute dt/dx (dt/dx=0 at x-boundaries) call dfdxk(t(1,k),tp,npt,npk,0,nxk,nyk,nck,lxxk(1,k),lyxk(1,k), * snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k)) call zerodt(tp,nok,lok(1,k),nxk,lxxk(1,k),tp(1,3)) c.....compute dt/dy (dt/dy=0 at y-boundaries) call dfdyk(t(1,k),tp(1,2),npt,npk,0,nyk,nxk,nck,lyyk(1,k),lxyk(1,k), * snyk(1,k),isyk(1,k)) call zerodt(tp(1,2),nok,lok(1,k),nyk,lyxk(1,k),tp(1,3)) c.....update the heat content array. do j = 1, npk i = isk(j,k) ft(i,k) = ft(i,k)-(emx(i)*uc(i,k)*tp(i,1) + emy(i)*vc(i,k)*tp(i,2)) ft(i,k) = ft(i,k) - t(i,k)*fhd(i,k) enddo enddo return c end of thoriz. end c subroutine zero_em (n, a) c-------------------------------- dimension a(1) do i = 1, n a(i) = 0.0 enddo return end subroutine copya2b (n, a, b) c-------------------------------- dimension a(1), b(1) do i = 1, n b(i) = a(i) enddo return end c ------------------------------------ subroutine decap(npt, nz, nzi, u,v,uc,vc,h) c ------------------------------------ c subroutine to convert horizontal transport to horizontal velocity. implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension u(npt,nz),v(npt,nz),uc(npt,nz),vc(npt,nz),h(npt,nz),nzi(npt) c do i = 1, npt do k = 1, nzi(i) hinv = 1./h(i,k) u(i,k) = uc(i,k)*hinv v(i,k) = vc(i,k)*hinv enddo enddo return end c ------------------------------------------------------------------ subroutine capfrm(npt,nz,nzi, u,v,uc,vc,h) c ------------------------------------------------------------------ c subroutine to convert velocities to transport. c implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension u(npt,nz),v(npt,nz),uc(npt,nz),vc(npt,nz),h(npt,nz),nzi(npt) c do i = 1, npt do k = 1, nzi(i) hk = h(i,k) uc(i,k) = u(i,k)*hk vc(i,k) = v(i,k)*hk enddo enddo return c end of capfrm. end c ------------------------------------- subroutine tdecap(npt, nzi, t, h) c ------------------------------------- c.....convert heat content to temperature. implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension t(npt,1), h(npt,1), nzi(npt) do i = 1, npt do k = 1, nzi(i) t(i,k) = t(i,k)/h(i,k) enddo enddo return end subroutine fixed_dep (npt,nzi_b,h,fu,fv,tfu,tfv,rhsx,rhsy,crhsx,crhsy) c----------------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension h(npt,1),fu(npt,1),fv(npt,1),tfu(1),tfv(1),nzi_b(npt) #ifdef dump_all dimension rhsx(npt,1), rhsy(npt,1) dimension crhsx(npt,1), crhsy(npt,1) #endif do i = 1, npt do k = 1, nzi_b(i) hk = h(i,k) #ifdef dump_all rhsx(i,k) = fu(i,k) rhsy(i,k) = fv(i,k) #endif fu(i,k) = fu(i,k) - hk* tfu(i) fv(i,k) = fv(i,k) - hk* tfv(i) #ifdef dump_all crhsx(i,k) = fu(i,k) crhsy(i,k) = fv(i,k) #endif enddo enddo return end c ------------------------------------------------------------------ subroutine capt(npt,nz,nzi,t,h) c ------------------------------------------------------------------ c form the heat content, ht, from the temperature. c dimension t(npt,nz),h(npt,nz),nzi(npt) c do i = 1, npt do k = 1, nzi(i) t(i,k) = t(i,k)*h(i,k) enddo enddo return c end of capt. end c ------------------------------------------------------------------ subroutine tupdat(npt,nz,nzi,binv,abinv,t,ft) c ------------------------------------------------------------------ c update temperature fields as was done for u, v, h in updat1. c implicit real(a-h,o-z),integer(i-n) dimension t(npt,nz),ft(npt,nz),nzi(npt) c do i = 1, npt do k = 1, nzi(i) t(i,k) = t(i,k) + binv*ft(i,k) ft(i,k) = abinv*ft(i,k) enddo enddo return c end of tupdat. end c ------------------------------------------------------------------ subroutine zerodt(dt,nlo,lo,nb,lb,tp) c ------------------------------------------------------------------ c set flux of t zero at the boundaries. c dt/dx = 0 at the x-sidewall boundaries. c dt/dy = 0 at the y-sidewall boundaries. c dimension dt(1),lo(1),tp(1),lb(1) c if (nlo.gt.0) then c first save the open boundary dt values. do i=1,nlo tp(i) = dt(lo(i)) enddo endif c c now zero dt at all x or y-boundaries. do i=1,nb dt(lb(i)) = 0. enddo c if (nlo.gt.0) then c replace dt values at open boundaries. do i=1,nlo dt(lo(i)) = tp(i) enddo endif c return c end of zerodt. end c ------------------------------------------------------------------ subroutine bcset(mbc,lxxk,lyyk,npt,u,v,nzi,nzi_b) c ------------------------------------------------------------------ c impose the u, v boundary conditions according to mbc. c c mbc = (input) type of boundary condition: c = 1; u(xb)=v(yb)=u(yb) = v(xb) = 0; no slip everywhere. c = 2; u(xb)=v(yb) = 0; no normal flow. c = 3; u(xb)=v(yb)=du(yb)/dy= v(xb) = 0; no slip at eastern c and western side walls; free slip along northern and c southern boundaries/steps, v=du/dy=0. c = 4; u(xb)=v(yb)=u(yb) = dv(xb)/dx= 0; no slip at northern c and southern; free slip along eastern and western c boundaries/steps, u=dv/dy=0. c c lxx = (input) nbx x-boundary plus ncs corner indices for a c regular or compressed x-sort. c lyy = (input) nby y-boundary plus ncs corner indices for a c regular or compressed x-sort. c npt = (input) number of field points/layer. c u,v = (input) fields. c = (output) fields with boundary conditions imposed. c implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) dimension lxxk(MXBDY,nz), lyyk(MXBDY,nz) dimension u(npt,nz),v(npt,nz),nzi(npt),nzi_b(npt) c c normal components are always zero at boundaries, u(xb)=v(yb)=0. c similarly, so is the along boundary derivative c du(xb)/dy = dv(yb)/dx = 0. c c the ncs corner points are part of the u/v-boundaries depending c on mbc. c mbc = 1; yes for u and v; du(yb)/dx = dv(xb)/dy = 0. c = 2; no for u and v. c = 3; no for u, yes for v; dv(xb)/dy = 0. c = 4; yes for u, no for v; du(yb)/dx = 0. c do k = 1, nz do i = 1, nbxk(k) u(lxxk(i,k),k) = 0. enddo do i = 1, nbyk(k) v(lyyk(i,k),k) = 0. enddo enddo do i = 1, npt do k = nzi_b(i)+1,nzi(i) u(i,k) = 0. v(i,k) = 0. enddo enddo if(mbc.eq.1 .or. mbc.eq.4) then do 30 k=1,nz do 30 i=1,nbyk(k)+ncsk(k) 30 u(lyyk(i,k),k) = 0. endif c if(mbc.eq.1 .or. mbc.eq.3) then do 40 k=1,nz do 40 i=1,nbxk(k)+ncsk(k) 40 v(lxxk(i,k),k) = 0. endif return c end of bcset. end c -------------------------------------------------------- logical function non_stable (iout, npt, nxp, nz, iox, t, u, v) c -------------------------------------------------------- c check to see that t or velocities are not bizarre c h = (input) layer thickness field. implicit real(a-h,o-z),integer(i-n) dimension t(npt,1), iox(1), u(npt,1), v(npt,1) c non_stable = .false. icheck = 0 do i = 1, npt if (t(i,2) .lt. -10..or.t(i,2).gt.50.or. * u(i,1)**2+v(i,1)**2.gt.400.) icheck = icheck + 1 enddo non_stable = (icheck .ne. 0) if (non_stable) then write (iout, *) 'Number of illegal points =', icheck do i = 1, npt if (t(i,2) .lt. -10..or.t(i,2).gt.50) then jj = 1 + (iox(i)-1)/nxp ii = iox(i) - (jj-1)*nxp write (iout, 11) i, ii, jj, t(i,2) endif if (u(i,1)**2 + v(i,1)**2 .gt. 400.) then jj = 1 + (iox(i)-1)/nxp ii = iox(i) - (jj-1)*nxp write (iout, 12) i, ii, jj endif enddo endif 11 format ('t(k=',i4,',2)[i=',i3,',j=',i3,'] =', g10.3) 12 format ('i,ii,jj=',3i8,' velocity is greater than 20 m/s') return end subroutine h_updat(npt,nsig,binv,abinv,h,fh) c------------------------------------------------ implicit real(a-h,o-z),integer(i-n) dimension h(npt,1),fh(npt,1) include 'comm_new.h' do k = 1, nsig do i = 1, npt h(i,k) = h(i,k) + binv*fh(i,k) fh(i,k) = abinv*fh(i,k) enddo enddo return end c ------------------------------------------------------------------ subroutine btpgf(npt,nzi_b,h,temp,dens,fu,fv,emx,emy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,lok,tp,tq,tr,lpbcwk,lpbcek,zfu,zfv, * pgfx,pgfy) c ------------------------------------------------------------------ c subroutine that calculates the pressure gradient terms in the c momentum equation c implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' include 'comm_new.h' dimension h(npt,nz),temp(npt,nz), fu(npt,nz),fv(npt,nz), * emx(1),emy(1),tp(npt,4),tq(npt,4),tr(npt,1), * dens(npt,nz),tmp(npt,nz),zfu(npt),zfv(npt), * pgfx(npt,nz),pgfy(npt,nz) dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz), * snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),nzi_b(npt), * lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz),lok(4*MAXSID,nz) pointer (p_tmp, tmp) common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) c-new temp array should contain temp, not heat content!!! c-new dens array should contain dens, not mass!!! c if (use_salt) then c .......................................case of density from EOS: c b = (grav/(1000+sigma0)) * (sigma0 - sigma(k)) c coef = -GRAVTY / (1000. + SITUD_BOT) bottom = SITUD_BOT p_tmp = loc(dens) else c .....................case of linear (in T) density and buoyancy: c b = alph * grav * (t(k) - t_bot) coef = TALPHA * GRAVTY bottom = TEMP_BOT p_tmp = loc(temp) endif do i = 1, npt dh = h(i,1)/2. tp(i,1) = dh*tmp(i,1) tp(i,2) = dh tp(i,4) = dh tq(i,3) = coef * emx(i) tq(i,4) = coef * emy(i) enddo do k = 1, nz npk = nptk(k) nxk = nbxk(k) nyk = nbyk(k) nck = ncsk(k) npbk = npbck(k) nok = nlok(k) call dfdxk(tp,tq,npt,npk,0,nxk,nyk,nck,lxxk(1,k),lyxk(1,k), * snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k)) call dfdxk(tp(1,2),tq(1,2),npt,npk,0,nxk,nyk,nck,lxxk(1,k),lyxk(1,k), * snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k)) call zerodt(tq(1,1),nok,lok(1,k),nxk,lxxk(1,k),tp(1,3)) call zerodt(tq(1,2),nok,lok(1,k),nxk,lxxk(1,k),tp(1,3)) do j = 1, npk i = isk(j,k) abc = tq(i,3) * h(i,k) * (tq(i,1) - tmp(i,k) * tq(i,2)) pgfx(i,k) = abc fu(i,k) = fu(i,k) + abc enddo call dfdyk(tp(1,1),tq(1,1),npt,npk,0,nyk,nxk,nck,lyyk(1,k),lxyk(1,k), * snyk(1,k),isyk(1,k)) call dfdyk(tp(1,2),tq(1,2),npt,npk,0,nyk,nxk,nck,lyyk(1,k),lxyk(1,k), * snyk(1,k),isyk(1,k)) call zerodt(tq(1,1),nok,lok(1,k),nyk,lyxk(1,k),tp(1,3)) call zerodt(tq(1,2),nok,lok(1,k),nyk,lyxk(1,k),tp(1,3)) do j = 1, npk i = isk(j,k) abc = tq(i,4) * h(i,k) * (tq(i,1) - tmp(i,k) * tq(i,2) ) pgfy(i,k) = abc fv(i,k) = fv(i,k) + abc enddo if (k .lt. nz) then do j = 1, npk i = isk(j,k) dh = h(i,k) - tp(i,4) tp(i,1) = tp(i,1) + dh*(tmp(i,k) + tmp(i,k+1)) tp(i,2) = tp(i,2) + 2.*dh tp(i,4) = dh enddo endif enddo do i = 1, npt do k = 1, nzi_b(i) zfu(i) = zfu(i) + pgfx(i,k) zfv(i) = zfv(i) + pgfy(i,k) enddo enddo return end c ------------------------------------------------------------------ subroutine btpgf_old(npt,nzi_b,h,temp,dens,fu,fv,emx,emy,lxxk,lyyk,lxyk,lyxk, * snxk,snyk,isyk,isk,lok,tp,tq,tr,lpbcwk,lpbcek,zfu,zfv, * pgfx,pgfy) c ------------------------------------------------------------------ c subroutine that calculates the pressure gradient terms in the c momentum equation for A CASE WITH CONSTANT DEPTH. c implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' include 'comm_new.h' dimension h(npt,nz),temp(npt,nz), fu(npt,nz),fv(npt,nz), * emx(1),emy(1),tp(npt,3),tq(npt,3),tr(npt,1), * dens(npt,nz),tmp(npt,nz),zfu(npt),zfv(npt), * pgfx(npt,nz),pgfy(npt,nz) dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz), * snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),nzi_b(npt), * lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz),lok(4*MAXSID,nz) pointer (p_tmp, tmp) common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) c-new temp array should contain temp, not heat content!!! c-new dens array should contain dens, not mass!!! c if (use_salt) then c .......................................case of density from EOS: c b = (grav/(1000+sigma0)) * (sigma0 - sigma(k)) c coef = -GRAVTY / (1000. + SITUD_BOT) bottom = SITUD_BOT p_tmp = loc(dens) else cc .....................case of linear (in T) density and buoyancy: c b = alph * grav * (t(k) - t_bot) coef = TALPHA * GRAVTY bottom = TEMP_BOT p_tmp = loc(temp) endif do i = 1, npt dz = h(i,1)/2. tp(i,1) = dz * tmp(i,1) tp(i,2) = dz tq(i,2) = coef * emx(i) tq(i,3) = coef * emy(i) enddo do k = 1, nz npk = nptk(k) nxk = nbxk(k) nyk = nbyk(k) nck = ncsk(k) npbk = npbck(k) nok = nlok(k) call dfdxk(tp,tq,npt,npk,0,nxk,nyk,nck,lxxk(1,k),lyxk(1,k), * snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k)) call zerodt(tq,nok,lok(1,k),nxk,lxxk(1,k),tp(1,3)) do j = 1, npk i = isk(j,k) abc = tq(i,2) * h(i,k) * tq(i,1) pgfx(i,k) = abc fu(i,k) = fu(i,k) + abc enddo call dfdyk(tp,tq,npt,npk,0,nyk,nxk,nck,lyyk(1,k),lxyk(1,k), * snyk(1,k),isyk(1,k)) call zerodt(tq,nok,lok(1,k),nyk,lyxk(1,k),tp(1,3)) do j = 1, npk i = isk(j,k) abc = tq(i,3) * h(i,k) * tq(i,1) pgfy(i,k) = abc fv(i,k) = fv(i,k) + abc enddo if (k .lt. nz) then do j = 1, npk i = isk(j,k) dz = h(i,k) - tp(i,2) tp(i,2) = dz tp(i,1) = tp(i,1) + dz * (tmp(i,k) + tmp(i,k+1)) enddo endif enddo do i = 1, npt do k = 1, nzi_b(i) zfu(i) = zfu(i) + pgfx(i,k) zfv(i) = zfv(i) + pgfy(i,k) enddo enddo return end dyn_subs.f/ 839513370 1572 1572 100444 16496 ` c$Source: /usr/our/senya/work/model/MC_PG/senq/RCS/dyn_subs.f,v $ c$Author: senya $ c$Revision: 0.4 $ c$Date: 94/01/24 11:04:57 $ c$State: Exp $ c ------------------------------------------------------------------ subroutine aarea(lxx,lyx,emx,emy,emxy,area,basin) c ------------------------------------------------------------------ c compute the stretched grid area factors for computing integrals c over the grid in the stretched coordinate system. c dx*dy = (d(x)/dpsi1(x) * d(y)/dpsi2(y)) * dpsi1 * dpsi2 c for transformation (stretching) functions dpsi1 and dpsi2. c c from common block grid: c nxp,nyp = (input) grid dimensions in the x and y directions. c nxyc = (input) number of ocean grid points. c land = (input) land storage flag. c nbx,nby = (input) number of x and y boundaries. c ncs = (input) number of interior corner boundary grid points. c c lxx = (input) nbx indices of the x-boundaries for an x c (compressed or regular) sort. c lyx = (input) nby indices of the y-boundaries for an x c (compressed or regular) sort. c emx = (input) factor for x-differencing = d(psi1)/d(x)*(1./delx) c emy = (input) factor for y-differencing = d(psi2)/d(y)*(1./dely) c area = (output) .5*dx*dy. c basin = (output) .5*(total basin area). c implicit real(a-h,o-z),integer(i-n) common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc dimension lxx(1),lyx(1),emx(1),emy(1),area(1),emxy(1) c r2 = 0.5 npt = nxyc c c find 1/2 the area (1/2 factor used on energy calculations) c as if all grid squares were completely ocean. c do 10 i=1,npt 10 area(i) = r2/(emx(i)*emy(i)) c c correct the x-boundary grid point areas. c do 20 i=1,nbx 20 area(lxx(i)) = area(lxx(i))*.5 c c correct the y-boundary grid point areas. c do 30 i=1,nby 30 area(lyx(i)) = area(lyx(i))*.5 c c correct the interior corner point areas. c do 40 i=nbx+1,nbx+ncs 40 area(lxx(i)) = area(lxx(i))*.75 basin = 0. do 60 i=1,npt 60 basin = basin + area(i) return c end of aarea. end c c ------------------------------------------------------------------ subroutine scaset(iox,x,y,xp,yp,f,emx,emy,emxy,emx2,emy2,tp) c ------------------------------------------------------------------ c subroutine called by wdrivn that computes the coordinates of the c grid points and length scale variables with and without stretching, c e.g. arrays emx, emy, emxy, and f. c c from common block grid: c c nxp,nyp = (input) grid dimensions in the x and y directions. c nxyc = (input) number of ocean grid points. c c from common block coords: c c alon,blon = (input) min,max x grid coordinates in degrees. c alat,blat = (input) min,max y grid coordinates in degrees. c rlat = (input) reference latitude for beta plane and f plane. c mgrid = (input) determines coordinate system (stretching c determined by nsx, nsy). c = 1; beta plane with delx = (blon-alon)/((nxp-1)*rearth). c = 2; spherical coords with c delx = (blon-alon)((nxp-1)*rearth*cos(y(i)) c (for spherical coords, delx is a function of the c convergence of meridians away from the equator.) c = 3; f-plane with c delx = (blon-alon)((nxp-1)*rearth). c nsx,nsy = (input) see routine stretch for a description. c = 0; no stretching. c c iox = (input) nxyc indices of the x-sorted ocean grid points. c x,y = (output) nxp x and nyp y grid point coordinates (degrees). c xp = (output) nxp derivatives of the x-transformation function c if coordinate stretching is used (see gridxy). c yp = (output) nyp derivatives of the y-transformation function c if coordniate stretching is used (see gridxy). c emx = (output) factor for x-differencing= d(psi1)/d(x)*(1./delx) c emy = (output) factor for y-differencing= d(psi2)/d(y)*(1./dely) c f = (output) coriolis factor for routine dhoriz. c implicit real(a-h,o-z),integer(i-n) parameter (maxxs=50) parameter (REARTH = 6378000., * DTOSEC = 86400., * RAD = 3.14159265/180., * TOMEGA = 4.*3.14159265/DTOSEC) common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch common/strech/xs(maxxs),alpha(maxxs),beta(maxxs) c c for spherical coords (mgrid=2), add array emxy to dimension c and subroutine calls. c dimension iox(1),x(1),y(1),xp(1),yp(1),emx(1),emy(1),f(1),emxy(1) * ,emx2(1), emy2(1), tp(1) c c compute the grid point x and y coordinates in degrees. c call gridxy(nxp,nyp,alon,blon,alat,blat,nsx,nsy,nystrch,xs,alpha,beta, + x,y,xp,yp,tp,tp(nxp+1)) delx = (blon-alon)*RAD/float(nxp-1) dely = (blat-alat)*RAD/float(nyp-1) c c convert to inverse delta x and delta y scale in m. c xfac = 1./(delx*REARTH) yfac = 1./(dely*REARTH) rlat = 0.5*(alat + blat) if ( (mgrid.eq.1) .or. (mgrid.eq.3) ) then c........beta plane or f plane. fz = sin(rlat*rad) betap = cos(rlat*rad) cosy = 1./betap c.............................for on f-plane. if (mgrid .eq.3 ) betap = 0. do k = 1, nxyc j = (iox(k)-1)/nxp + 1 i = iox(k) - (j-1)*nxp f(k) = (fz + betap*RAD*(y(j)-rlat))*TOMEGA emx(k) = xfac*xp(i)*cosy emy(k) = yfac*yp(j) enddo elseif (mgrid .eq. 2) then c.......................for spherical coordinates. do k = 1, nxyc c convert the x-sort index to i,j. j = (iox(k)-1)/nxp + 1 i = iox(k) - (j-1)*nxp yrad = y(j)*RAD fj = sin(yrad)*TOMEGA cosy = 1./cos(yrad) xyfac = -tan(yrad)/REARTH cos2 = cosy*cosy f(k) = fj emx(k) = xfac*xp(i)*cosy emy(k) = yfac*yp(j) emxy(k) = xyfac emx2(k) = xfac*xfac*tp(i)*cos2 emy2(k) = yfac*yfac*tp(nxp+j) enddo endif return c end of scaset. end c c ------------------------------------------------------------------ subroutine stretch(nx,xmin,xmax,ns,xs,alpha,beta,x,xp,xpp) c ------------------------------------------------------------------ c compute grid point locations for a stretched coordinate system. c c nx = (input) # of grid points in a coordinate direction. c xmin,xmax = (input) coordinate range of the nx grid points. c ns = (input) # of atan's defining the transformation from c the stretched coordinates to the regular coordinates. c xs = (input) ns locations of the atan's. c alpha = (input) ns scaling parameters for the atan's in degrees. c beta = (input) ns scaling parameters for the atan's in degrees. c x = (output) nx stretched grid point locations. c xp = (output) nx derivatives of the transformation function c d(psi(x))/d(x). c xpp = (output) nx second derivatives of the transformation c function: d^2(psi(x))/d(x)^2. (by Senya Basin) c c the transformation from the stretched coordinates x to the regular c coordinates xx is c xx = psi(x) = a + b*(x + sum of alpha(i)*atan((x-xs(i))/beta(i)) c + c*x**2 c c the extra degree of freedom provided by c*x**2 is used to locate c a grid point right at the equator. note the definition of psi c differs slightly from cane & gent & ncar code. alpha can be c modified to reproduce ncar stretching. c c for nx equally spaced values of xx from xmin to xmax, this routine c finds the corresponding values of the coord x. the stretched grid c point spacing will be the smallest near x=xs(i). increasing the c parameter alpha(i) increases the # of stretched grid points in the c vicinity of xs(i). increasing beta(i) widens the region around c xs(i) in which grid points are concentrated. if xmin*xmax.ge.0. c (basin does not span the equator) then the parameter c is set to c 0., and a and b are chosen by this routine to force the ends of c the computational and physical grids to be the same: c psi(xmin)=xmin, psi(xmax)=xmax. if xmin*xmax .lt. 0., then the c parameters a, b, and c are chosen to force psi(xmin)=xmin, c psi(0.)=0., and psi(xmax)=xmax. c c nbegns : the function psi(x) is initially computed at nbegns c equally spaced points between xmin and xmax to provide c a table of starting values for the iterative solution. c c maxit = the maximum allowed number of iterations. c c eps = the iterative solution for x is continued until c abs( (x_this_iter. - x_last_iter.)/x_last_iter. ).le.eps c implicit real(a-h,o-z),integer(i-n) parameter (nbegns=100, maxit=1000, eps=1.e-6) dimension xs(1),alpha(1),beta(1),x(1),xp(1),xpp(1) c c solve for a, b, (and c) by construing the physical and c computational grids at the end points (and equator). c if(xmin*xmax.ge.0.) then c c get the scaling factors a and b, which will force c psi(xmin)=xmin and psi(xmax)=xmax. c c evaluate psi at the end points as if a=0 and b=1. c ymin = psi(xmin,0.,1.,0.,ns,xs,alpha,beta) ymax = psi(xmax,0.,1.,0.,ns,xs,alpha,beta) c solving for two equations and two unknowns yields: a = (xmin*ymax-ymin*xmax)/(ymax-ymin) b = (xmax-xmin)/(ymax-ymin) c = 0. else c c for a basin that includes the equator. c c get the scaling factors a,b and c, which will force c psi(xmin)=xmin, psi(xmax)=xmax, and psi(0.) = 0. c c evaluate psi at the end points and equator as if c a=c=0 and b=1. c ymin = psi(xmin,0.,1.,0.,ns,xs,alpha,beta) ymax = psi(xmax,0.,1.,0.,ns,xs,alpha,beta) y0 = psi( 0.,0.,1.,0.,ns,xs,alpha,beta) x1 = xmin*xmin x2 = xmax*xmax c solving three equations for three unknowns: b = (xmin*x2-xmax*x1)/(x2*(ymin-y0)-x1*(ymax-y0)) c = (xmin - b*(ymin-y0))/x1 a = -b*y0 endif c kstart = 1 delx = (xmax-xmin)/float(nbegns-1) psi1 = psi(xmin,a,b,c,ns,xs,alpha,beta) c c loop over nx values of xx evenly spaced from xmin to xmax c and find the corresponding values of x such that xx = psi(x). c dx = (xmax-xmin)/float(nx-1) do 50 i = 1,nx xx = xmin + (i-1)*dx c c use Newton's method to find x for f(x) = psi(x)-xx = 0: c f(x+delx) ~= f(x) + f'(x)*delx + f"(x)/2*delx**2 + ... c for f(x+delx)=0, delx = -f(x)/f'(x) c xj1 = xj - f(xj))/fp(xj); fp(x) = dpsi = d(psi(x))/d(x) c c first find psi1 and psi2 straddling xy such that c psi1.le.xx .and. xx.le.psi2 and iterate on x from there. c 20 psi2 = psi(xmin+kstart*delx,a,b,c,ns,xs,alpha,beta) if (psi2 .ge. xx) goto 30 if (kstart .lt. nbegns-1) then c if not, increase x. kstart = kstart + 1 psi1 = psi2 goto 20 endif c c interpolate between two values of psi to get a starting xj. c 30 xj1 = xmin + (kstart-1)*delx + (xx-psi1)*delx/(psi2-psi1) c c loop until abs((xj1-xj)/xj).le.eps or iter.eq.maxit c iter = 0 40 xj = xj1 f = psi(xj,a,b,c,ns,xs,alpha,beta) - xx fp = dpsi(xj,a,b,c,ns,xs,alpha,beta) xj1 = xj - f/fp iter = iter + 1 if(xj .ne. 0.) then if((abs((xj1-xj)/xj).gt.eps).and.(iter.lt.maxit)) goto 40 else if(abs(xj1) .gt. eps) goto 40 endif c store x location. x(i)=xj c store psi derivative: xp = d(psi)/d(x) xp(i) = fp c xpp = d^2(psi)/dx^2 xpp(i) = d2psi(xj,a,b,c,ns,xs,alpha,beta) 50 continue c ccc fix the ends: x(1) = xmin x(nx) = xmax ccc return c end of stretch. end c ------------------------------------------------------------------ real function d2psi(x,a,b,c,ns,xs,alpha,beta) c ------------------------------------------------------------------ c Second derivative of the stretching function. (Senya Basin) c d2x = b * sum { -alpha/beta^2 * (2e/(1+e^2)^2 } + 2*c; e = (x-xs)/beta implicit real(a-h,o-z),integer(i-n) dimension xs(1),alpha(1),beta(1) c sum = 0. do i = 1, ns binv = 1./beta(i) e = binv*(x - xs(i)) e2 = 1. + e*e sum = sum + alpha(i)*binv*binv*(e + e)/(e2 * e2) enddo d2psi = -b*sum + 2.*c return c end of function d2psi. end c ------------------------------------------------------------------ real function dpsi(x,a,b,c,ns,xs,alpha,beta) c ------------------------------------------------------------------ c derivative of the stretching function. c dimension xs(1),alpha(1),beta(1) c sum = 0. do 10 i=1,ns e = (x - xs(i))/beta(i) 10 sum = sum + (alpha(i)/beta(i)) * 1./(1.+ e*e) dpsi = b*(1. + sum) + 2.*c*x return c end of function dpsi. end c c ------------------------------------------------------------------ real function psi(x,a,b,c,ns,xs,alpha,beta) c ------------------------------------------------------------------ c coordinate stretching function. c dimension xs(1),alpha(1),beta(1) c sum = x do 10 i=1,ns 10 sum = sum + alpha(i)*atan((x-xs(i))/beta(i)) psi = a + b*sum + c*x*x return c end of function psi. end c subroutine wspace(parm,need) c ------------------------------------------------------------------ c write an error message about the required array space and exit. c c parm = (input) six-character name of the dimension parameter. c need = (input) needed value for the parameter parm, or zero. c = 0, then the needed value is not included in the message. c implicit real(a-h,o-z),integer(i-n) character*6 parm character*72 msg if(need.ne.0) then write(msg,1) parm,need 1 format('insufficient space, increase dimension parameter ', + a6,' to ',i6,'$') else write(msg,2) parm 2 format('insufficient space, increase dimension parameter ',a6, + '$') endif call perror1(msg,1) return c end of wspace. end c ------------------------------------------------------------------ subroutine perror1(msg,istop) c ------------------------------------------------------------------ c print the character string msg and exit the program if istop.ne.0 c c msg = (input) character string containing a message to be c printed. c istop = (input) stop flag c = 0, continue execution c = otherwise, exit the program c ioerr = (input) unit number for error messages. c character*(*) msg character*72 err common/errors/ioerr,nstep c c check if ioerr is reasonable. if not, write to unit 6. c if(ioerr.ge.1 .and. ioerr.le.99) then io = ioerr else io = 6 endif c if(nstep .gt. 0) then if(istop.eq.0) then write(io,1) nstep 1 format(1x,'warning on step ',i10) else write(io,2) nstep 2 format(1x,'error exit on step ',i10) endif endif if(len(msg) .gt. 0) then l = len(msg) iend = 0 do 10 i=1,72 if(msg(i:i) .eq. '$') iend = 1 if(i .gt. l .or. iend .eq. 1) then err(i:i) = ' ' else err(i:i) = msg(i:i) endif 10 continue write(io,11) err 11 format(1x,a72) endif c c close all open output data files and stop execution. c if(istop.ne.0) then call cstop stop endif return c end of perror. end c dyn_tios.f/ 839602929 1572 1572 100444 16244 ` #define c_str(s) ('s\0') c---------------------------------------------------------------------- subroutine init_data_out (tfile,dfile,nx,ny,npt,xx,yy,en) c---------------------------------------------------------------------- include 'comm_new.h' include 'comm_data.h' include 'comm_pbl.h' character*(*) tfile, dfile real en(1), xx(1), yy(1) real zz(100) integer tios_idvar common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /tios_id/ iddq, idri, idenm, ifoh ,idmosf, idtm save zz call tios_init (tfile, dfile) do i = 1, nz+1 zz(i) = real(i) enddo call tios_grid (id_g0, nxp, nyp, 1, xx, yy, zz) call tios_grid (id_g1, nxp, nyp, nz, xx, yy, zz) call tios_grid (id_g2, npten, 1, nz+1, zz, zz, zz) call tios_grid (id_g3, nxp, nyp, nz-1, xx, yy, zz) call tios_grid (id_g4, 1, nyp, nz+1, xx, yy, zz) call tios_map (imap, nxp*nyp, nxyc, iox) call tios_var (t, c_str(TEMP), id_g1, imap) call tios_var (u, c_str(U_VEL), id_g1, imap) call tios_var (v, c_str(V_VEL), id_g1, imap) call tios_var (w, c_str(W_VEL), id_g1, imap) call tios_var (fhd, c_str(DIV), id_g1, imap) if (use_salt) then call tios_var (sal, c_str(SALT), id_g1, imap) call tios_var (dens,c_str(DENS), id_g1, imap) endif call tios_var (pgfx, c_str(PGF_X), id_g1, imap) #ifdef dump_all call tios_var (rhsx, c_str(RHS_X), id_g1, imap) call tios_var (corx, c_str(COR_X), id_g1, imap) call tios_var (xnl, c_str(NONLIN_X), id_g1, imap) call tios_var (vertx, c_str(VERT_X), id_g1, imap) call tios_var (crhsx, c_str(CRHS_X), id_g1, imap) #endif call tios_var (pgfy, c_str(PGF_Y), id_g1, imap) #ifdef dump_all call tios_var (rhsy, c_str(RHS_Y), id_g1, imap) call tios_var (cory, c_str(COR_Y), id_g1, imap) call tios_var (ynl, c_str(NONLIN_Y), id_g1, imap) call tios_var (verty, c_str(VERT_Y), id_g1, imap) call tios_var (crhsy, c_str(CRHS_Y), id_g1, imap) #endif idenm = tios_idvar (c_str(D_MEAN), id_g1, imap) call tios_var (tm, c_str(T_MEAN), id_g1, imap) call tios_var (um, c_str(U_MEAN), id_g1, imap) call tios_var (vm, c_str(V_MEAN), id_g1, imap) call tios_var (wm, c_str(W_MEAN), id_g1, imap) if (use_salt) then call tios_var (salm, c_str(S_MEAN), id_g1, imap) call tios_var (densm, c_str(DENS_MEAN), id_g1, imap) endif iddq = tios_idvar(c_str(HFLX), id_g0, imap) call tios_var(qb(npt1), c_str(SOLAR), id_g0, imap) call tios_var(qb(npt2), c_str(LATENT), id_g0, imap) call tios_var(qb(npt3), c_str(SENSIBLE), id_g0, imap) call tios_var(qb(npt4), c_str(LONGWAVE), id_g0, imap) call tios_var(qb(npt4+nxyc), c_str(DEFICIT), id_g0, imap) call tios_var(cld(npt3), c_str(CLD), id_g0, imap) call tios_var(wnd, c_str(WNSP), id_g0, imap) call tios_var(wnd(npt2), c_str(UWND), id_g0, imap) call tios_var(wnd(npt3), c_str(VWND), id_g0, imap) call tios_var(sst(npt3), c_str(SST), id_g0, imap) if (use_salt) then call tios_var(ep, c_str(EP), id_g0, imap) call tios_var(sss(npt3), c_str(SSS), id_g0, imap) endif if (initq .eq. 8) then call tios_var(amhum, c_str(PBLHUM), id_g0, 0) call tios_var(amth, c_str(PBLPTEM), id_g0, 0) call tios_var(ahum(1,3), c_str(AIRHUM), id_g0, 0) call tios_var(atem(1,3), c_str(AIRTEM), id_g0, 0) endif call tios_var (convn, c_str(CONVN), id_g1, imap) call tios_var (en, c_str(ENRG), id_g2, 0) call tios_var (w((nz-1)*nxyc+1) , c_str(SEALEV), id_g0, imap) idri = tios_idvar (c_str(RI), id_g3, imap) ifoh = idvar_tios (c_str(FOH), id_g0, imap) call tios_var (dept, c_str(TOTAL_DEPTH), id_g0, imap) call tios_var (relax, c_str(RELAX), id_g0, imap) call tios_var (sponge, c_str(SPONGE), id_g0, imap) if (ibaro .ne. 0) then call tios_var (psi, c_str(PSI), id_g0, imap) call tios_var (ubar, c_str(U_BAR), id_g0, imap) call tios_var (vbar, c_str(V_BAR), id_g0, imap) endif call tios_var(taux, c_str(TAUX), id_g0, imap) call tios_var(tauy, c_str(TAUY), id_g0, imap) idtm = idvar_tios (c_str(DEPTH), id_g1, imap) idmosf = tios_idvar (c_str(W_MOSF), id_g4, 0) call tios_var (psiw, c_str(MOSF), id_g4, 0) call tios_read return end c-------------------------------------------------- subroutine data_out (tenso, nx, ny, npt, en) c-------------------------------------------------- include 'comm_new.h' include 'comm_data.h' include 'comm_pbl.h' real en(1) common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /tios_id/ iddq, idri, idenm, ifoh ,idmosf, idtm external h_to_z, comp_rich, out_mean, out_mosf, dept_to_foh, comp_q integer tios_putvar, tios_putidvar if (tios_putvar (t, tenso, 0) .eq. 1) then call zero_em(nz*nxyc, convn) endif call tios_putvar (pgfx, tenso, 0) call tios_putvar (pgfy, tenso, 0) c.....output mean MODEL variables: if ( tios_putidvar (idenm, tp, tenso, out_mean) .eq. 0 ) then call tios_putvar (tm, tenso, out_mean) endif call tios_putidvar (iddq, tp, tenso, comp_q) if (initq .eq. 8) then call tios_putvar (amhum, tenso, 0) endif call tios_putvar (en, tenso, 0) call tios_putvar (w((nz-1)*nxyc+1), tenso, 0) call tios_putidvar (idri, tp, tenso, comp_rich) call tios_putidvar (ifoh, tp, tenso, dept_to_foh) if (ibaro.ne.0) call tios_putvar (psi, tenso, 0) call tios_putidvar (idtm, tp, tenso, h_to_z) call tios_putidvar (idmosf, wint, tenso, out_mosf) call tios_save return end c------------------------------------------------------------ subroutine h_to_z c------------------------------------------------------------ include 'comm_data.h' include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc c c compute vertical coordinate x = sqrt(-1.) do i = 1, nxyc*nz tp(i) = x enddo do i = 1, nxyc z = h(i)/2. dz= h(i)/2. tp(i) = -z do k = 2, nzi(i) kn = (k-1)*nxyc ik = kn + i ikm = kn + i - nxyc dz = h(ikm) - dz z = z + 2.*dz tp(ik) = - z enddo enddo return end c------------------------------------------------------------ subroutine dept_to_foh c------------------------------------------------------------ include 'comm_data.h' include 'comm_para.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc c c compute f/H do i = 1, nxyc tp(i) = f(i)/dept(i) enddo return end c------------------------------------------------------------ subroutine comp_rich c------------------------------------------------------------ include 'comm_para.h' include 'comm_new.h' include 'comm_data.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc parameter (R_COEF = -0.5 * GRAVTY/1000.) parameter (DUZ_0 = 1.e-5) c c compute Ri & put it into tp(*) c Ri = -(g/rho0) * d(rho)/dz / (du/dz**2 + du/dz**2)c c if (use_salt) then do k = 1, nz-1 kn = (k-1)*nxyc do i = 1, nxyc ik = kn + i ikp = ik + nxyc uu = u(ik) - u(ikp) vv = v(ik) - v(ikp) du2 = uu*uu + vv*vv if (du2 .lt. DUZ_0) du2 = DUZ_0 tp(ik) = R_COEF * (h(ik) + h(ikp))*(dens(ik) - dens(ikp)) / du2 enddo enddo else coef = R_COEF * TCOEF do k = 1, nz-1 kn = (k-1)*nxyc do i = 1, nxyc ik = kn + i ikp = ik + nxyc uu = u(ik) - u(ikp) vv = v(ik) - v(ikp) du2 = uu*uu + vv*vv if (du2 .lt. DUZ_0) du2 = DUZ_0 tp(ik) = coef * (h(ik) + h(ikp))*(t(ikp) - t(ik)) / du2 enddo enddo endif return end subroutine add_mean_old c----------------------------- include 'comm_data.h' include 'comm_new.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /mean_comm/ nmcount nmcount = nmcount + 1 if (nmcount .eq. 1) then do i = 1, nz*nxyc um(i) = 0. vm(i) = 0. wm(i) = 0. tm(i) = 0. enddo if (use_salt) then do i = 1, nz*nxyc salm(i) = 0. densm(i) = 0. enddo endif endif do k = 1, nz ik0 = (k-1)*nxyc do i = ik0+1, ik0+nxyc um(i) = um(i) + u(i) vm(i) = vm(i) + v(i) wm(i) = wm(i) + w(i) tm(i) = tm(i) + t(i) enddo enddo if (use_salt) then do k = 1, nz ik0 = (k-1)*nxyc do i = ik0+1, ik0+nxyc salm(i) = salm(i) + sal(i) densm(i) = densm(i) + dens(i) enddo enddo endif return end subroutine out_mean c-------------------------- include 'comm_data.h' include 'comm_new.h' common /grid/ nxp, nyp, nxyc, nz, nbx,nby,ncs,land,nlo,npbc common /mean_comm/ nmcount coef = 1./real(nmcount) nmcount = 0 do i = 1, nz*nxyc um(i) = coef*um(i) vm(i) = coef*vm(i) wm(i) = coef*wm(i) hm(i) = coef*hm(i) tm(i) = coef*tm(i) enddo do i = 1, nxyc z = 0.5*hm(i) dh= z do k = 1, nzi(i) ik = i + (k-1)*nxyc tp(ik) = - z z = z + 2.*dh dh = hm(ik) - dh enddo enddo c do i = 1, nxyc c tp(i) = -0.5*hm(i) c enddo c do k = 2, nz c kn = (k-1)*nxyc c do i = 1, nxyc c ik = kn + i c ikm = ik - nxyc c tp(ik) = tp(ikm) - 0.5 * (hm(ikm) + hm(ik)) c enddo c enddo if (use_salt) then do i = 1, nz*nxyc salm(i) = coef*salm(i) densm(i) = coef*densm(i) enddo endif do i = 1, ntrac*nz*nxyc trm(i) = coef*trm(i) enddo return end subroutine out_mean_old c-------------------------- include 'comm_data.h' include 'comm_new.h' common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /mean_comm/ nmcount coef = 1./real(nmcount) nmcount = 0 do i = 1, nz*nxyc um(i) = coef*um(i) vm(i) = coef*vm(i) wm(i) = coef*wm(i) tm(i) = coef*tm(i) enddo if (use_salt) then do i = 1, nz*nxyc salm(i) = coef*salm(i) densm(i) = coef*densm(i) enddo endif return end c------------------------------------------------------------ subroutine out_mosf c------------------------------------------------------------ include 'comm_para.h' include 'comm_new.h' include 'comm_data.h' common /grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common /main/npt c for mean field meridional overturning streamfunction: call comp_mosf(nxp,nyp,nz,npt,mask,wm,psiw,emx,emy,wint,tp) c for instantaneous field meridional overturning streamfunction: c call comp_mosf(nxp,nyp,nz,npt,mask,w,psiw,emx,emy,wint,tp) return end c------------------------------------------------------------ subroutine comp_mosf(nx,ny,nz,npt,mask,w,psi,emx,emy,wint,tmp) c------------------------------------------------------------ c find the meridional overturning streamfunction include 'comm_para.h' include 'comm_new.h' dimension mask(nx*ny,nz),w(npt,nz) dimension emx(npt),emy(npt),wint(ny,nz) dimension tmp(ny,2),psi(ny,nz+1) parameter (REARTH = 6378000., RAD = 3.14159265/180.) jmax=0 jmin=ny do j = 1, ny do i = 1, nx ij = (j-1)*nx + i ii = mask(ij,1) if (ii.gt.0) then tmp(j,1) = emy(ii) jmax = max(jmax,j) jmin = min(jmin,j) endif enddo enddo do j = 1, ny tmp(j,2) = 0 enddo do j = 1, ny do i = 1, nx ij = (j-1)*nx + i do k = 1, nz ii = mask(ij,k) if (ii.gt.0) then tmp(j,2) = max(k,tmp(j,2)) endif enddo enddo enddo c compute wint = zonal integral of w call zonal_int(1,nx,ny,nz-1,npt,mask,w,wint,emx) rnan = sqrt(-1.) do j = 1, ny do k = 1, nz+1 psi(j,k) = rnan enddo enddo do j = jmin, jmax psi(j,1) = 0. psi(j,tmp(j,2)+1) = 0. enddo do k = 1, tmp(jmin,2) psi(jmin,k) = 0. enddo do k = 1, tmp(jmax,2) psi(jmax,k) = 0. enddo c compute psi from integrating wint in y do j = jmin + 1, jmax - 1 do k = 2, tmp(j,2) dy = (1./tmp(j,1) + 1./tmp(j-1,1))/2. psi(j,k)=psi(j-1,k) + dy*(wint(j,k)+wint(j-1,k))/2. enddo enddo return end c------------------------------------------------------------ subroutine zonal_int(iflag, nx,ny,nz,npt,mask,f,fint,emx) c------------------------------------------------------------ dimension mask(nx*ny,nz),f(npt,nz),fint(ny,nz),emx(npt) do j = 1, ny do k = 1, nz + iflag fint(j,k) = 0. enddo enddo do j = 1, ny do i = 1, nx ij = (j-1)*nx + i do k = 1, nz ii = mask(ij,1) if (mask(ij,k).gt.0) then fint(j,k+iflag) = fint(j,k+iflag) + f(ii,k)/emx(ii) endif enddo enddo enddo return end subroutine add_mean c----------------------------- include 'comm_data.h' include 'comm_new.h' common /grid/ nxp, nyp, nxyc, nz, nbx,nby,ncs,land,nlo,npbc common /mean_comm/ nmcount nmcount = nmcount + 1 if (nmcount .eq. 1) then do i = 1, nz*nxyc um(i) = 0. vm(i) = 0. wm(i) = 0. hm(i) = 0. tm(i) = 0. enddo if (use_salt) then do i = 1, nz*nxyc salm(i) = 0. densm(i) = 0. enddo endif do i = 1, nz*nxyc*ntrac trm(i) = 0. enddo endif do k = 1, nz ik0 = (k-1)*nxyc do i = ik0+1, ik0+nxyc um(i) = um(i) + u(i) vm(i) = vm(i) + v(i) hm(i) = hm(i) + h(i) wm(i) = wm(i) + w(i) tm(i) = tm(i) + t(i) enddo enddo if (use_salt) then do k = 1, nz ik0 = (k-1)*nxyc do i = ik0+1, ik0+nxyc salm(i) = salm(i) + sal(i) densm(i) = densm(i) + dens(i) enddo enddo endif do n = 1, ntrac in0 = (n-1)*nz*nxyc do k = 1, nz ik0 = in0 + (k-1)*nxyc do i = ik0+1, ik0+nxyc trm(i) = trm(i) + tr(i) enddo enddo enddo return end c------------------------------------------------------------ subroutine comp_q c------------------------------------------------------------ include 'comm_new.h' include 'comm_data.h' common /grid/ nxp, nyp, nxyc, nz, nbx,nby,ncs,land,nlo do i = 1, nxyc tp(i) = QCON * (q(i) + qr(i)) enddo return end dyn_topo.f/ 839946116 1572 1572 100444 15844 ` subroutine new_topo (nxp,nyp,nz,npt,zin,dzin,hin,nsig,sigma,dept,h,nptk,nzi) dimension zin(nz+1),dzin(nz+1),dept(npt),nptk(nz),h(npt,nz) * ,nzi(npt),hin(nz),sigma(nz) include 'comm_new.h' do k = 1, nz do i = 1, npt c h(i,k) = -98765432. h(i,k) = 0. enddo enddo do i = 1, npt dep = dept(i) n = 1 do k = 2, nz if (dep.lt.zin(k)) goto 10 n = k enddo 10 nzi(i) = n enddo if (initbt.eq.0) then do i = 1, npt mz = nzi(i) do k = 1, mz h(i,k) = dzin(k+1) + dzin(k) enddo enddo elseif (initbt.eq.3) then mmz = 0 do i = 1, npt mmz = max(nzi(i),mmz) enddo do i = 1, npt mz = nzi(i) do k = 1, mz - 1 h(i,k) = dzin(k+1) + dzin(k) enddo if (mz.eq.mmz) then h(i,mz) = dzin(mz) + (dept(i)-zin(mz)) else h(i,mz) = dzin(mz+1) + dzin(mz) endif enddo else do i = 1, npt dep = dept(i) mz = nzi(i) do k = 1, mz - 1 h(i,k) = dzin(k+1) + dzin(k) enddo h(i,mz) = dzin(mz) + (dep-zin(mz)) enddo endif return end c --------------------------------------------------------------------- subroutine data_init (npt,nptk,nz,isk,u,v,uc,vc,fu,fv,ft,fsal,bdiv,ubar,vbar,use_salt) c --------------------------------------------------------------------- dimension nptk(nz),isk(npt,nz),bdiv(npt),ubar(npt),vbar(npt), * u(npt,nz),v(npt,nz),uc(npt,nz),vc(npt,nz), * fu(npt,nz), fv(npt,nz), ft(npt,nz), fsal(npt,nz) logical use_salt do i = 1, npt bdiv(i) = 0. ubar(i) = 0. vbar(i) = 0. enddo do k = 1, nz do j = 1, nptk(k) i = isk(j,k) u(i,k) = 0. v(i,k) = 0. uc(i,k) = 0. vc(i,k) = 0. fu(i,k) = 0. fv(i,k) = 0. ft(i,k) = 0. enddo enddo if (.not.use_salt) return do k = 1, nz do j = 1, nptk(k) i = isk(j,k) fsal(i,k) = 0. enddo enddo return end c --------------------------------------------------------------------- subroutine dfdxk (f,df,npt,npk,nbu,nbx,nby,ncs,lxx,lyx,snx * ,npbc,lpbcw,lpbce,isk) c --------------------------------------------------------------------- c............ a version with Periodic B.C. (Senya Basin) implicit real(a-h,o-z),integer(i-n) dimension f(npt),df(npt),snx(nbx),lxx(nbx+ncs,4), lyx(nby) dimension lpbcw(npbc), lpbce(npbc),isk(npk) c compute centered first derivative for entire grid. #ifdef fourth_order do i = 3, npk - 2 j = isk(i) df(j) = (8.*(f(j+1)-f(j-1)) - (f(j+2)-f(j-2)))/12. enddo #else !second_order do i = 2, npk - 1 j = isk(i) df(j) = (f(j+1)-f(j-1))/2. enddo #endif c....................... periodic B.C. do i = 1, npbc i2 = lpbce(i) f4 = f(i2) f3 = f(i2-1) f2 = f(i2-2) f1 = f(i2-3) i1 = lpbcw(i) f5 = f(i1) f6 = f(i1+1) f7 = f(i1+2) f8 = f(i1+3) #ifdef fourth_order df(i1) = (8.*(f6 - f4) - (f7 - f3))/12. df(i1+1) = (8.*(f7 - f5) - (f8 - f4))/12. df(i2) = (8.*(f5 - f3) - (f6 - f2))/12. df(i2-1) = (8.*(f4 - f2) - (f5 - f1))/12. #else !second_order df(i1) = (f6 - f4)/2. df(i1+1) = (f7 - f5)/2. df(i2) = (f5 - f3)/2. df(i2-1) = (f4 - f2)/2. #endif enddo nb = nbx if (nbu .eq. -1 .or. nbu .eq. 2) then do i = 1, nb i1 = lxx(i,1) i2 = lxx(i,2) f1 = f(i1) f2 = f(i2) f3 = f(lxx(i,3)) f4 = f(lxx(i,4)) df(i1) = 0. #ifdef fourth_order df(i2) = snx(i)*( 2.*(f2-f1) + 5.*(f3-f2) - (f4-f3))/6. #endif enddo else do i = 1, nb i1 = lxx(i,1) i2 = lxx(i,2) f1 = f(i1) f2 = f(i2) f3 = f(lxx(i,3)) f4 = f(lxx(i,4)) #ifdef fourth_order df(i1) = snx(i)*(11.*(f2-f1) + 7.*(f2 - f3) + 2.*(f4-f3))/6. df(i2) = snx(i)*( 2.*(f2-f1) + 5.*(f3-f2) - (f4-f3))/6. #else df(i1) = snx(i)*(3.*(f2 - f1) + (f2 - f3))/2. #endif enddo endif if (nbu .eq. -1 .or. nbu.eq.1) then c..................set the derivative along the boundary equal to zero. do i = 1, nby df(lyx(i)) = 0. enddo endif return c end of dfdxk. end c ------------------------------------------------------------------ subroutine dfdyk(f,df,npt,npk,nbv,nby,nbx,ncs,lyy,lxy,sny,isy) c ------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) dimension f(npt),df(npt),sny(nby),lyy(nby+ncs,4),lxy(nbx) * ,isy(npk) c note, isy: k-y-comp -> x-comp, c lyy: k-y-comp-bound -> x-comp , etc. c #ifdef fourth_order do i = 3, npk-2 j = isy(i) df(j)=(8.*(f(isy(i+1))-f(isy(i-1))) - (f(isy(i+2))-f(isy(i-2))))/12. enddo #else !second_order do i = 2, npk-1 j = isy(i) df(j)=(f(isy(i+1))-f(isy(i-1)))/2. enddo #endif nb = nby if (nbv.eq.-1 .or. nbv.eq.2) then do i = 1, nb i1 = lyy(i,1) i2 = lyy(i,2) f1 = f(i1) f2 = f(i2) f3 = f(lyy(i,3)) f4 = f(lyy(i,4)) df(i1) = 0. #ifdef fourth_order df(i2) = sny(i)*(2.*(f2-f1) + 5.*(f3-f2) - (f4-f3))/6. #endif enddo else do i = 1, nb i1 = lyy(i,1) i2 = lyy(i,2) f1 = f(i1) f2 = f(i2) f3 = f(lyy(i,3)) f4 = f(lyy(i,4)) #ifdef fourth_order df(i1) = sny(i)*(11.*(f2-f1) + 7.*(f2-f3) + 2.*(f4-f3))/6. df(i2) = sny(i)*( 2.*(f2-f1) + 5.*(f3-f2) - (f4-f3))/6. #else !second_order df(i1) = sny(i)*(3.*(f2-f1) + (f2-f3))/2. #endif enddo endif if(nbv.eq.-1 .or. nbv.eq.1) then c.....................set the derivative along the x boundary equal to zero. do i = 1, nbx df(lxy(i)) = 0. enddo endif return c end of dfdyk. end c --------------------------------------------------------------------- subroutine dfdx1 (f,df,npt,nbu,nbx,nby,ncs,lxx,lyx,snx * ,npbc,lpbcw,lpbce) c --------------------------------------------------------------------- c............ a version with Periodic B.C. (Senya Basin) implicit real(a-h,o-z),integer(i-n) dimension f(npt),df(npt),snx(nbx),lxx(nbx+ncs,4), lyx(nby) dimension lpbcw(npbc), lpbce(npbc) c compute fourth order centered first derivative for entire grid. #ifdef fourth_order do j = 3, npt - 2 df(j) = (8.*(f(j+1)-f(j-1)) - (f(j+2)-f(j-2)))/12. enddo #else !second_order do j = 2, npt - 1 df(j) = (f(j+1)-f(j-1))/2. enddo #endif c....................... periodic B.C. do i = 1, npbc i2 = lpbce(i) f4 = f(i2) f3 = f(i2-1) f2 = f(i2-2) f1 = f(i2-3) i1 = lpbcw(i) f5 = f(i1) f6 = f(i1+1) f7 = f(i1+2) f8 = f(i1+3) #ifdef fourth_order df(i1) = (8.*(f6 - f4) - (f7 - f3))/12. df(i1+1) = (8.*(f7 - f5) - (f8 - f4))/12. df(i2) = (8.*(f5 - f3) - (f6 - f2))/12. df(i2-1) = (8.*(f4 - f2) - (f5 - f1))/12. #else !second_order df(i1) = (f6 - f4)/2. df(i1+1) = (f7 - f5)/2. df(i2) = (f5 - f3)/2. df(i2-1) = (f4 - f2)/2. #endif enddo do i = 1, nbx i1 = lxx(i,1) i2 = lxx(i,2) f1 = f(i1) f2 = f(i2) f3 = f(lxx(i,3)) f4 = f(lxx(i,4)) #ifdef fourth_order df(i1) = snx(i)*(3.*(f2-f1) + (f2-f3))/2. c df(i1) = snx(i)*(11.*(f2-f1) + 7.*(f2 - f3) + 2.*(f4-f3))/6. df(i2) = snx(i)*(2.*(f2-f1) + 5.*(f3-f2) + (f3-f4))/6. #else df(i1) = snx(i)*(f2 - f1) #endif enddo if (nbu.eq.1) then c..................set the derivative along the boundary equal to zero. do i = 1, nby df(lyx(i)) = 0. enddo endif return end c ------------------------------------------------------------------ subroutine dfdy1(f,df,npt,nbv,nby,nbx,ncs,lyy,lxy,sny,isy) c ------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) dimension f(npt),df(npt),sny(nby),lyy(nby+ncs,4),lxy(nbx) * ,isy(npt) c note, isy: k-y-comp -> x-comp, c lyy: k-y-comp-bound -> x-comp , etc. c #ifdef fourth_order do i = 3, npt-2 j = isy(i) df(j)=(8.*(f(isy(i+1))-f(isy(i-1))) - (f(isy(i+2))-f(isy(i-2))))/12. enddo #else !second_order do i = 2, npt-1 j = isy(i) df(j)=(f(isy(i+1))-f(isy(i-1)))/2. enddo #endif do i = 1, nby i1 = lyy(i,1) i2 = lyy(i,2) f1 = f(i1) f2 = f(i2) f3 = f(lyy(i,3)) f4 = f(lyy(i,4)) #ifdef fourth_order df(i1) = sny(i)*(3.*(f2-f1) + (f2-f3))/2. c df(i1) = sny(i)*(11.*(f2-f1) + 7.*(f2-f3) + 2.*(f4-f3))/6. df(i2) = sny(i)*(2.*(f2-f1) + 5.*(f3-f2) + (f3-f4))/6. #else df(i1) = sny(i)*(f2 - f1) #endif enddo if(nbv.eq.1) then c.....................set the derivative along the x boundary equal to zero. do i = 1, nbx df(lxy(i)) = 0. enddo endif return c end of dfdy1. end subroutine baro_dept(npt,nz,nzi,nzi_b,h,lxxk,lyyk,mbc,dept,nz_x,nz_y) c --------------------------------------------------------------------- c...... requires no-slip boundary condition c...... if point is an x or y boundary point on the k-th grid, but not c...... the first grid, then it must be treated differently in baro_shap c...... and baro_updat in order to satisfy boundary conditions implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' dimension h(npt,nz),dept(npt), * lxxk(MXBDY,nz),lyyk(MXBDY,nz),nzi(npt),nzi_b(npt) * ,nz_x(npt),nz_y(npt) common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) do i = 1, npt nz_x(i) = nzi(i) nz_y(i) = nzi(i) enddo c find x-direction restrictions on depth do k = nz, 2, -1 do j = 1, nbxk(k) i = lxxk(j,k) nz_x(i) = k-1 enddo enddo k = 1 do j = 1, nbxk(k) i = lxxk(j,k) nz_x(i) = nzi(i) enddo do i = 1, npt nzi_b(i) = nz_x(i) enddo #ifdef fourth_order do k = nz, 2, -1 nxck = nbxk(k) + ncsk(k) do i = 1, nbxk(k) j = lxxk(i+nxck,k) nz_x(j) = k-1 enddo enddo k = 1 nxck = nbxk(k) + ncsk(k) do i = 1, nbxk(k) j = lxxk(i+nxck,k) nz_x(j) = nzi_b(j) enddo #endif c find y-direction restrictions on depth do k = nz, 2, -1 do j = 1, nbyk(k) i = lyyk(j,k) nz_y(i) = k-1 enddo enddo k = 1 do j = 1, nbyk(k) i = lyyk(j,k) nz_y(i) = nzi(i) enddo do i = 1, npt nzi_b(i) = nz_y(i) enddo #ifdef fourth_order do k = nz, 2, -1 nyck = nbyk(k) + ncsk(k) do i = 1, nbyk(k) j = lyyk(i+nyck,k) nz_y(j) = k-1 enddo enddo k = 1 nyck = nbyk(k) + ncsk(k) do i = 1, nbyk(k) j = lyyk(i+nyck,k) nz_y(j) = nzi_b(j) enddo #endif do i = 1, npt nzi_b(i) = min(nz_x(i),nz_y(i)) enddo do i = 1, npt dept(i) = h(i,1) do k = 2, nzi_b(i) dept(i) = dept(i) + h(i,k) enddo enddo return end subroutine baro_shap (nstep,npt,nz,nzi,nzi_b,dept,h,uc,vc,ubar,vbar,u,v, * lxxk,lyyk) c--------------------------------------------------------------------------- c This subroutine is responsible for preserving the rigid lid c assumption. It must be called immediately before ddiv to c work properly c Note that in the non-constant depth scenario, we need c div(sum(uc_k)) = sum(div(uc_k)). c - We need the same divergence operators on both sides. c We accomplish this by using the k=1 divergence operator c on all levels, assuming uc(i,k)=0 at all 'mud' (non-ocean) points. c - In order for the divergence and summation (over k) operators c to commute, we need also need the summation to be independent of c horizontal position, hence the sum must be over all 'nz' levels c but no normal vertical flow through the bottom requires that c div(uc_k) = 0 at all 'mud' points. c Thus we have two constraints while computing divergences in ddiv: c uc_k=0 and div(uc_k)=0 at mud points c NOTE: A distinction is made between 'mud' points and 'land' c points. A 'mud' point is by definitions a point which is c not water on some level k>1, but is water on the k=1 level. c These 'fixes' are not done on the land points, only mud points. c Zero mudpoint transport (uc_k = 0) is done in ddiv. c Zero mudpoint divergence (div(uc_k) = 0) is accomplished by c enforcing the normal component of velocity to be zero at c one(two) grid point(s) adjacent to land in the case of c second(fourth) order approximations to the derivatives. This c is done here and in bcset, but in order for the total transport to c remain fixed, we must redistribute the zero-ed out barotropic c transport in this routine. The redistribution of ubar(vbar) is c determined by nzi_b. This restores the correct barotropic transport c (which was spoiled by bcset and the shapiro filter). c----NHN:Dec.21,95 implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' dimension h(npt,nz),uc(npt,nz),vc(npt,nz),ubar(npt),vbar(npt) dimension u(npt,nz),v(npt,nz) dimension dept(npt),nzi(npt),nzi_b(npt) dimension lxxk(MXBDY,nz), lyyk(MXBDY,nz) common/shapi/nord,nshapu,nshaph,nshapt,mshapu,mshaph,mshapt common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) do i = 1, npt do k = 1, nzi_b(i) hi = h(i,k) uc(i,k) = u(i,k)*hi vc(i,k) = v(i,k)*hi enddo enddo do i = 1, npt do k = nzi_b(i)+1, nzi(i) uc(i,k) = 0. vc(i,k) = 0. enddo enddo call baro_sum (npt, nz, nzi_b, uc, vc, u, v) call baro_scale (npt, u, v, dept) do i = 1, npt do k = 1, nzi_b(i) uc(i,k) = uc(i,k) + h(i,k)*(ubar(i) - u(i,1)) enddo do k = 1, nzi_b(i) vc(i,k) = vc(i,k) + h(i,k)*(vbar(i) - v(i,1)) enddo enddo call decap (npt, nz, nzi, u,v,uc,vc,h) return end dyn_xir.f/ 839513370 1572 1572 100444 31937 ` c*********************************************************************** c c routines for irregular geometry. c c*********************************************************************** c ------------------------------------------------------------------ subroutine bndrys(npt,iox,ioy,isxk,isyk,mask,h,nzi, * ixk,iyk,lxxk,lyyk,lxyk,lyxk,snxk,snyk,lok, * lpbcwk,lpbcek,ifxk,ifpxk,ifyk,dept) c ------------------------------------------------------------------ c finds the indices of the land-ocean boundary grid points. c c from the common block grid: c nxp,nyp = (input) # of grid points in the x and y directions. c nxyc = (input) # of ocean grid points. c mxbdy = (input) maximum storage space for each array lxx, lyy. c maxnb = (input) max storage space for each array lxy, lyx, snx, sny. c iox = (output) nxyc indices of the x-sorted ocean grid points. c ioy = (output) nxyc indices of the ocean points for a y-sort. c isx = (output) nxyc indices to gather data to the compressed c x-sort from the compressed y-sort. c isy = nxyc indices to gather data to the compressed y-sort c from the compressed x-sort. c lxx = MINSEG*(nbx+ncs) indices of points on and next to x-bndrys c for the compressed x-sort. c lyy = MINSEG*(nby+ncs) x-sort indices of points on and next c to y-bndrys for the compressed y-sort. c lxy = nbx+ncs indices of x-boundary points for the compressed c y-sort. c lyx = nby+ncs indices of y-boundary points for the compressed c x-sort. c c snx = (output) nbx+ncs signs (+1. or -1.) associated with the c x-boundary indices in lxx. if snx(i)=1., then the ocean c grid point with index lxx(i) is to the east (pos. x-dir.) c of the adjacent land point. if snx(i)=-1., c then the ocean pt. lxx(i) is to the west (neg. x-dir) of c the adjacent land grid point. c sny = (output) nby+ncs signs (+1. or -1.) associated with the c y-boundary indices in lyy in the same since as snx and lxx. c nbx = (output) # of x-boundary grid points. c nby = (output) # of y-boundary grid points. c ncs = (output) # of interior corner boundary grid points. c c ***************************************************************** c a few words about the different data sorts and bndry indices: c c the boundary grid points are the ocean grid points which are c adjacent to one or more land grid points. an ocean point is an c x-boundary point if the adjacent land point is in the pos. or neg. c x-direction, and an ocean point is a y-boundary pt if the adjacent c land point is in the pos. or neg. y-direction. thus a point c can be both an x-boundary and a y-boundary point. there are nbx c and nby x and y boundary points, respectively. a special case is c an ocean point which is neither an x nor a y boundary point, c but is adjacent to a land point in a diagonal direction. these are c referred to as interior corner boundary points (there are always c some on a peninsula). there are ncs ocean points of this type. c c assume that a data field is stored in the matrix u(i,j) whose c first dimension has been declared as nxp elements. the index i c corresponds to increasing x, and j corresponds to increasing y. in c fortran, the elements of u are stored sequentially with the index c i increasing before j, ie. u(1,1),u(2,1),...,u(nxp,1),u(1,2),... c this is the x or regular x-sort. the y or regular y-sort is simply c a sequential storage of u with the j index increasing before i, c u(1,1),u(1,2),...,u(1,nyp),u(2,1),u(2,2),.... the compressed c x-sort is the regular x-sort, excluding land points. the elements c representing ocean points are simply shifted towards u(1,1) to c fill the gaps left by the land elements, so that all ocean points c are stored consecutively. similarly, the compressed y-sort is the c regular y-sort, excluding land points. c for each type of sort the data u can obviously be identified by c a single index, say k. if k is simply the sequential position of c the element as it is stored, then for the regular sorts, k can be c expressed in terms of the original indices i and j: c k = i + (j-1)*nxp regular x-sort c k = j + (i-1)*nyp regular y-sort c the indices iox are the k-indices of the ocean pts for an x-sort c and the indices ioy are the k-indices of the ocean pts for a c regular y-sort. some relations between sorts and indices are: c uxc(i) = ux(iox(i)) compressed x-sort from regular x-sort c uyc(i) = uy(ioy(i)) compressed y-sort from regular y-sort c uyc(i) = uxc(isy(i)) compressed y-sort from compressed x-sort, c where isy is a columnwise ordering of the c compressed x-sort indices c uxc(i) = uyc(isx(i)) compressed x-sort from compressed y-sort, c where isx is a rowwise ordering of the c compressed y-sort indices c isx(isy(k)) = k, and isy(isx(k)) = k c c the k-index for the regular x-sort can be expressed in terms c of the k-index for the regular y-sort, and vice versa. so the c indices of ocean grid points in the two sorts are related as: c ioy(i) = ((iox(i)-1)/nxp)*(1-nxp*nyp) + (iox(i)-1)*nyp + 1 c and c iox(i) = ((ioy(i)-1)/nyp)*(1-nxp*nyp) + (ioy(i)-1)*nxp + 1 c c (the divisions must operate on integers) c c ***************************************************************** implicit real(a-h,o-z),integer(i-n) c include 'comm_para.h' dimension isx(1),isy(1),iox(1),ioy(1),h(1) dimension ixk(npt,nz),iyk(npt,nz),isxk(npt,nz),isyk(npt,nz), + lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz), + snxk(MAXNB,nz),snyk(MAXNB,nz), mask(nxp*nyp,nz), dept(npt), + ifxk(9*MAXSID,nz),ifpxk(5*MAXSID,nz),ifyk(9*MAXSID,nz), + lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz),lok(4*MAXSID,nz),nzi(npt) common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) common /new_filt/ MAXFO, nxk, nyk, nfx, nfpx, nfy c if (MINSEG.le.0 .or. nxp.le.0 .or. nyp.le.0) return nptk(1) = npt c.....iox and mask have already been created for top level, here we c.....initialize mask for rest of levels call maskk (npt,nxp,nyp,nz,nzi,iox,mask) c.....get the nbx x-bndry and the nby y-bndry indices call bndxy (npt,iox,ioy,lxxk,lyyk,lxyk,lyxk,snxk,snyk, * isxk,isyk,lpbcwk,lpbcek,mask,nzi,h,ixk,iyk,lok,dept) c.....compute indices for shapiro filters do k = 1, nz call shap_indx (nptk(k),nxp,nyp,mask(1,k),isxk(1,k), * nfxk(k),nfpxk(k),nfyk(k),ifxk(1,k),ifpxk(1,k),ifyk(1,k)) enddo c.....find the ncs interior-corner indices for the compressed x-sort. c.....store them at the end of lxx, and store the signs in snx. do k = 1, nz ncx = nbxk(k) ncy = nbyk(k) call newcorn (nxp,nyp,ncsk(k),lxxk(ncx+1,k),snxk(ncx+1,k), * lyyk(ncy+1,k),snyk(ncy+1,k),mask(1,k),isxk(1,k)) enddo need = MINSEG*(max0(nbx,nby)+ncs) if (need .gt. MXBDY) call wspace('MXBDY', need) c.....store copies of the corner indices for both sorts in lyx and lxy. do k = 1, nz ncx = nbxk(k) ncy = nbyk(k) do i = 1, ncsk(k) lyxk(ncy+i,k) = lxxk(ncx+i,k) lxyk(ncx+i,k) = lyyk(ncy+i,k) enddo enddo c do k = 1, nz nc = ncsk(k) ncx = nbxk(k) ncy = nbyk(k) nbxc = ncx + nc nbyc = ncy + nc do m = 1, MINSEG - 1 do i = 1, ncx lxxk(m*nbxc+i,k) = lxxk(i,k) + isign(m, int(snxk(i,k))) enddo do i = 1, ncy lyyk(m*nbyc+i,k) = lyyk(i,k) + isign(m, int(snyk(i,k))) enddo enddo do i = 1, nc lxxk(nbxc+i+ncx,k) = lxxk(i+ncx,k) + isign(1, int(snxk(i+ncx,k))) lyyk(nbyc+i+ncy,k) = lyyk(i+ncy,k) + isign(1, int(snyk(i+ncy,k))) enddo enddo c now combine a few of the mappings: do k = 1, nz npk = nptk(k) do i = 1, npk if (isyk(i,k).lt.1.or.isyk(i,k).gt.npt) print*,'trouble',i,k isyk(i,k) = ixk(isyk(i,k),k) enddo nbyck = nbyk(k) + ncsk(k) nbxck = nbxk(k) + ncsk(k) do i = 1, MINSEG*nbyck ly = lyyk(i,k) if (ly.le.npk.and.ly.ge.1) lyyk(i,k) = isyk(ly,k) enddo do i = 1, nbxck ly = lxyk(i,k) if (ly.le.npk.and.ly.ge.1) lxyk(i,k) = isyk(ly,k) enddo do i = 1, MINSEG*nbxck ly = lxxk(i,k) if (ly.le.npk.and.ly.ge.1) lxxk(i,k) = ixk(ly,k) enddo do i = 1, nbyck ly = lyxk(i,k) if (ly.le.npk.and.ly.ge.1) lyxk(i,k) = ixk(ly,k) enddo do i = 1, npbck(k) ly = lpbcek(i,k) if (ly.le.npk.and.ly.ge.1) lpbcek(i,k) = ixk(ly,k) ly = lpbcwk(i,k) if (ly.le.npk.and.ly.ge.1) lpbcwk(i,k) = ixk(ly,k) enddo do i = 1, nlok(k) ly = lok(i,k) if (ly.le.npk.and.ly.ge.1) lok(i,k) = ixk(ly,k) enddo enddo return c end of bndrys. end c------------------------------------------------------------------ subroutine bndxy(npt,iox,ioy,lxx,lyy,lxy,lyx,snx,sny, + isxk,isyk, lpbcw, lpbce, mask, nzi,h,ixk, iyk, lok, dept) c------------------------------------------------------------------ c Get the compressed x-sort boundary indices. c iox = (input) nxyc indices of the ocean points for the x-sort. c maxnb = (input) max. storage space for lxx, lyy, lxy, or lyx. c = default maximum allowable value for max0(nbx,nby). c minseg = (input) required minimum # of consecutive ocean points c interior to and including each boundary point. c lxx = (output) x-bndry indices for the compressed x-sort. c lyy = (output) y-bndry indices for the compressed y-sort. c lxy = (output) x-bndry indices for the compressed y-sort. c lyx = (output) y-bndry indices for the compressed x-sort. c snx = (output) nbx signs for the x-boundaries. c sny = (output) nby signs for the y-boundaries. c ioy = (output) nxyc indices of the ocean points for the y-sort. c isx = (output) nxyc indices to gather the compressed x-sort c from the compressed y-sort. c isy = (output) nxyc indices to gather the compressed y-sort c from the compressed x-sort. c implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' include 'comm_para.h' dimension iox(1),ioy(1),isxk(npt,nz),isyk(npt,nz), + lxx(MXBDY,nz),lyy(MXBDY,nz),lxy(MAXNB,nz),lyx(MAXNB,nz), + snx(MAXNB,nz),sny(MAXNB,nz), mask(nxp*nyp,nz), nzi(npt), + h(1),lpbcw(MAXSID,nz),lpbce(MAXSID,nz),lok(4*MAXSID,nz), + ixk(npt,nz),iyk(npt,nz), dept(npt) common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ) + ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ) c.....convert the x-sort indices in iox to y-sort indices ioy. nxy1 = 1-nxp*nyp c c.....convert cumulation location of ocean points from rowwise to c.....colomnwise. do i=1,nxyc ioy(i) = ((iox(i)-1)/nxp)*nxy1 + (iox(i)-1)*nyp + 1 enddo c sort by increasing value so that ioy(1) is the bottom of the c first ocean column and not the beginning of the first ocean c row. the sort order is isy. call sorti(nxyc,ioy,1,isyk) c form isxk from isyk, i.e. find the rowwise ordering of the c compressed y-sort indices. do i=1,nxyc isxk(isyk(i,1),1) = i enddo c.....find x-bndry indices for the compressed x-sort. do i=1,nxyc ixk(i,1) = i iyk(i,1) = i enddo if (iglob .eq. 0) then call bound(nxyc,iox,ixk,nxp,maxnb,minseg,nbxk,lxx,snx) else call set_pbc (nxp,nyp, npbck, lpbcw, lpbce, mask) call set_bpx (nxp,nyp,mask,maxnb,minseg,nbxk,lxx,snx) endif call reset_mask (nxyc,nxp,nyp,nz,nzi,h,mask,MINSEG,nptk, * ixk,iyk,isxk,isyk,dept) do k = 2, nz do i=1,nptk(k) isxk(isyk(i,k),k) = i enddo enddo call make_lok(npt,nxp,nyp,nz,iox,mask,nlok,lok) do k = 2, nz npbck(k) = 0 if (iglob .eq. 0) then call bound(nptk(k),iox,ixk(1,k),nxp,maxnb,minseg, * nbxk(k),lxx(1,k),snx(1,k)) else call set_pbck (nxp,nyp,npbck(k),lpbcw(1,k),lpbce(1,k), * mask(1,k)) call set_bpxk (nxp,nyp,mask(1,k),nbxk(k),lxx(1,k),snx(1,k)) endif enddo do k = 1, nz c.....find y-bndry indices for the compressed y-sort. call bound(nptk(k),ioy,iyk(1,k),nyp,maxnb,minseg, * nbyk(k),lyy(1,k),sny(1,k)) c find the y-bndry indices for the compressed x-sort using the c columnwise ordering of the compressed x-sort. do i=1,nbyk(k) lyx(i,k) = isyk(lyy(i,k),k) enddo c sort in sequential order. call sorti(nbyk(k),lyx(1,k),0) enddo c find the x-bndry indices for the compressed y-sort using the c rowwise ordering of the compressed x-sort. do k = 1, nz do i=1,nbxk(k) lxy(i,k) = isxk(lxx(i,k),k) enddo call sorti(nbxk(k),lxy(1,k),0) enddo return c end of bndxy. end c c ------------------------------------------------------------------ subroutine bound(npk,ioc,ixk,nsid,maxnb,minseg,nb,lbn,sgn) c ------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) character*72 msg dimension ioc(1),lbn(1),sgn(1),ixk(1) c if (npk.eq.0) then nb = 0 return endif nb = 1 lbn(1) = 1 sgn(1) = 1. c c cycle through all ocean points and note the location of all c nonconsecutive indices and points at the absolute extreme of c the rectangular grid. c do 10 i=2,npk ii = ixk(i) im = ixk(i-1) if(ioc(ii)-ioc(im).gt.1 .or. mod(ioc(ii)-1,nsid).eq.0) then if(nb+3 .gt. maxnb) goto 20 c c store location and set sign for the previous end of row c or top of column. c nb = nb + 1 lbn(nb) = i - 1 sgn(nb) = -1. c c make sure the boundary geometry will permit a 4th order c differencing. c if(lbn(nb)-lbn(nb-1)+1 .lt. minseg) goto 30 c c store location and set sign for the start of row or bottom c of column. c nb = nb + 1 lbn(nb) = i sgn(nb) = 1. endif 10 continue c c register last point. c nb = nb + 1 lbn(nb) = npk sgn(nb) = -1. if(lbn(nb)-lbn(nb-1)+1 .lt. minseg) goto 30 return 20 write(msg,21) maxnb 21 format('bound: insufficient space for lb. maxnb=',i10,'$') call perror1(msg,1) 30 j = (ioc(lbn(nb))-1)/nsid + 1 i = ioc(lbn(nb)) - (j-1)*nsid write(msg,31) lbn(nb)-lbn(nb-1)+1,i,j 31 format('bound: only',i3,' consecutive ocean grid pts', + ' near (i,j or j,i)= ',2i5,'$') call perror1(msg,1) c end of bound. end c ------------------------------------------------------------------ subroutine gridxy(nxp,nyp,x1,x2,y1,y2,nsx,nsy,nystrch,xs,alpha,beta, * x,y,xp,yp,xpp,ypp) c ------------------------------------------------------------------ c compute the x and y grid point coordinates. c c nxp,nyp = (input) # of grid points in the x and y directions. c x1,x2 = (input) minimum and maximum x-coordinate. c y1,y2 = (input) minimum and maximum y-coordinate. c nsx,nsy = (input) # of atan's composing the stretched grid c transformation function for the x and y directions. c xs = (input) locations of the atan's for x: xs(1 to nsx), c and for y: xs(nsx+1 to nsx+nsy). c alpha = (input) parameters that will determine the # of grid c points in a stretched region; c x: alpha(1 to nsx); and for y: alpha(nsx+1 to nsx+nsy). c beta = (input) parameters that determines the scale width of c each stretched region; c x: beta(1 to nsx); and for y: beta(nsx+1 to nsx+nsy). c x,y = (output) nxp x and nyp y grid coordinates. c xp = (output) nxp derivatives of the x-transformation c function: d(psi1(x))/d(x). c yp = (output) nyp derivatives of the y-transformation c function: d(psi2(y))/d(y). c dimension xs(1),alpha(1),beta(1),x(1),y(1),xp(1),yp(1),xpp(1),ypp(1) c if(nsx.le.0) then c no stretching of the x-coordinates. delx = (x2-x1)/float(nxp-1) do i = 1, nxp x(i) = x1 + (i-1)*delx xp(i) = 1. xpp(i) = 0. enddo else c coordinate stretching in the x-direction. call stretch(nxp,x1,x2,nsx,xs,alpha,beta,x,xp,xpp) endif if (nystrch.eq.1) then if(nsy.le.0) then c no stretching of the y-coordinates. dely = (y2-y1)/float(nyp-1) do i = 1, nyp y(i) = y1 + (i-1)*dely yp(i) = 1. ypp(i) = 0. enddo else c coordinate stretching in the y-direction. i = nsx + 1 call stretch(nyp,y1,y2,nsy,xs(i),alpha(i),beta(i),y,yp,ypp) endif elseif (nystrch.eq.2) then dely = (y2-y1)/float(nyp-1) b = (y2-y1)/(sind(y2)-sind(y1)) a = y1 - b* sind(y1) to_pie = atan(1.)/45. do i = 1, nyp yl = y1 + (i-1)*dely y(i) = a + b * sind(yl) yp(i) = to_pie* b * cosd(yl) ypp(i)= - to_pie*to_pie* b * sind(yl) enddo endif return c end of gridxy. end c ------------------------------------------------------------------ subroutine sorti(n,ix,key,ist) c ------------------------------------------------------------------ c sort ix by increasing values and return the sort order in ist. c c n = (input) length of ix. c ix = (input) array to be sorted. c = (output) array sorted by increasing values. c key = (input) flag: c = 1; return the sort order in array ist. c = otherwise; do not use array ist. (call sorti(n,ix,0) is ok.) c ist = (output) array containing the sort order if key=1; c ie. ix output(i) = ix input(ist(i)), i=1,n c implicit real(a-h,o-z),integer(i-n) dimension ix(0:n-1),ist(0:n-1) c c see "the c programming language", kernighan and ritchie, page 58 c for this algorithm. c igap = n/2 if(key.eq.0) then 10 if(igap .le. 0) return do 30 i=igap,n-1 do 20 j=i-igap,0,-igap if(ix(j) .lt. ix(j+igap)) goto 30 itemp = ix(j) ix(j) = ix(j+igap) ix(j+igap) = itemp 20 continue 30 continue igap = igap/2 goto 10 else c do 40 i=0,n-1 40 ist(i) = i+1 50 if(igap .le. 0) return do 70 i=igap,n-1 do 60 j=i-igap,0,-igap if(ix(j) .lt. ix(j+igap)) goto 70 itemp = ix(j) ix(j) = ix(j+igap) ix(j+igap) = itemp itemp = ist(j) ist(j) = ist(j+igap) ist(j+igap) = itemp 60 continue 70 continue igap = igap/2 goto 50 endif c end of sorti. end subroutine newcorn (nxp,nyp,nc,lxx,snx,lyy,sny,mask,isx) c------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) dimension in(4), lxx(1), lyy(1), mask(1), snx(1), sny(1), isx(1) do j = 1, nyp-1 do i = 1, nxp-1 k = nxp*(j-1) + i in(1) = k in(2) = k + 1 in(3) = k + nxp + 1 in(4) = k + nxp land = 0 do m = 1, 4 if (mask(in(m)) .eq. 0) then land = land + 1 m0 = m endif enddo if (land .eq. 1) then nc = nc + 1 if (m0 .le. 2) then n0 = m0 + 2 sy = 1. sx = 3-2*m0 else n0 = m0 - 2 sy = -1. sx = 2*m0-7 endif it = in(n0) ma = mask(it) lxx(nc) = ma snx(nc) = sx c lyy(nc) = (1-nxp*nyp)*((it-1)/nxp) + (it-1)*nyp + 1 lyy(nc) = isx(ma) sny(nc) = sy endif enddo enddo return end subroutine make_iox (nx, ny, mask, iox, nlo, lo, nsponge, lsponge, * nrelax, lrelax, iglob) c------------------------------------------------------------- dimension mask(1), iox(1), lo(1), lsponge(1), lrelax(1) nlo = 0 nsponge = 0 nrelax = 0 k = 0 do i = 1, nx*ny ma = mask(i) if (ma .ne. 0) then k = k + 1 iox(k) = i if (ma .eq. 2) then nlo = nlo + 1 lo(nlo) = k elseif (ma .eq. 3) then nsponge = nsponge + 1 lsponge(nsponge) = i elseif (ma .eq. 4) then nrelax = nrelax + 1 lrelax(nrelax) = i elseif (ma .eq. 5) then nsponge = nsponge + 1 lsponge(nsponge) = i nrelax = nrelax + 1 lrelax(nrelax) = i endif mask(i) = k endif enddo if (iglob .eq. 1) then do j = 1, ny j1 = 1 + (j-1)*nx jnx = j*nx if ( (mask(j1) .eq. 0 .and. mask(jnx) .ne. 0).or. * (mask(jnx) .eq. 0 .and. mask(j1) .ne. 0)) then print*,'ocean/land periodic boundary not allowed' stop endif enddo endif return end c ------------------------------------------------------------------ subroutine maskk (npt,nxp,nyp,nz,nzi,iox,mask) c ------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) dimension mask(nxp*nyp,nz), nzi(npt), iox(npt) do k = 2, nz do i = 1, nxp*nyp mask(i,k) = 0 enddo enddo do i = 1, npt do k = 2, nzi(i) ixy = iox(i) mask(ixy,k) = mask(ixy,1) enddo enddo return end c ------------------------------------------------------------------ subroutine reset_mask(npt,nxp,nyp,nz,nzi,h,mask,MINSEG,nptk, * ixk,iyk,isxk,isyk,dept) c ------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) include 'comm_new.h' dimension mask(nxp,nyp,nz), h(npt,nz), nptk(nz), nzi(npt), * ixk(npt,nz),iyk(npt,nz),isxk(npt,nz),isyk(npt,nz),dept(npt) logical prev, curr c do k = nz, 2, -1 10 continue iflag = 0 do irow = 1, nyp prev = (mask(1, irow, k) .eq. 0) ista = 1 do icol = 2, nxp ixy = mask(icol, irow, k) curr = (ixy .eq. 0) if ( curr .ne. prev ) then if ( prev ) then ista = icol else if (icol-ista .lt. MINSEG) then do i = ista, icol-1 ixym = mask(i,irow,1) mask(i,irow,k) = 0 if (initbt.eq.2)h(ixym,k-1)=h(ixym,k-1)+h(ixym,k) c h(ixym, k) = -98765432. h(ixym, k) = 0. nzi(ixym) = nzi(ixym) - 1 iflag = 1 enddo endif endif prev = curr endif enddo c check last segment if (.not.curr.and.nxp-ista+1.lt.MINSEG) then do i = ista, nxp ixym = mask(i,irow,1) mask(i,irow,k) = 0 if (initbt.eq.2)h(ixym,k-1)=h(ixym,k-1)+h(ixym,k) c h(ixym, k) = -98765432. h(ixym, k) = 0. nzi(ixym) = nzi(ixym) - 1 iflag = 1 enddo endif enddo c now same in y-direction do icol = 1, nxp prev = (mask(icol, 1, k) .eq. 0) ista = 1 do irow = 2, nyp ixy = mask(icol, irow, k) curr = (ixy .eq. 0) if ( curr .ne. prev ) then if ( prev ) then ista = irow else if (irow-ista .lt. MINSEG) then do i = ista, irow-1 ixym = mask(icol,i,1) mask(icol,i,k) = 0 if (initbt.eq.2)h(ixym,k-1)=h(ixym,k-1)+h(ixym,k) c h(ixym, k) = -98765432. h(ixym, k) = 0. nzi(ixym) = nzi(ixym) - 1 iflag = 1 enddo endif endif prev = curr endif enddo c check last segment if (.not.curr.and.nyp-ista+1.lt.MINSEG) then do i = ista, nyp ixym = mask(icol,i,1) mask(icol,i,k) = 0 if (initbt.eq.2)h(ixym,k-1)=h(ixym,k-1)+h(ixym,k) c h(ixym, k) = -98765432. h(ixym, k) = 0. nzi(ixym) = nzi(ixym) - 1 iflag = 1 enddo endif enddo c repeat until iflag = 0 if (iflag.ne.0) goto 10 c now make sure periodic boundaries and land boundaries do not coincide if (iglob .eq. 1) then do irow = 1, nyp ixy = mask(1,irow,1) ixyp = mask(nxp,irow,1) ixyk = mask(1,irow,k) ixypk = mask(nxp,irow,k) if (ixyk.ne.0.and.ixypk.eq.0) then c--------------- turn (nxp,irow,k) into ocean point mask(nxp,irow,k) = ixyp h(ixyp,k) = h(ixy,k) nzi(ixyp) = nzi(ixyp) + 1 endif if (ixypk.ne.0.and.ixyk.eq.0) then c--------------- turn (1,irow,k) into ocean point mask(1,irow,k) = ixy h(ixy,k) = h(ixyp,k) nzi(ixy) = nzi(ixy) + 1 endif enddo endif c now count the number of points on the k-th grid: npk = 0 do icol = 1, nxp do irow = 1, nyp ma = mask(icol,irow,k) if (ma.ne.0) then npk = npk + 1 iyk(npk,k) = isxk(ma,1) endif enddo enddo npk = 0 do irow = 1, nyp do icol = 1, nxp ma = mask(icol,irow,k) if (ma.ne.0) then npk = npk + 1 ixk(npk,k) = ma mask(icol,irow,k) = npk endif enddo enddo nptk(k) = npk npk = 0 do icol = 1, nxp do irow = 1, nyp ma = mask(icol,irow,k) if (ma.ne.0) then npk = npk + 1 isyk(npk,k) = ma endif enddo enddo enddo do i = 1, npt dept(i) = h(i,1) do k = 2, nzi(i) dept(i) = dept(i) + h(i,k) enddo enddo c nzt = nzi(1) c nzi(1) = 0 c do j = nyp,1,-1 c write(90,101)(nzi(max(1,mask(i,j,1))),i=1,nxp) c enddo c nzi(1) = nzt c c do k = 1,nz c do j = nyp,1,-1 c write(90+k,102)(mod(mask(i,j,k),100),i=1,nxp) c enddo c enddo c 101 format(60i1) c 102 format(60i2) return end subroutine set_pbck (nxp, nyp, npbc, lpbcw, lpbce, mask) c---------------------------------------------------------------- implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' dimension lpbcw(1), lpbce(1), mask(nxp*nyp) do j = 1, nyp j1 = 1 + (j-1)*nxp jnx = j*nxp ierr = 0 if ( mask(j1) .ne. 0 ) then if ( mask(jnx) .eq. 0 ) then ierr = nxp+1 else do i = 1, MINSEG - 1 if (ierr.eq.0 .and. mask(j1+i).eq.0) then ierr = i elseif (ierr.eq.0 .and. mask(jnx-i).eq.0) then ierr = nxp+1-i endif enddo endif if (ierr .eq. 0) then npbc = npbc + 1 lpbcw(npbc) = mask(j1) lpbce(npbc) = mask(jnx) endif endif enddo return end c ------------------------------------------------------------------ subroutine set_bpxk (nxp, nyp, mask, nbx,lxx,snx) c ------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) dimension mask(nxp,1), lxx(1),snx(1) logical prev, curr c nbx = 0 do irow = 1, nyp prev = (mask(1, irow) .eq. 0) ista = 1 do icol = 2, nxp ixy = mask(icol, irow) curr = (ixy .eq. 0) if ( curr .ne. prev ) then nbx = nbx + 1 if ( prev ) then lxx(nbx) = ixy snx(nbx) = 1. ista = icol else lxx(nbx) = mask(icol-1, irow) snx(nbx) = -1. endif prev = curr endif enddo enddo end c ------------------------------------------------------------------ subroutine make_lok(npt,nxp,nyp,nz,iox,mask,nlok,lok) c ------------------------------------------------------------------ implicit real(a-h,o-z),integer(i-n) include 'comm_para.h' dimension mask(nxp*nyp,nz), iox(npt), lok(4*MAXSID,nz), nlok(nz) do k = 2, nz nl = 0 do i= 1, nlok(1) ma = mask( iox( lok(i,1)), k) if (ma.ne.0) then nl = nl+1 lok(nl,k) = ma endif enddo enddo return end eos.f/ 839513370 1572 1572 100444 19838 ` C a copy of CAL81 routines from B Huber C fixed range check bugs 5 May 1987 C routines kept in /usr/lib/libeos.a c hydrographic subroutines to compute various oceanographic c parameters from measured values of pressure, temp, conductivity, c and salinity. routines re-written & reorganized october, 1982 c largely from &calcs, &hysub, & &rhosb. c c to conform as closely as possible to unesco '81 standards c c programmers: s rennie, b huber, p mele, c greengrove c & some whoi types referenced below c c group i -- mostly functions returning 1 value c no double precision except zeta & zeta2 c c call sal81( p, t, c ,s) - convert conductivity => salin (practical sal'78) c potmp( p, t, s ) - potential temperature (bryden) c sigmt( t, s ) - new sigma-t function (calls dens) c sigth( p, t, s ) - new sigma-theta function (call dens) c sigp(p, t, s, pref) - function for sigma-p (calls atg & dens ) c spvan(p, t, s, spvl) - new function for spec vol anomaly (calls spvol) c alfbt(p, t, s, alpha, beta, dwrtt, dwrts) - subr for dens partial deriv c (calls dens) c zeta(p, zlat, zdep) - function to convert pressure to depth (approx) c zeta2(p, zlat, zdep) - sub to convert pressure to depth (approx) c bvun(p, t, s, sn2) - brunt-vaisalla freq in cycles/hour (changed from c bvfof 7/19/84) c c group ii -- used by routines in group i, may have double precision args c c atg(p, t, s) - adiabatic temp grad (bryden 1973) c dens(p, t, s, r0ts, rpts ) - unecso'81 density rho(sigm-t) & rho(insitu) c spvol(p, t, s, spv0, spv ) - unesco'81 specific volume c sbulk(p, t, s, kk) - unesco'81 secant bulk modulas c theta( p, t, s, pref ) - local potential temp (fofonoff) - uses atg c c**************************************************************************** c function potmp (prs, temp, sal) c c potential temperature according to bryden c convert to 1948 temperature scale c tmp = temp tmp = temp + 4.4e-6 * temp * (100.0 - temp) s0 = sal - 35.0 a3 = 0.50484e-14 * tmp - 0.16056e-12 a2 = (0.21987e-11 * tmp - 0.31628e-9) * tmp + 0.89309e-8 - * 0.41057e-10 * s0 a11 = -0.29778e-7 * tmp + 0.17439e-5 a10 = ((0.40274e-9 * tmp - 0.54065e-7) * tmp + * 0.83198e-5) * tmp + 0.36504e-4 a1 = a11 * s0 + a10 potmp = temp - ((a3 * prs + a2) * prs + a1) * prs return end c**************************************************************************** function zeta(p, zlat, zdep) c c depth from pressure -- ignores dynamic height anamoly c zlat (input) is lat in radians c c from saunders & fofonoff - dsr 23, aug 1978 c real*8 zgrav, zdep, zlat zgrav = 978.0318 * (1.0 + 5.3024d-3 * dsin(zlat)**2 - 5.9d-6 * * dsin(2.0 * zlat)**2) c cm/s**2 c zdep = 0.712953 * p + 1.113d-7 * p**2 - 3.434d-12 * p**3 + c * 14190.7 * dlog(1.0 + 1.83d-5 * p) zdep = (( -3.434d-12*p + 1.113d-7)*p + 0.712953)*p * + 14190.7 * dlog(1.0 + 1.83d-5 * p) zdep = zdep / (zgrav + 1.113d-4 * p) * 1000.0 return end c**************************************************************************** c subroutine zeta2(p, zlat, zdep) c c compute depth from pressure & lat (in radians) c ignores dynamic height anomoly c from saunders - jpo 11/1, apr 81 c real*8 zlat, zdep, zpres zpres = p zdep = ((1.0d0 - (5.92d0 + 5.25d0 * dsin(zlat)**2) * 1d-3) * - 2.21d-6 * zpres)*zpres return end c**************************************************************************** subroutine sal81(pres, temp, cond, sal) c c sal81 salinity subroutine derived from c sal78 subr ********** oct 24 1979 ************* c c subroutine to convert conductivity to salinity c c algorithms recommended by jpots using the 1978 practical c salinity scale and ipts-68 for temperature c c n fofonoff c c code basically from rte aqui c it was found that subr. salin formerly used in c in plt78 produced values that were too low by c approx. .006 o/oo, possibly due to use of dauphinee c correction. this version incorporates the newest c recommendations on how to derive salinity from c conductivity (unesco 78), but still uses old c pressure term. update when new pressure data c available in the literature. for now, this c routine should produce results consistent with c the aquisition program. c bah nov 8 '81 c mikhail somov c sfn(xr, xt) = ((((2.7081 * xr - 7.0261) * xr + 14.0941) * xr + * 25.3851) * xr - 0.1692) * xr + 0.0080 + (xt / (1.0 + * 0.0162 * xt)) * (((((-0.0144 * xr + 0.0636) * xr - * 0.0375) * xr - 0.0066) * xr - 0.0056) * xr + 0.0005) c c rt35 c rt35(xt) = (((1.0031e-9 * xt - 6.9698e-7) * xt + 1.104259e-4) * * xt + 2.00564e-2) * xt + 0.6766097 c c cba c c(xp) = ((3.989e-15 * xp - 6.370e-10) * xp + 2.070e-5) * xp b(xt) = (4.464e-4 * xt + 3.426e-2) * xt + 1.0 a(xt) = -3.107e-3 * xt + 0.4215 c c prog c dt = temp - 15.0 r = cond / 42.909 rt = r / (rt35(temp) * (1.0 + c(pres) / (b(temp) + a(temp) * r))) c c avoid neg arg to sqrt c if (rt .le. 0.0) rt = 0.0 rt = sqrt(rt) sal = sfn(rt, dt) return end c**************************************************************************** function sigmt ( t, s ) c sigma-t from r0ts double precision r0ts, rho p = 0.0 call dens( p, t, s, r0ts, rho ) sigmt = (r0ts - 1.d0) * 1.d3 return end c**************************************************************************** function sigth( p, t, s ) c sigma-theta from r0(potmp)s double precision r0ts, rho theta = potmp( p, t, s) call dens( p, theta, s, r0ts, rho ) sigth = (r0ts - 1.d0) * 1.d3 return end c**************************************************************************** function sigp(p, t, s, pref) c c * sigp ****** potential density fcn (was sigz2)*** bah 8/82 c c compute density of parcel moved adiabatically from c pressure p to pref. uses bryden (73) polynomial (in atg ) c double precision r0ts, rho pincr = 100.0 nmax = 10000.0 / pincr c max pr allowed is 10,000 db n = 0 pi = p tp = t if(pref .lt. p) pincr = -pincr c moving up or down? c c compute local atg and pot. temp at p + pincr. repeat in c pincr dbar increments until we reach pref. c do 10 n = 1, nmax if ( abs(pi - pref) .lt. abs(pincr) ) then tp = tp + atg( pi, tp, s ) * (pref - pi) go to 20 c reached pref, we're done end if tp = tp + atg( pi,tp,s) * pincr pi = pi + pincr 10 continue sigp = -99.999 c if we get here then something is wrong return c now compute density at pref, tp, s 20 call dens( pref, tp, s, r0ts, rho ) sigp = (rho - 1.d0) * 1.0d3 return end c**************************************************************************** subroutine sbulk(pr, t, s, kk) c c subroutines to calculate density, spec vol, secant bulk c modulas and alpha & beta c based on unesco 1981 report c equation of state for seawater - millero c programmer - c. greengrove, jan 1982 c modified for hp - p mele, sep '82 c c range: c s = 0 to 42 (practical salinity) c t = -4 to 40 (c) c pr = 0 to 10000 (decibars) c c other units: c density = kg/m3 **3 c bulk deni mod.(k) = bars c c c kk is secant bulk modulas - returned c implicit double precision (a-z) real*4 t, s, pr, s12 c single precision parameter 1 (e0=19652.21d+00,e1=148.4206d+00,e2=-2.327105d+00, 2 e3=1.360477d-02,e4=-5.155288d-05, 3 f0=54.6746d+00,f1=-.603459d+00,f2=1.09987d-02,f3=-6.167d-05, 4 g0=7.944d-02,g1=1.6483d-02,g2=-5.3009d-04, 5 h0=3.239908d+00,h1=1.43713d-03,h2=1.16092d-04,h3=-5.77905d-07, 6 i0=2.2838d-03,i1=-1.0981d-05,i2=-1.6078d-06, 7 j=1.91075d-04, 8 k0=8.50935d-05,k1=-6.12293d-06,k2=5.2787d-08, 9 m0=-9.9348d-07,m1=2.0816d-08,m2=9.1697d-10) if (t.lt.-4.0 .or. t.gt.40.0) then c range specifications kk = -99.9 return else if (s.lt.0.0 .or. s.gt.42.0) then kk = -99.9 return else if (pr.lt.0.0 .or. pr.gt.10000.0) then kk = -99.9 return end if p = pr / 10.0 c convert to bars c define sqrt(s) s12=sqrt(s) c c secant bulk modulas (k) of seawater c c pure water terms of sbm are w series c kw = (((e4*t + e3)*t + e2)*t + e1)*t + e0 aw = ((h3*t + h2)*t + h1)*t + h0 bw = (k2*t + k1)*t + k0 c c coeff for final equation c aa = aw + s*((i2*t + i1)*t + i0 + j*s12) bb = bw + s*((m2*t + m1)*t + m0) c c sbm at p = 0 first term in the final eq c ko = kw + s*(((f3*t + f2)*t + f1)*t + f0) * + s*s12*((g2*t + g1)*t + g0) c c final eq sbm c kk = (bb*p + aa)*p + ko return end c**************************************************************************** subroutine dens(pr, t, s, r0, rr) c c sub to compute density c calls sub 'sbulk', for secant bulk modulas c c r0 is density at p = 0 - returned in gr cm**3 c rr is in situ density - returned c implicit double precision (a-z) real*4 t, s, pr c dimension a(0:5), b(0:4), c(0:2) parameter 1 (a0=999.842594d+00,a1=6.793952d-02,a2=-9.095290d-03, 2 a3=1.001685d-04,a4=-1.120083d-06,a5=6.536332d-09, 3 b0=8.24493d-01,b1=-4.0899d-03,b2=7.6438d-05, 4 b3=-8.2467d-07,b4=5.3875d-09, 5 c0=-5.72466d-03,c1=1.0227d-04,c2=-1.6546d-06, 6 d=4.8314d-04) if (t.lt.-4.0 .or. t.gt.40.0) then r0 = -99.9 rr = -99.9 return else if (s.lt.0.0 .or. s.gt.42.0) then r0 = -99.9 rr = -99.9 return else if (pr.lt.0.0 .or. pr.gt.10000.0) then r0 = -99.9 rr = -99.9 return end if call sbulk(pr, t, s, kk) c secant bulk modulas (k) of seawater c c density of smow c rw = ((((a5*t + a4)*t + a3)*t + a2)*t + a1)*t +a0 c c density at p = 0 c r0 = rw + s*((((b4*t + b3)*t + b2)*t + b1)*t + b0) * + s*sqrt(s)*((c2*t + c1)*t + c0) + s*s*d c c in situ density c p = pr / 10.0 c p is in bars rr = r0 / (1.d0 - p / kk) rr = rr / 1.d3 c densities are returned in r0 = r0 / 1.d3 c grams / cubic centimeter return end c**************************************************************************** subroutine spvol(pr, t, s, spv0, spv) c c sub to compute specific volume c calls sub dens, for density c c spv0 is specific volume at p = 0 - returned c spv is in situ specific volume - returned c implicit double precision (a-z) real*4 t, s, pr c single precision if (t.lt.-4.0 .or. t.gt.40.0) then spv0 = -99.9 spv = -99.9 return else if (s.lt.0.0 .or. s.gt.42.0) then spv0 = -99.9 spv = -99.9 return else if (pr.lt.0.0 .or. pr.gt.10000.0) then spv0 = -99.9 spv0 = -99.9 return end if call dens(pr, t, s, r0, rr) c this sub calls 'sbulk' spv0 = 1.0 / r0 c specific volume at p = 0 spv = 1.0 / rr c in situ specific volume return end c**************************************************************************** subroutine alfbt(p, t, s, alph, beta, dwrtt, dwrts) c c sub to compute alpha & beta c calls subs: sbulk - secant bulk modulas c dens - density c spvol - specific volume c implicit double precision (a-z) real*4 p, t, s, alph, beta, dwrtt, dwrts, s12 c arguments single precision dimension a(0:5), b(0:4), c(0:2), e(0:4), f(0:3), g(0:2), * h(0:3), i(0:2), k(0:2), m(0:2) data 1 a / 999.842594d+00, 6.793952d-02, -9.095290d-03, 2 1.001685d-04, -1.120083d-06, 6.536332d-09 /, 3 b / 8.24493d-01, -4.0899d-03, 7.6438d-05, 4 -8.2467d-07, 5.3875d-09 /, 5 c / -5.72466d-03, 1.0227d-04, -1.6546d-06 /, 6 d / 4.8314d-04 /, 7 e / 19652.21d+00, 148.4206d+00, -2.327105d+00, 8 1.360477d-02, -5.155288d-05 /, 9 f / 54.6746d+00, -.603459d+00, 1.09987d-02, -6.167d-05 / data 1 g / 7.944d-02, 1.6483d-02, -5.3009d-04 /, 2 h / 3.239908d+00, 1.43713d-03, 1.16092d-04, -5.77905d-07 /, 3 i / 2.2838d-03, -1.0981d-05, -1.6078d-06 /, 4 j / 1.91075d-04 /, 5 k / 8.50935d-05, -6.12293d-06, 5.2787d-08 /, 6 m / -9.9348d-07, 2.0816d-08, 9.1697d-10 / if (t.lt.-4.0 .or. t.gt.40.0) then alph = -99.9 beta = -99.9 return else if (s.lt.0.0 .or. s.gt.42.0) then alph = -99.9 beta = -99.9 return else if (p.lt.0.0 .or. p.gt.10000.0) then alph = -99.9 beta = -99.9 return end if call sbulk(p, t, s, kk) c need kk call dens(p, t, s, r0, rr) c need r0 call spvol(p, t, s, spv0, spv) c need spv0 & spv c c compute sqrt(s) s12=sqrt(s) c derivatives working toward alpha and beta c dbt = k(1) + 2 * k(2) * t + (m(1) + 2 * m(2) * t) * s c derv b wrt t dbs = m(0) + t*(m(1) + m(2)*t) c derv b wrt s dat = h(1) + t*(2*h(2) +3*h(3)*t) + (i(1) + c derv a wrt t * 2 * i(2) * t) * s das = i(0) + t*(i(1)*t + i(2)*t) + 1.5 * j * s12 c derv a wrt s c dkot = e(1) + 2 * e(2) * t + 3 * e(3) * t**2 + 4 * c * e(4) * t**3 + (f(1) + 2 * f(2) * t + 3 * f(3) * c * t**2) * s + (g(1) + 2 * g(2) * t) * s**1.5 dkot = ((4*e(4)*t + 3*e(3))*t + 2*e(2))*t + e(1) c derv ko wrt t * + s*(f(1) + (3*f(3)*t + 2*f(2))*t + s12* * (2*g(2)*t + g(1))) dkos = f(0) + ((f(3)*t + f(2))*t + f(1))*t c derv ko wrt s * + 1.5 * (g(0) + t*(g(1) + g(2)*t)) * s12 drt = a(1)+(((5*a(5)*t + 4*a(4))*t + 3*a(3))*t + 2*a(2))*t c derv dens * + s*(b(1) + ((4*b(4)*t + 3*b(3))*t + 2* b(2))*t c (p = 0) wrt t * + s12*(c(1) + 2*c(2)*t)) dwrtt = drt c argument returned drs = b(0)+ (((b(4)*t + b(3))*t + b(2))*t + b(1))*t c derv dens * + 1.5*s12*(c(0) + (c(2)*t + c(1))*t) + 2*d*s c (p = 0) wrt s dwrts = drs c argument returned r0sq=r0*r0 dvot = (-1.0 / r0sq) * drt c derv spec vol (p = 0) wrt t dvos = (-1.0 / r0sq) * drs c derv spec vol (p = 0) wrt s pbar = p/10. dkt = dkot+pbar*(dat+dbt*pbar) c derv k wrt t dks = dkos+pbar*(das+dbs*pbar) c derv k wrt s kksq=kk*kk fact1=(1.-pbar/kk) fact2=spv0*pbar/(kk*kk) dspvt = dvot*fact1 + dkt*fact2 c derv spec vol wrtt dspvs = dvos*fact1 + dks*fact2 c derv spec vol wt c c alpha & beta c alph = dspvt/spv beta = -dspvs/spv return end c**************************************************************************** function atg(p, t, s) c c adiabatic temperature gradient (bryden 1973) c ds = s - 35.0 atg = (((-2.1687e-16 * t + 1.8676e-14) * t - 4.6206e-13) * p + * ((2.7759e-12 * t - 1.1351e-10) * ds + ((-5.4481e-14 * t + * 8.733e-12) * t - 6.7795e-10) * t + 1.8741e-8)) * p + * (-4.2393e-8 * t + 1.8932e-6) * ds + ((6.6228e-10 * t - * 6.836e-8) * t + 8.5258e-6) * t + 3.5803e-5 return end c**************************************************************************** function theta(p0, t0, s, pf) c c to compute local potential temperature at pf c c oct 12 1975 n. fofonoff c p = p0 t = t0 h = pf - p xk = h * atg(p, t, s) t = t + 0.5 * xk q = xk p = p + 0.5 * h xk = h*atg(p,t,s) t = t + 0.29298322*(xk-q) q = 0.58578644*xk + 0.121320344*q xk = h*atg(p,t,s) t = t + 1.707106781*(xk-q) q = 3.414213562*xk - 4.121320344*q p = p + 0.5*h xk = h*atg(p,t,s) theta = t + (xk - 2.0 * q) / 6.0 return end c**************************************************************************** function spvan(p,t,s,spv) c c specific volume anomaly*1e5 unesco routines, simple-minded approach c oct ,1982, s.rennie c double precision xspv0,xspv, xstnd call spvol( p, t, s, xspv0, xspv) call spvol( p, 0.0, 35., xspv0, xstnd ) spvan = 1d5*( xspv - xstnd ) spv = xspv c return single prec. arg for spec.vol. return end c**************************************************************************** function svel(pr,t,sal) c c svel wilson c wilson oct sound speed (m/sec) jasa,1960,32,(10),1357 c p = 0.1019716*(pr+10.1325) sd = sal - 35. 10 a = (((7.9851e-6*t-2.6045e-4)*t-4.4532e-2)*t+4.5721)*t x+1449.14 svel = (7.7711e-7*t-1.1244e-2)*t+1.39799 v0 = (1.69202e-3*sd+svel)*sd+a a = ((4.5283e-8*t+7.4812e-6)*t-1.8607e-4)*t+.160272 svel = (1.579e-9*t+3.158e-8)*t+7.7016e-5 v1 = svel*sd+a a = (1.8563e-9*t-2.5294e-7)*t+1.0268e-5 svel = -1.2943e-7*sd+a a = -1.9646e-10*t+3.5216e-9 svel = (((-3.3603e-12*p+a)*p+svel)*p+v1)*p+v0 return end c**************************************************************************** function oxsat(t,s) c c oxygen saturation (ml/l) weiss,1970 dsr 17,(4);721 c x = (t+273.16)/100.0 oxsat = exp(((-21.8492*x-173.4292)*x+249.6339)/x *+s*((-0.0017*x+0.014259)*x-0.033096)+143.3483*alog(x)) return end c**************************************************************************** subroutine ctdo2 ( p,t,s,oxc,oxt,ox,pcor,tcor,c2) c c ctdo2 oxygen sensor algorithm c uses weiss ( dsr,17,(4); 721,1970 ) c formula for saturation. units (ml/l) c ox = oxc*exp(tcor*(t+c2*(oxt-t))+pcor*p) ox = ox*oxsat(t,s) return end c**************************************************************************** function bvun(p,t,s, sn2) c c bvun -- from bvfof ***** brunt-vaisala freq ***** c ************************************ c sept 25 1976 n fofonoff c c computes n in cycles per hour,n**2 in rad/sec**2 c double precision rlast, rho, r0 , e SAVE if ( p.eq. 0.0 ) then sn2 = 0.0 bvun = 0.0 go to 90 end if pav = 0.5*(p + plast) call dens( pav,theta(plast,tlast,slast,pav),slast, r0,rlast) call dens(pav,theta(p,t,s,pav),s, r0, rho) cc bvfof e = 38.467369d+0 *( rho - rlast) / cc bvfof @ ((p-plast)* (2.0*rlast*rho + rlast + rho)**2 ) cc changed 7/19/84 to correct approx. factor of 2 difference from version cc on hp & previous calculations e = 9.8/rho * (rho - rlast )/ (p - plast) sn2 = e bvun = 572.9578 * dsign( dsqrt(dabs(e)),e) c rem: e is double prc 90 plast = p c warning: routine needs to 'remember' the last tlast = t c values. if bvfof is in a segment, the slast = s c last values will be lost when swapped. return end less_simple.ing/832170043 1572 1572 100444 3353 ` %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% XY PLANE PICTURES \begin{TIOS} (NEW/Inew.rc) run /XOVY 1.6 def /FIXD true def /CRASH false def /setT{T exch dup 0 gt{1 sub first}{1 add last}ifelse exch step mul add VALUE}def /stpG{last first sub exch div STEP}def /L05 {DEPTH >L 0.5 sub}def /limZ {Z exch -1 mul 0 RANGE}def CRASH {/m1 -2 def /T12N{T first secondtolast last VALUES}def} {/m1 -1 def /T12N{T first second last VALUES}def}ifelse /West {360 exch sub} def /X3 {X [160 210 260] VALUES}def /Y3 {Y [-30 0 30] VALUES}def /Z3 {Z [0. -100 -300] VALUES}def /Z0 {Z 0 VALUE}def /Y0 {Y 0 VALUE}def /X0 {X 210 VALUE}def /XY{X low 4 high GRID Y low 3 high GRID}def /Z dup /real ordered 30 10 600 log_array NewGRID def %%%% NZ H(1) HMAX -- /lgZ {Z first -10. RANGE Z -1. mul 1. add log /longname ($log parenleft Z parenright $) def} def /vel_scale 1.e-3 def /CSC1{/CSCALE vel_scale def}def /CSC01{/CSCALE vel_scale 0.1 mul def}def /CSC05{/CSCALE vel_scale 0.5 mul def}def /arrowsperinch 10 def /stfn{/fullname exch def}def \end{TIOS} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{STREAMS} STR_XY %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% FIXD not { DEPTH -2 mul L first VALUE -1 setT (1-st Layer Depth)stfn X Y CONTOUR DEPTH dup L first VALUE 2 mul exch L second VALUE sub 2 mul -1 setT (2-st Layer Depth)stfn X Y CONTOUR DEPTH -1 mul L last VALUE -1 setT (Total Depth)stfn X Y CONTOUR L05 DEPTH Y3 -1 setT Z L toS (X-Z Vertical Profile)stfn X Z CONTOUR L05 DEPTH X3 -1 setT Z L toS (Y-Z Vertical Profile)stfn Y Z CONTOUR DEPTH -1 mul L second VALUE Y 0 VALUE T 6 stpG X T LINE W_VEL L last VALUE m1 setT ($zeta$ - Surface Elevation)stfn X Y CONTOUR } { TEMP L first VALUE Y0 T 6 stpG X T LINE L05 DEPTH Y0 1 setT Z L toS (X-Z Vertical Profile)stfn X Z CONTOUR }ifelse W_VEL L second VALUE m1 setT X Y CONTOUR TEMP T12N L first VALUE X Y CONTOUR TEMP {Y0 T12N} to_Z X Z CONTOUR TEMP {m1 setT} to_Z Z3 X Y CONTOUR TEMP {X3 m1 setT}to_Z Y Z CONTOUR TEMP {Y3 m1 setT}to_Z X Z CONTOUR CSC1 U_VEL {m1 setT XY}to_Z Z3 V_VEL {m1 setT XY}to_Z Z3 X Y VECTOR U_VEL {X3 m1 setT}to_Z lgZ Y exch CONTOUR U_VEL {Y3 m1 setT}to_Z lgZ X exch CONTOUR pop MEANS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /DEPTH D_MEAN def /T2N {T second last RANGE T /T units gridtype first 6 sub 12. last 6 sub NewEvenGRID replaceGRID}def /Tym {T last VALUE} def T_MEAN {Tym} to_Z Z3 X Y CONTOUR T_MEAN {Tym Y0}to_Z 1500 limZ X Z CONTOUR T_MEAN {Tym Y0}to_Z lgZ X exch CONTOUR T_MEAN {Tym X0}to_Z 1000 limZ Y Z CONTOUR FIXD not{ D_MEAN -1 mul L first last VALUES Tym X Y CONTOUR D_MEAN T2N L last VALUE Y -5 5 RANGE Y AVERAGE X T CONTOUR}if T_MEAN T2N L first VALUE Y -5 5 RANGE Y AVERAGE X T CONTOUR U_MEAN T2N L first VALUE Y -5 5 RANGE Y AVERAGE X T CONTOUR CSC1 U_MEAN {Tym XY}to_Z Z0 V_MEAN {Tym XY}to_Z Z0 X Y VECTOR W_MEAN L second VALUE Tym X Y CONTOUR U_MEAN {Tym Y0}to_Z lgZ X exch CONTOUR U_MEAN {Tym X 210 VALUE}to_Z lgZ Y exch CONTOUR U_MEAN {Tym X 260 VALUE}to_Z lgZ Y exch CONTOUR U_MEAN {T2N Y0 X0} to_Z lgZ T /month setunits exch CONTOUR V_MEAN {T2N Y0 X0} to_Z lgZ T /month setunits exch CONTOUR T_MEAN {T2N Y0 X0} to_Z DATA 1 STEP lgZ T /month setunits exch CONTOUR pop \end{STREAMS} libdyn4.a/ 839864869 1572 1572 100644 1080032 ` ! /SYM64/ 839864869 0 0 0 42576 ` ,\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨҨ=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\=\bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPP A8 A8 A8 A8 A8 A8 A8 A8 A8 A8 A8 A8 A8 A8 p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p p