*IF DEF,OCEAN GENINT1.2
C ******************************COPYRIGHT****************************** GENINT1.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. GENINT1.4
C GENINT1.5
C Use, duplication or disclosure of this code is subject to the GENINT1.6
C restrictions as set forth in the contract. GENINT1.7
C GENINT1.8
C Meteorological Office GENINT1.9
C London Road GENINT1.10
C BRACKNELL GENINT1.11
C Berkshire UK GENINT1.12
C RG12 2SZ GENINT1.13
C GENINT1.14
C If no contract has been raised with this copy of the code, the use, GENINT1.15
C duplication or disclosure of it is strictly prohibited. Permission GENINT1.16
C to do so must first be obtained in writing from the Head of Numerical GENINT1.17
C Modelling at the above address. GENINT1.18
C ******************************COPYRIGHT****************************** GENINT1.19
C GENINT1.20
CLL Subroutine GEN_INTF_FLD ------------------------------------------- GENINT1.21
C GENINT1.22
CLL Purpose: To generate boundary data from a source model(global or GENINT1.23
CLL regional) GENINT1.24
CLL GENINT1.25
CLL Gather_fld extracts the required data from the source GENINT1.26
CLL (global or regional) data to create the boundary data GENINT1.27
CLL GENINT1.28
CLL Model Modification history from model version 4.5 GENINT1.29
CLL version Date GENINT1.30
CLL 4.5 3/09/98 New deck added M.J.Bell GENINT1.31
CLL GENINT1.32
CLLEND --------------------------------------------------------------- GENINT1.33
GENINT1.34
C*L Argument list for GEN_INTF_FLD GENINT1.35
subroutine gen_intf_fld ( icode, cmessage, nlevels_srce, 9,3GENINT1.36
*IF DEF,MPP GENINT1.37
& nrows_local_srce, row_length_local_srce, GENINT1.38
& mype, proc_to_use, proc_group, GENINT1.39
*ENDIF GENINT1.40
& nrows_srce, row_length_srce, GENINT1.41
& len_intf_trgt, tot_len_intf_trgt, n_levels_trgt, GENINT1.42
& indx_start, index_b_l, index_b_r, GENINT1.43
& weight_b_l, weight_b_r, weight_t_l, weight_t_r, GENINT1.44
& intf_vert_interp, depths_srce, depths_trgt, GENINT1.45
& fld_srce, out_trgt ) GENINT1.46
GENINT1.47
implicit none GENINT1.48
GENINT1.49
integer icode GENINT1.50
character*256 cmessage GENINT1.51
GENINT1.52
integer GENINT1.53
& nlevels_srce, ! IN number of levels on source grid (global) GENINT1.54
*IF DEF,MPP GENINT1.55
& nrows_local_srce, ! in number of rows on source grid (local) GENINT1.56
& row_length_local_srce, ! IN number of points on a row (local) GENINT1.57
& mype, ! "my" processor number GENINT1.58
& proc_to_use, ! IN processor to use GENINT1.59
& proc_group, ! IN (GC_ALL_PROC_GROUP) GENINT1.60
*ENDIF GENINT1.61
& nrows_srce, ! IN number of rows on source grid (global) GENINT1.62
& row_length_srce, ! IN number of points on a row (global) GENINT1.63
& len_intf_trgt, ! IN length of 1 level of interface output GENINT1.64
& tot_len_intf_trgt, ! IN; total length of coefficient arrays GENINT1.65
& n_levels_trgt, ! IN number of levels of interface output GENINT1.66
& indx_start, ! IN start location in arrays GENINT1.67
& index_b_l(tot_len_intf_trgt), !IN GENINT1.68
& index_b_r(tot_len_intf_trgt) ! IN GENINT1.69
real GENINT1.70
& weight_b_l(tot_len_intf_trgt), ! IN weights for GENINT1.71
& weight_b_r(tot_len_intf_trgt), ! IN horiz GENINT1.72
& weight_t_l(tot_len_intf_trgt), ! IN interpolation GENINT1.73
& weight_t_r(tot_len_intf_trgt) ! IN GENINT1.74
GENINT1.75
logical intf_vert_interp ! T => vertical interpolation needed GENINT1.76
real GENINT1.77
& depths_srce( nlevels_srce), ! IN depths of source grid GENINT1.78
& depths_trgt ( n_levels_trgt ), ! IN depths of target grid GENINT1.79
*IF DEF,MPP GENINT1.80
& fld_srce (row_length_local_srce*nrows_local_srce,nlevels_srce), GENINT1.81
*ELSE GENINT1.82
& fld_srce (row_length_srce*nrows_srce,nlevels_srce), GENINT1.83
*ENDIF GENINT1.84
& ! IN input field GENINT1.85
& out_trgt ( len_intf_trgt, n_levels_trgt ) ! OUT main output GENINT1.86
GENINT1.87
!--------------------------------------- GENINT1.88
GENINT1.89
! local arrays GENINT1.90
real work_global(row_length_srce, nrows_srce) GENINT1.91
real intf_work( len_intf_trgt, nlevels_srce) GENINT1.92
GENINT1.93
! local scalars GENINT1.94
integer level, i ! loop counters GENINT1.95
GENINT1.96
integer indx_ptr ! pointer to start location in interpolation GENINT1.97
! coeff arrays GENINT1.98
real depth ! depth of level to interpolate to GENINT1.99
GENINT1.100
integer lev1, lev2 ! depths of nearest levels GENINT1.101
real dep_lev1, dep_lev2 !depths of levels above and below GENINT1.102
GENINT1.103
!--------------------------------------- GENINT1.104
GENINT1.105
CL 1. Loop over levels of SRCE grid for horizontal interpolation GENINT1.106
GENINT1.107
do level = 1, nlevels_srce GENINT1.108
GENINT1.109
CL 1.1 Gather field for horizontal interpolation GENINT1.110
GENINT1.111
*IF DEF,MPP GENINT1.112
call gather_field
(fld_srce(1,level), work_global, GENINT1.113
& row_length_local_srce, nrows_local_srce, GENINT1.114
& row_length_srce, nrows_srce, GENINT1.115
& proc_to_use, proc_group, GENINT1.116
& icode) ! check info -> icode is OK GENINT1.117
GENINT1.118
if (icode .ne. 0) then GENINT1.119
write(6,*) ' gather_field failed in gen_intf_fld on level ' GENINT1.120
write(6,*) level GENINT1.121
icode = 1 GENINT1.122
go to 999 GENINT1.123
end if GENINT1.124
GENINT1.125
IF (mype .EQ. proc_to_use) THEN GENINT1.126
*ENDIF GENINT1.127
GENINT1.128
CL 1.2 Do horizontal interpolation GENINT1.129
GENINT1.130
! need to think about sizes carefully !! GENINT1.131
! indx_ptr = (level - 1) * len_intf_trgt + indx_start GENINT1.132
indx_ptr = indx_start GENINT1.133
! need to think about sizes carefully !! GENINT1.134
GENINT1.135
GENINT1.136
*IF -DEF,MPP GENINT1.137
call h_int_bl(nrows_srce,row_length_srce,len_intf_trgt GENINT1.138
&, index_b_l(indx_ptr),index_b_r(indx_ptr), fld_srce GENINT1.139
*ELSE GENINT1.140
call h_int_bl(nrows_srce,row_length_srce,len_intf_trgt GENINT1.141
&, index_b_l(indx_ptr),index_b_r(indx_ptr),work_global GENINT1.142
*ENDIF GENINT1.143
&, weight_b_l(indx_ptr), weight_b_r(indx_ptr) GENINT1.144
&, weight_t_l(indx_ptr), weight_t_r(indx_ptr) GENINT1.145
&, intf_work(1,level) ) GENINT1.146
GENINT1.147
*IF DEF,MPP GENINT1.148
END IF ! mype GENINT1.149
*ENDIF GENINT1.150
GENINT1.151
end do ! level GENINT1.152
GENINT1.153
CL 2. do vertical interpolation GENINT1.154
GENINT1.155
*IF DEF,MPP GENINT1.156
IF (mype .eq. proc_to_use) THEN GENINT1.157
*ENDIF GENINT1.158
GENINT1.159
if (intf_vert_interp) then GENINT1.160
do level=1, n_levels_trgt GENINT1.161
! set output level GENINT1.162
depth = depths_trgt (level) GENINT1.163
GENINT1.164
call oa_int_lev( icode, cmessage, GENINT1.165
& nlevels_srce, depths_srce, depth, GENINT1.166
& lev1, lev2, dep_lev1, dep_lev2 ) GENINT1.167
GENINT1.168
call oa_int_1d( icode, cmessage, GENINT1.169
& dep_lev1, dep_lev2, 1, depth, GENINT1.170
& len_intf_trgt, intf_work(1,lev1), intf_work(1,lev2), GENINT1.171
& out_trgt) GENINT1.172
GENINT1.173
end do GENINT1.174
GENINT1.175
C if no vertical interpolation transfer output directly to out_trgt GENINT1.176
else GENINT1.177
do level=1, n_levels_trgt GENINT1.178
do i = 1, len_intf_trgt GENINT1.179
out_trgt (i,level) = intf_work (i,level) GENINT1.180
end do GENINT1.181
end do GENINT1.182
end if GENINT1.183
GENINT1.184
!!!! temporary write out values to see what is happening !!!! GENINT1.185
write(6,*) ' gen_int_fld: out_trgt(i,1) ' GENINT1.186
level=min(7,n_levels_trgt) GENINT1.187
write(6,*)(out_trgt(i,level),i=1,len_intf_trgt) GENINT1.188
GENINT1.189
GENINT1.190
*IF DEF,MPP GENINT1.191
END IF ! mype GENINT1.192
*ENDIF GENINT1.193
GENINT1.194
999 continue GENINT1.195
return GENINT1.196
end GENINT1.197
GENINT1.198
*ENDIF GENINT1.199