Newer
Older
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
INTEGER, INTENT(in) :: kn ! 1= from 2D to 1D ; 2= from 1D to 2D
!
INTEGER :: jl, jk ! dummy loop indices
!!-----------------------------------------------------------------------
!
SELECT CASE( kn )
! !---------------------!
CASE( 1 ) !== from 2D to 1D ==!
! !---------------------!
! fields used but not modified
CALL tab_2d_1d( npti, nptidx(1:npti), sss_1d(1:npti), sss_m(:,:) )
CALL tab_2d_1d( npti, nptidx(1:npti), sst_1d(1:npti), sst_m(:,:) )
! the following fields are modified in this routine
!!CALL tab_2d_1d( npti, nptidx(1:npti), ato_i_1d(1:npti), ato_i(:,:) )
!!CALL tab_3d_2d( npti, nptidx(1:npti), a_i_2d(1:npti,1:jpl), a_i(:,:,:) )
!!CALL tab_3d_2d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) )
CALL tab_3d_2d( npti, nptidx(1:npti), v_s_2d (1:npti,1:jpl), v_s (:,:,:) )
CALL tab_3d_2d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) )
CALL tab_3d_2d( npti, nptidx(1:npti), oa_i_2d(1:npti,1:jpl), oa_i(:,:,:) )
CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip(:,:,:) )
CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip(:,:,:) )
CALL tab_3d_2d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il(:,:,:) )
DO jl = 1, jpl
DO jk = 1, nlay_s
CALL tab_2d_1d( npti, nptidx(1:npti), ze_s_2d(1:npti,jk,jl), e_s(:,:,jk,jl) )
END DO
DO jk = 1, nlay_i
CALL tab_2d_1d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
END DO
END DO
CALL tab_2d_1d( npti, nptidx(1:npti), sfx_dyn_1d (1:npti), sfx_dyn (:,:) )
CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bri_1d (1:npti), sfx_bri (:,:) )
CALL tab_2d_1d( npti, nptidx(1:npti), wfx_dyn_1d (1:npti), wfx_dyn (:,:) )
CALL tab_2d_1d( npti, nptidx(1:npti), hfx_dyn_1d (1:npti), hfx_dyn (:,:) )
CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_dyn_1d(1:npti), wfx_snw_dyn(:,:) )
CALL tab_2d_1d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd (:,:) )
!
! !---------------------!
CASE( 2 ) !== from 1D to 2D ==!
! !---------------------!
CALL tab_1d_2d( npti, nptidx(1:npti), ato_i_1d(1:npti), ato_i(:,:) )
CALL tab_2d_3d( npti, nptidx(1:npti), a_i_2d (1:npti,1:jpl), a_i (:,:,:) )
CALL tab_2d_3d( npti, nptidx(1:npti), v_i_2d (1:npti,1:jpl), v_i (:,:,:) )
CALL tab_2d_3d( npti, nptidx(1:npti), v_s_2d (1:npti,1:jpl), v_s (:,:,:) )
CALL tab_2d_3d( npti, nptidx(1:npti), sv_i_2d(1:npti,1:jpl), sv_i(:,:,:) )
CALL tab_2d_3d( npti, nptidx(1:npti), oa_i_2d(1:npti,1:jpl), oa_i(:,:,:) )
CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip(:,:,:) )
CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip(:,:,:) )
CALL tab_2d_3d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il(:,:,:) )
DO jl = 1, jpl
DO jk = 1, nlay_s
CALL tab_1d_2d( npti, nptidx(1:npti), ze_s_2d(1:npti,jk,jl), e_s(:,:,jk,jl) )
END DO
DO jk = 1, nlay_i
CALL tab_1d_2d( npti, nptidx(1:npti), ze_i_2d(1:npti,jk,jl), e_i(:,:,jk,jl) )
END DO
END DO
CALL tab_1d_2d( npti, nptidx(1:npti), sfx_dyn_1d (1:npti), sfx_dyn (:,:) )
CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bri_1d (1:npti), sfx_bri (:,:) )
CALL tab_1d_2d( npti, nptidx(1:npti), wfx_dyn_1d (1:npti), wfx_dyn (:,:) )
CALL tab_1d_2d( npti, nptidx(1:npti), hfx_dyn_1d (1:npti), hfx_dyn (:,:) )
CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_dyn_1d(1:npti), wfx_snw_dyn(:,:) )
CALL tab_1d_2d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd (:,:) )
!
END SELECT
!
END SUBROUTINE ice_dyn_1d2d
SUBROUTINE ice_dyn_rdgrft_init
!!-------------------------------------------------------------------
!! *** ROUTINE ice_dyn_rdgrft_init ***
!!
!! ** Purpose : Physical constants and parameters linked
!! to the mechanical ice redistribution
!!
!! ** Method : Read the namdyn_rdgrft namelist
!! and check the parameters values
!! called at the first timestep (nit000)
!!
!! ** input : Namelist namdyn_rdgrft
!!-------------------------------------------------------------------
INTEGER :: ios, ioptio ! Local integer output status for namelist read
!!
NAMELIST/namdyn_rdgrft/ ln_str_H79, rn_pstar, rn_crhg, ln_str_R75, rn_pe_rdg, ln_str_CST, rn_str, ln_str_smooth, &
& ln_distf_lin, ln_distf_exp, rn_murdg, rn_csrdg, &
& ln_partf_lin, rn_gstar, ln_partf_exp, rn_astar, &
& ln_ridging, rn_hstar, rn_porordg, rn_fsnwrdg, rn_fpndrdg, &
& ln_rafting, rn_hraft, rn_craft , rn_fsnwrft, rn_fpndrft
!!-------------------------------------------------------------------
!
READ ( numnam_ice_ref, namdyn_rdgrft, IOSTAT = ios, ERR = 901)
901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_rdgrft in reference namelist' )
READ ( numnam_ice_cfg, namdyn_rdgrft, IOSTAT = ios, ERR = 902 )
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namdyn_rdgrft in configuration namelist' )
IF(lwm) WRITE ( numoni, namdyn_rdgrft )
!
IF (lwp) THEN ! control print
WRITE(numout,*)
WRITE(numout,*) 'ice_dyn_rdgrft_init: ice parameters for ridging/rafting '
WRITE(numout,*) '~~~~~~~~~~~~~~~~~~'
WRITE(numout,*) ' Namelist namdyn_rdgrft:'
WRITE(numout,*) ' ice strength parameterization Hibler (1979) ln_str_H79 = ', ln_str_H79
WRITE(numout,*) ' 1st bulk-rheology parameter rn_pstar = ', rn_pstar
WRITE(numout,*) ' 2nd bulk-rhelogy parameter rn_crhg = ', rn_crhg
WRITE(numout,*) ' ice strength parameterization Rothrock (1975) ln_str_R75 = ', ln_str_R75
WRITE(numout,*) ' coef accounting for frictional dissipation rn_pe_rdg = ', rn_pe_rdg
WRITE(numout,*) ' ice strength parameterization Constant ln_str_CST = ', ln_str_CST
WRITE(numout,*) ' ice strength value rn_str = ', rn_str
WRITE(numout,*) ' spatial smoothing of the strength ln_str_smooth= ', ln_str_smooth
WRITE(numout,*) ' redistribution of ridged ice: linear (Hibler 1980) ln_distf_lin = ', ln_distf_lin
WRITE(numout,*) ' redistribution of ridged ice: exponential(Lipscomb 2007) ln_distf_exp = ', ln_distf_exp
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
WRITE(numout,*) ' e-folding scale of ridged ice rn_murdg = ', rn_murdg
WRITE(numout,*) ' Fraction of shear energy contributing to ridging rn_csrdg = ', rn_csrdg
WRITE(numout,*) ' linear ridging participation function ln_partf_lin = ', ln_partf_lin
WRITE(numout,*) ' Fraction of ice coverage contributing to ridging rn_gstar = ', rn_gstar
WRITE(numout,*) ' Exponential ridging participation function ln_partf_exp = ', ln_partf_exp
WRITE(numout,*) ' Equivalent to G* for an exponential function rn_astar = ', rn_astar
WRITE(numout,*) ' Ridging of ice sheets or not ln_ridging = ', ln_ridging
WRITE(numout,*) ' max ridged ice thickness rn_hstar = ', rn_hstar
WRITE(numout,*) ' Initial porosity of ridges rn_porordg = ', rn_porordg
WRITE(numout,*) ' Fraction of snow volume conserved during ridging rn_fsnwrdg = ', rn_fsnwrdg
WRITE(numout,*) ' Fraction of pond volume conserved during ridging rn_fpndrdg = ', rn_fpndrdg
WRITE(numout,*) ' Rafting of ice sheets or not ln_rafting = ', ln_rafting
WRITE(numout,*) ' Parmeter thickness (threshold between ridge-raft) rn_hraft = ', rn_hraft
WRITE(numout,*) ' Rafting hyperbolic tangent coefficient rn_craft = ', rn_craft
WRITE(numout,*) ' Fraction of snow volume conserved during rafting rn_fsnwrft = ', rn_fsnwrft
WRITE(numout,*) ' Fraction of pond volume conserved during rafting rn_fpndrft = ', rn_fpndrft
ENDIF
!
ioptio = 0
IF( ln_str_H79 ) THEN ; ioptio = ioptio + 1 ; nice_str = np_strh79 ; ENDIF
IF( ln_str_R75 ) THEN ; ioptio = ioptio + 1 ; nice_str = np_strr75 ; ENDIF
IF( ln_str_CST ) THEN ; ioptio = ioptio + 1 ; nice_str = np_strcst ; ENDIF
IF( ioptio /= 1 ) CALL ctl_stop( 'ice_dyn_rdgrft_init: one and only one ice strength option has to be defined ' )
!
IF ( ( ln_str_H79 .AND. ln_str_R75 ) .OR. ( .NOT.ln_str_H79 .AND. .NOT.ln_str_R75 ) ) THEN
CALL ctl_stop( 'ice_dyn_rdgrft_init: choose one and only one ice strength formulation (ln_str_H79 or ln_str_R75)' )
ENDIF
!
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
IF ( ( ln_distf_lin .AND. ln_distf_exp ) .OR. ( .NOT.ln_distf_lin .AND. .NOT.ln_distf_exp ) ) THEN
CALL ctl_stop( 'ice_dyn_rdgrft_init: choose one and only one redistribution function (ln_distf_lin or ln_distf_exp)' )
ENDIF
!
IF ( ( ln_partf_lin .AND. ln_partf_exp ) .OR. ( .NOT.ln_partf_lin .AND. .NOT.ln_partf_exp ) ) THEN
CALL ctl_stop( 'ice_dyn_rdgrft_init: choose one and only one participation function (ln_partf_lin or ln_partf_exp)' )
ENDIF
!
IF( .NOT. ln_icethd ) THEN
rn_porordg = 0._wp
rn_fsnwrdg = 1._wp ; rn_fsnwrft = 1._wp
rn_fpndrdg = 1._wp ; rn_fpndrft = 1._wp
IF( lwp ) THEN
WRITE(numout,*) ' ==> only ice dynamics is activated, thus some parameters must be changed'
WRITE(numout,*) ' rn_porordg = ', rn_porordg
WRITE(numout,*) ' rn_fsnwrdg = ', rn_fsnwrdg
WRITE(numout,*) ' rn_fpndrdg = ', rn_fpndrdg
WRITE(numout,*) ' rn_fsnwrft = ', rn_fsnwrft
WRITE(numout,*) ' rn_fpndrft = ', rn_fpndrft
ENDIF
ENDIF
! ! allocate arrays
IF( ice_dyn_rdgrft_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'ice_dyn_rdgrft_init: unable to allocate arrays' )
!
END SUBROUTINE ice_dyn_rdgrft_init
#else
!!----------------------------------------------------------------------
!! Default option Empty module NO SI3 sea-ice model
!!----------------------------------------------------------------------
#endif
!!======================================================================
END MODULE icedyn_rdgrft