SUBROUTINE GEN_INTF ( 5,9@DYALLOC.950
*CALL ARGSIZE 
@DYALLOC.951
*CALL ARGD1 @DYALLOC.952
*CALL ARGDUMA @DYALLOC.953
*CALL ARGSTS @DYALLOC.954
*CALL ARGPTRA @DYALLOC.955
*CALL ARGCONA @DYALLOC.956
*CALL ARGINFA @DYALLOC.957
*CALL ARGPTRO GMB1F405.57
*CALL ARGCONO GMB1F405.58
*CALL ARGDUMO GMB1F405.59
*CALL ARGINFO GMB1F405.60
*CALL ARGPPX APB4F401.116
& internal_model,ICODE,CMESSAGE) GDR3F305.189
GENINTF1.31
IMPLICIT NONE GENINTF1.32
@DYALLOC.959
*CALL CMAXSIZE @DYALLOC.960
*CALL CMAXSIZO GMB1F405.61
*CALL CSUBMODL GSS1F305.926
*CALL CINTFA GDR2F405.113
*CALL TYPSIZE @DYALLOC.961
*CALL TYPD1 @DYALLOC.962
*CALL TYPDUMA @DYALLOC.963
*CALL TYPSTS @DYALLOC.964
*CALL TYPPTRA @DYALLOC.965
*CALL TYPCONA @DYALLOC.966
*CALL TYPINFA @DYALLOC.967
*CALL TYPPTRO GMB1F405.62
*CALL TYPCONO GMB1F405.63
*CALL TYPDUMO GMB1F405.64
*CALL TYPINFO GMB1F405.65
*IF DEF,MPP APB4F401.117
*CALL PARVARS APB4F401.118
*ENDIF APB4F401.119
GENINTF1.33
INTEGER GENINTF1.34
& internal_model, ! Sub-model indicator GDR3F305.190
& ICODE ! Return code : =0 Normal exit DR240293.163
DR240293.164
CHARACTER*(80) CMESSAGE ! Error message if ICODE > 0 ANF0F304.16
DR240293.166
C* DR240293.167
*CALL CHSUNITS GDR3F305.191
*CALL CCONTROL GDR3F305.192
*CALL CTIME DR240293.168
*CALL PPXLOOK APB4F401.120
*CALL CHISTORY GDR3F405.669
*CALL LBC_COUP GDR3F405.670
integer lbc_ntimes ! No of times BC's have been generated. GDR3F405.671
*IF DEF,MPP GDR3F405.672
integer ierr ! Error code GDR3F405.673
integer info ! Return code from GCOM routine. GDR3F405.674
*ENDIF GDR3F405.675
character*8 ch_date2 ! Date returned from date_and_time. GDR3F405.676
character*10 ch_time2 ! Time returned from date_and_time. GDR3F405.677
GDR3F405.678
*CALL CINTFO GMB1F405.66
*CALL TYPOCDPT GMB1F405.67
DR240293.173
INTEGER NFTOUT DR240293.174
DR240293.177
INTEGER JINTF ! Interface area index DR240293.178
INTEGER LEN_INTF_DATA_DA ! Length of workspace GDR1F400.20
INTEGER IM_IDENT ! internal model identifier GRB4F305.134
INTEGER IM_INDEX ! internal model index for STASH arrays GRB4F305.135
DR240293.181
C*L External subroutines called : DR240293.182
EXTERNAL GMB1F405.68
& INTF_UNIT GMB1F405.69
*IF DEF,ATMOS GMB1F405.70
& ,GEN_INTF_A GMB1F405.71
*ENDIF GMB1F405.72
*IF DEF,OCEAN GMB1F405.73
& ,GEN_INTF_O GMB1F405.74
*ENDIF GMB1F405.75
C* DR240293.184
CL Internal structure: DR240293.190
GRB4F305.136
C Set up internal model identifier and STASH index GRB4F305.137
im_ident = internal_model GRB4F305.138
im_index = internal_model_index(im_ident) GRB4F305.139
DR240293.191
ICODE=0 DR240293.192
CMESSAGE=' ' DR240293.193
DR240293.194
*IF DEF,ATMOS GSS1F304.321
IF (LLBOUTim(A_IM)) THEN GDR3F305.193
DR240293.196
CL Atmosphere Interface DR240293.197
DR240293.198
CL 1.0 Loop over all areas DR240293.199
DO JINTF=1,N_INTF_A DR240293.200
DR240293.201
CL Determine if interface data required this timestep DR240293.202
IF (INTERFACE_STEPSim(JINTF,a_im).GT.0) THEN GDR5F305.19
DR240293.204
IF ( MOD(STEPim(a_im)-INTERFACE_FSTEPim(JINTF,a_im), GDR5F305.20
+ INTERFACE_STEPSim(JINTF,a_im)).EQ.0 GDR5F305.21
+ .AND. STEPim(a_im).GE.INTERFACE_FSTEPim(JINTF,a_im) GDR5F305.22
+ .AND. STEPim(a_im).LE.INTERFACE_LSTEPim(JINTF,a_im) ) THEN GDR5F305.23
DR240293.209
CALL INTF_UNIT (1,JINTF,NFTOUT) GDR2F405.114
DR240293.211
! Determine length of workspace to be dynamic allocated GDR1F400.21
LEN_INTF_DATA_DA = LEN_INTFA_DATA(JINTF) APB4F401.121
GDR1F400.27
CL Call GEN_INTF_A to generate interface data for this area. @DYALLOC.969
CALL GEN_INTF_A ( @DYALLOC.970
*CALL ARGSIZE @DYALLOC.971
*CALL ARGDUMA @DYALLOC.972
*CALL ARGINFA @DYALLOC.973
*CALL ARGSTS APB4F401.122
*CALL ARGPPX APB4F401.123
*IF DEF,MPP APB4F401.124
& glsize(1)*glsize(2), APB4F401.125
*ENDIF APB4F401.126
+ JINTF,NFTOUT, @DYALLOC.974
+ D1(JPSTAR),D1(JU(1)),D1(JV(1)),D1(JTHETA(1)),D1(JQ(1)), DR240293.215
+ D1(JQCF(1)),D1(JTRACER(1,1)),A_LEVDEPC(JAK),A_LEVDEPC(JBK), ARB1F404.216
+ LEN_INTFA_P(JINTF),LEN_INTFA_U(JINTF),LEN_INTFA_DATA(JINTF), DR240293.217
+ INTF_P_LEVELS(JINTF), @DYALLOC.975
& U_FIELD, APB4F401.127
& P_LEVELS,LEN_INTF_DATA_DA, GDR1F400.28
& atmos_im, APB4F401.128
& ICODE,CMESSAGE) GDR3F305.194
DR240293.222
IF (ICODE.NE.0) THEN DR240293.223
GO TO 999 ! Return DR240293.225
ENDIF DR240293.226
DR240293.227
ENDIF DR240293.228
GDR3F405.679
if (l_lbc_coup .and. GDR3F405.680
& lbc_stream_a(jintf).eq.um_lbc_stream) then GDR3F405.681
GDR3F405.682
! Flush buffer to send latest BC's to file. GDR3F405.683
GDR3F405.684
*IF DEF,MPP GDR3F405.685
if (mype.eq.0) then GDR3F405.686
*ENDIF GDR3F405.687
GDR3F405.688
! Flush out all boundary data from buffer. GDR3F405.689
call flush_buffer(nftout,icode) GDR3F405.690
GDR3F405.691
if (icode.ne.0) then GDR3F405.692
write (6,*) 'Return Code from FLUSH_BUFFER ',icode, GDR3F405.693
& ' for unit number ',nftout GDR3F405.694
icode = 501 GDR3F405.695
write (cmessage,*) 'GENINTF : Error flushing out '// GDR3F405.696
& 'Boundary Data.' GDR3F405.697
endif GDR3F405.698
*IF DEF,MPP GDR3F405.699
GDR3F405.700
endif ! if mype=0 GDR3F405.701
GDR3F405.702
! Broadcast ICODE to all PE's GDR3F405.703
ierr=icode GDR3F405.704
call gc_ibcast(450,1,0,nproc,info,ierr) GDR3F405.705
icode = ierr GDR3F405.706
*ENDIF GDR3F405.707
GDR3F405.708
! Check ICODE before proceeding. GDR3F405.709
if (icode.ne.0) then GDR3F405.710
write (6,*) ' GENINTF - Error detected' GDR3F405.711
write (6,*) ' CMESSAGE : ',CMESSAGE GDR3F405.712
write (6,*) ' ICODE : ',ICODE GDR3F405.713
go to 999 ! Return GDR3F405.714
endif GDR3F405.715
GDR3F405.716
! Get the number of times BC's have been generated. GDR3F405.717
lbc_ntimes = ft_lastfield(nftout) GDR3F405.718
GDR3F405.719
write (6,*) ' gl : after gen_intf - lbc_ntimes ', GDR3F405.720
& lbc_ntimes GDR3F405.721
GDR3F405.722
*IF DEF,MPP GDR3F405.723
if (mype.eq.0) then GDR3F405.724
*ENDIF GDR3F405.725
GDR3F405.726
! Send message to communication file that next lot of GDR3F405.727
! BC's have been generated. GDR3F405.728
write (190,*) lbc_ntimes GDR3F405.729
GDR3F405.730
*IF -DEF,MAKEBC PXGENINT.1
! Flush message out. GDR3F405.731
call um_fort_flush (190,icode) PXFLUSH.1
if (icode.ne.0) then GDR3F405.733
write (6,*) 'Return Code from FLUSH ',icode GDR3F405.734
icode = 503 GDR3F405.735
write (cmessage,*) 'GENINTF : Error flushing out '// GDR3F405.736
& 'contents for Unit 190.' GDR3F405.737
go to 150 GDR3F405.738
endif GDR3F405.739
*ENDIF PXGENINT.2
GDR3F405.740
! Write a text message that next lot of BC's have GDR3F405.741
! been generated. GDR3F405.742
call date_and_time(ch_date2, ch_time2) GDR3F405.743
if (lbc_fc_hrs.ge.0) then GDR3F405.744
write (191,*) GDR3F405.745
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6), GDR3F405.746
& ' Boundary data has been generated for T+',lbc_fc_hrs GDR3F405.747
else GDR3F405.748
write (191,*) GDR3F405.749
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6), GDR3F405.750
& ' Boundary data has been generated for T',lbc_fc_hrs GDR3F405.751
endif GDR3F405.752
GDR3F405.753
*IF -DEF,MAKEBC PXGENINT.3
! Flush message out. GDR3F405.754
call um_fort_flush (191,icode) PXFLUSH.2
if (icode.ne.0) then GDR3F405.756
write (6,*) 'Return Code from FLUSH ',icode GDR3F405.757
icode = 504 GDR3F405.758
write (cmessage,*) 'GENINTF : Error flushing out '// GDR3F405.759
& 'contents for Unit 191.' GDR3F405.760
go to 150 GDR3F405.761
endif GDR3F405.762
*ENDIF PXGENINT.4
GDR3F405.763
*IF DEF,MPP GDR3F405.764
endif ! if mype=0 GDR3F405.765
*ENDIF GDR3F405.766
GDR3F405.767
call date_and_time(ch_date2, ch_time2) GDR3F405.768
GDR3F405.769
write(6,*) 'LBC_COUP: ', GDR3F405.770
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6),' on ', GDR3F405.771
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4), GDR3F405.772
& ' Timestep ',stepim(a_im), GDR3F405.773
& ' Boundary conditions generated.' GDR3F405.774
GDR3F405.775
! If all boundary conditions have been generated, add GDR3F405.776
! value 7777 to end of file. GDR3F405.777
GDR3F405.778
if (stepim(a_im) .eq. interface_LSTEPim(jintf,a_im)) then GDR3F405.779
GDR3F405.780
lbc_ntimes = 7777 GDR3F405.781
GDR3F405.782
write (6,*) ' gl : after gen_intf - lbc_ntimes ', GDR3F405.783
& lbc_ntimes GDR3F405.784
GDR3F405.785
*IF DEF,MPP GDR3F405.786
if (mype.eq.0) then GDR3F405.787
*ENDIF GDR3F405.788
GDR3F405.789
! Write to communication file and flush. GDR3F405.790
write (190,*) lbc_ntimes GDR3F405.791
*IF -DEF,MAKEBC PXGENINT.5
call um_fort_flush (190,icode) PXFLUSH.3
if (icode.ne.0) then GDR3F405.793
write (6,*) 'Return Code from FLUSH ',icode GDR3F405.794
icode = 506 GDR3F405.795
write (cmessage,*) 'GENINTF : Error flushing out '// GDR3F405.796
& 'contents for Unit 190.' GDR3F405.797
go to 150 GDR3F405.798
endif GDR3F405.799
*ENDIF PXGENINT.6
GDR3F405.800
! Write text message and flush. GDR3F405.801
write (191,*) ' All Boundary data has been generated.' GDR3F405.802
*IF -DEF,MAKEBC PXGENINT.7
call um_fort_flush (191,icode) PXFLUSH.4
if (icode.ne.0) then GDR3F405.804
write (6,*) 'Return Code from FLUSH ',icode GDR3F405.805
icode = 507 GDR3F405.806
write (cmessage,*) 'GENINTF : Error flushing out '// GDR3F405.807
& 'contents for Unit 191.' GDR3F405.808
go to 150 GDR3F405.809
endif GDR3F405.810
*ENDIF PXGENINT.8
GDR3F405.811
*IF DEF,MPP GDR3F405.812
endif ! if mype=0 GDR3F405.813
*ENDIF GDR3F405.814
GDR3F405.815
write (6,*) GDR3F405.816
& 'LBC_COUP: GEN_INTF - All Boundary Conditions generated ', GDR3F405.817
& 'for stream ',jintf GDR3F405.818
GDR3F405.819
endif ! if stepim(a_im) GDR3F405.820
GDR3F405.821
150 continue GDR3F405.822
GDR3F405.823
*IF DEF,MPP GDR3F405.824
! Broadcast ICODE to all PEs. GDR3F405.825
ierr=icode GDR3F405.826
call gc_ibcast(450,1,0,nproc,info,ierr) GDR3F405.827
icode = ierr GDR3F405.828
*ENDIF GDR3F405.829
GDR3F405.830
! Check ICODE before proceeding. GDR3F405.831
if (icode.ne.0) then GDR3F405.832
write (6,*) ' GENINTF - Error detected' GDR3F405.833
write (6,*) ' ICODE : ',ICODE GDR3F405.834
write (6,*) ' CMESSAGE : ',CMESSAGE GDR3F405.835
go to 999 ! Return GDR3F405.836
endif GDR3F405.837
GDR3F405.838
endif ! if l_lbc_coup GDR3F405.839
GDR3F405.840
ENDIF DR240293.229
ENDDO ! Loop over JINTF DR240293.230
GSS1F304.324
END IF ! LLBOUTim(A_IM) GDR3F305.195
*ENDIF GSS1F304.326
DR240293.232
*IF DEF,OCEAN GMB1F405.76
IF (LLBOUTim(O_IM)) THEN GMB1F405.77
GMB1F405.78
CL Ocean Interface GMB1F405.79
GMB1F405.80
CL 1.0 Loop over all areas GMB1F405.81
DO JINTF=1,N_INTF_O GMB1F405.82
GMB1F405.83
CL Determine if interface data required this timestep GMB1F405.84
IF (INTERFACE_STEPSim(JINTF,o_im).GT.0) THEN GMB1F405.85
GMB1F405.86
IF ( MOD(STEPim(o_im)-INTERFACE_FSTEPim(JINTF,o_im), GMB1F405.87
+ INTERFACE_STEPSim(JINTF,o_im)).EQ.0 GMB1F405.88
+ .AND. STEPim(o_im).GE.INTERFACE_FSTEPim(JINTF,o_im) GMB1F405.89
+ .AND. STEPim(o_im).LE.INTERFACE_LSTEPim(JINTF,o_im) ) THEN GMB1F405.90
GMB1F405.91
call intf_unit(o_im, jintf, nftout) GMB1F405.92
GMB1F405.93
CL Call GEN_INTF_O to generate interface data for this area. GMB1F405.94
GMB1F405.95
call gen_intf_o ( GMB1F405.96
*CALL ADUMLENO GMB1F405.97
*CALL AINFLENO GMB1F405.98
*CALL AINTFO GMB1F405.99
*CALL ARGDUMO GMB1F405.100
*CALL ARGINFO GMB1F405.101
*CALL ARGPPX GMB1F405.102
+ JINTF,NFTOUT, GMB1F405.103
+ imt, jmt, km, GMB1F405.104
+ NITEMS, PPINDEX, GMB1F405.105
+ D1(joc_tracer(1,1)), D1(joc_tracer(2,1)), GMB1F405.106
+ D1(joc_u(1)),D1(joc_v(1)), GMB1F405.107
+ D1(joc_stream(1)), D1(joc_tend(1)), GMB1F405.108
+ D1(joc_snow), D1(joc_icecon), D1(joc_icedep), GMB1F405.109
+ O_SPCON(jocp_zdzz), GMB1F405.110
& ICODE,CMESSAGE ) GMB1F405.111
GMB1F405.112
IF (ICODE.NE.0) THEN GMB1F405.113
CMESSAGE = 'GEN_INTF ; Error in GEN_INTF_O' GMB1F405.114
GO TO 999 ! Return GMB1F405.115
ENDIF GMB1F405.116
GMB1F405.117
ENDIF GMB1F405.118
ENDIF GMB1F405.119
ENDDO ! Loop over JINTF GMB1F405.120
GMB1F405.121
END IF ! LLBOUTim(o_im) GMB1F405.122
*ENDIF GMB1F405.123
999 RETURN DR240293.240
END DR240293.241
DR240293.242
*IF DEF,ATMOS GSS1F304.327
DR240293.245
C*L Argument list for GEN_INTF_A @DYALLOC.980
SUBROUTINE GEN_INTF_A ( 1,65@DYALLOC.981
*CALL ARGSIZE @DYALLOC.982
*CALL ARGDUMA @DYALLOC.983
*CALL ARGINFA @DYALLOC.984
*CALL ARGSTS APB4F401.129
*CALL ARGPPX APB4F401.130
*IF DEF,MPP APB4F401.131
& WORK_FLD_SIZE, APB4F401.132
*ENDIF APB4F401.133
& JINTF,NFTOUT, @DYALLOC.985
& PSTAR,U,V,THETA,Q,QCF,TRACER,AK,BK, ARB1F404.217
& LEN_INTF_P,LEN_INTF_U,LEN_INTF_DATA, DR240293.248
& INTF_P_LEVS,U_FIELDDA, APB4F401.134
& P_LEVELSDA,LEN_INTF_DATA_DA, GDR1F400.29
& INTERNAL_MODEL, APB4F401.135
& ICODE,CMESSAGE) GDR3F305.196
DR240293.252
IMPLICIT NONE DR240293.253
DR240293.254
*CALL CMAXSIZE @DYALLOC.987
*CALL CINTFA GDR2F405.115
*CALL TYPSIZE @DYALLOC.988
*CALL TYPDUMA @DYALLOC.989
*CALL TYPINFA @DYALLOC.990
*CALL CSUBMODL APB4F401.136
*CALL TYPSTS APB4F401.137
@DYALLOC.991
INTEGER DR240293.255
& JINTF ! Index to interface area DR240293.256
& ,NFTOUT ! Unit number for interface data DR240293.257
& ,LEN_INTF_P ! Length of interface p* grid DR240293.266
& ,LEN_INTF_U ! Length of interface u grid DR240293.267
& ,LEN_INTF_DATA ! Length of interface data DR240293.268
& ,INTF_P_LEVS ! No of model levels in interface data DR240293.269
& ,U_FIELDDA ! No. of points in wind field ANF1F304.33
*IF DEF,MPP APB4F401.138
& ,WORK_FLD_SIZE ! Size of full global field APB4F401.139
*ENDIF APB4F401.140
& ,P_LEVELSDA ! No. of levels - p* grid GDR1F400.30
& ,LEN_INTF_DATA_DA ! Length of workspace for interface data GDR1F400.31
& ,INTERNAL_MODEL APB4F401.141
DR240293.284
INTEGER DR240293.285
& ICODE ! Return code : =0 Normal exit DR240293.286
C ! >0 Error condition GENINTF1.36
CHARACTER*(80) CMESSAGE ! Error message if ICODE>0 ANF0F304.21
@DYALLOC.993
REAL @DYALLOC.994
& PSTAR(P_FIELD) ! Model P* data @DYALLOC.995
& ,U(U_FIELD,P_LEVELS) ! Model u components @DYALLOC.996
& ,V(U_FIELD,P_LEVELS) ! Model v components @DYALLOC.997
& ,THETA(P_FIELD,P_LEVELS) ! Model theta data @DYALLOC.998
& ,Q(P_FIELD,Q_LEVELS) ! Model Q data @DYALLOC.999
& ,QCF(P_FIELD,Q_LEVELS) ! Model QCF data ARB1F404.218
& ,TRACER(TR_VARS*P_FIELD,TR_LEVELS) ! Model tracer data GDR2F400.3
& ,AK(P_LEVELS) !) A and B values for hybrid @DYALLOC.1003
& ,BK(P_LEVELS) !) co-ords on model full levels @DYALLOC.1004
@DYALLOC.1005
LOGICAL GDR1F400.32
& LPACK_32B ! Packing Indicator GDR1F400.33
& ,LPACK_PPXREF APB4F401.142
C* DR240293.288
INTEGER DR240293.289
& I, GENINTF1.38
& J, GENINTF1.39
& IADDR,IADDR_V, GDR1F400.34
& LEVEL, GENINTF1.42
& VAR, GENINTF1.43
& LOOKUP_START, GENINTF1.44
& LEN_IO, GENINTF1.45
& SEC, GENINTF1.46
& DATA_START, GENINTF1.48
& CODE GENINTF1.49
& ,NTIME ! postion number of interface data GENINTF1.50
*,LEN_PPNAME GENINTF1.51
& ,im_ident ! Internal model identifier APB4F401.143
& ,im_index ! Internal model index in STASH arrays APB4F401.144
GENINTF1.52
INTEGER YY,MM,DD,HR,MN,SS,DAY_NO DR240293.290
DR240293.291
REAL TEMP GENINTF1.53
GENINTF1.56
LOGICAL GENINTF1.57
& ROT_IN ! =T, if input model grid rotated GENINTF1.58
*CALL CHSUNITS GDR3F305.198
*CALL CHISTORY GDR3F305.199
*CALL CCONTROL GDR3F305.200
*CALL CTIME GDR3F305.201
*CALL CLOOKADD GDR3F305.202
*CALL CTRACERA ARB1F404.219
*CALL PPXLOOK APB4F401.145
*CALL C_R_CP GENINTF1.69
*IF DEF,MPP APB4F401.146
*CALL PARVARS APB4F401.147
*CALL GCCOM APB4F401.148
INTEGER info APB4F401.149
*IF DEF,T3E GBCEF405.9
c GBCEF405.10
integer len_intf_uv_data ! Length of U or V data to be GBCEF405.11
! collected after processing GBCEF405.12
! or copying GBCEF405.13
integer len_intf_theta_data ! Length of THETA data to be GBCEF405.14
! collected after processing GBCEF405.15
! or copying GBCEF405.16
integer len_intf_qt_data ! Length of QT data to be GBCEF405.17
! collected after processing GBCEF405.18
! or copying GBCEF405.19
integer lbc_address_work(maxproc) ! Address of the work area GBCEF405.20
! on remote PE's GBCEF405.21
integer lbc_address_data(maxproc) ! Address of the data area GBCEF405.22
! on remote PE's GBCEF405.23
integer iaddr_good ! The real address in GBCEF405.24
! intf_data, maintained GBCEF405.25
! correctly across PE's GBCEF405.26
integer iaddr_u ! Address of U in 'intf_data' GBCEF405.27
integer iaddr_theta ! Address of THETA in GBCEF405.28
! 'intf_data' GBCEF405.29
integer iaddr_qt ! Address of QT in 'intf_data' GBCEF405.30
c GBCEF405.31
integer pe_for_level_uv(p_levels) ! PE to work on a given level GBCEF405.32
! for U/V GBCEF405.33
integer pe_for_level_theta(p_levels)! PE to work on a given level GBCEF405.34
! for THETA GBCEF405.35
integer pe_for_level_qt(p_levels) ! PE to work on a given level GBCEF405.36
! for QT GBCEF405.37
integer local_level(p_levels) ! Index of a global level on a GBCEF405.38
! local PE when the levels are GBCEF405.39
! distributed over several PEs GBCEF405.40
integer pe_for_var(intf_lookupsa) ! PE numbers for each variable GBCEF405.41
real t1, t2, t3 ! local Timers GBCEF405.42
c GBCEF405.43
real remote_intf_work(len_intf_p, 2+2*p_levelsda) GBCEF405.44
real remote_intf_data(len_intf_data_da) GBCEF405.45
c GBCEF405.46
pointer (ptr_work, remote_intf_work) GBCEF405.47
pointer (ptr_data, remote_intf_data) GBCEF405.48
c GBCEF405.49
common/lbc_address_workes/ lbc_address_work, lbc_address_data GBCEF405.50
c GBCEF405.51
*IF DEF,TIME_LBC GBCEF405.52
*CALL T3ECLKTK GBCEF405.53
*ENDIF GBCEF405.54
*ENDIF GBCEF405.55
*ENDIF APB4F401.150
GENINTF1.70
C*L External subroutines called : GENINTF1.71
EXTERNAL SEC2TIME,IOERROR,SETPOS,PACK21,W_LLTOEQ UDG1F400.326
& ,W_EQTOLL,V_INT,BUFFIN,BUFFOUT,P21BITS,H_INT_BL UDG1F400.327
C* DR240293.292
INTEGER EXPPXI APB4F401.151
EXTERNAL EXPPXI APB4F401.152
INTEGER P21BITS DR240293.293
INTEGER N1,N2,N3,N4,N5,NPACK DR240293.294
INTEGER LEN_DATA DR240293.295
*CALL CNTL_IO GBC5F404.52
c GBC5F404.53
integer GBC5F404.54
& disk_address ! Current rounded disk address GBC5F404.55
&,disk_length ! Current data record length on disk GBC5F404.56
&,len_buf ! Maximum Record length to O/P GBC5F404.57
c GBC5F404.58
C*L Workspace used GENINTF1.81
DR240293.297
C Dynamic allocated workspace @DYALLOC.1006
REAL GENINTF1.82
* intf_data(((len_intf_data_da+um_sector_size-1)/ GBC5F404.59
* um_sector_size)*um_sector_size), GBC5F404.60
* INTF_WORK(LEN_INTF_P,2+2*P_LEVELSDA), GDR1F400.36
* INTF_PSTAR(LEN_INTF_P), DR240293.300
* P_OUT(LEN_INTF_P), DR240293.301
* P_TMP(LEN_INTF_P,P_LEVELSDA), GDR1F400.37
* P_HALF_TMP(LEN_INTF_P,INTF_P_LEVS+1), DR240293.303
* P_EXNER_HALF_TMP(LEN_INTF_P,INTF_P_LEVS+1), DR240293.304
*IF DEF,T3E,AND,DEF,MPP GBCEF405.56
* u_temp(u_fieldda, p_levelsda), GBCEF405.57
* v_temp(u_fieldda, p_levelsda), GBCEF405.58
*ELSE GBCEF405.59
* U_TEMP(U_FIELDDA), ANF1F304.34
* V_TEMP(U_FIELDDA), ANF1F304.35
*ENDIF GBCEF405.60
*IF DEF,MPP APB4F401.153
*IF DEF,T3E GBCEF405.61
& WORK_GLOBAL(WORK_FLD_SIZE, 2), GBCEF405.62
*ELSE GBCEF405.63
& WORK_GLOBAL(WORK_FLD_SIZE), APB4F401.154
*ENDIF GBCEF405.64
*ENDIF APB4F401.155
& A_IO DR240293.307
C Workspace for T3E vector function rtor_v GSS9F402.96
integer n_input ! No. of inputs for rtor_v GSS9F402.97
REAL P_HALF_TMP_wk(LEN_INTF_P,INTF_P_LEVS+1) GSS9F402.98
REAL KAPPA_HALF_wk(LEN_INTF_P,INTF_P_LEVS+1) GSS9F402.99
REAL P_TMP_wk(LEN_INTF_P,P_LEVELSDA) GSS9F402.100
REAL KAPPA_wk(LEN_INTF_P,P_LEVELSDA) GSS9F402.101
cdir$ cache_align intf_data GBC5F404.61
DR240293.308
C*--------------------------------------------------------------------- DR240293.309
INTEGER IP_P,IP_U DR240293.311
CHARACTER*80 STRING ! work array GENINTF1.97
CHARACTER*14 PPNAME ! boundary output filename GENINTF1.98
INTEGER START_ADDR ! Start Address in LOOKUP table APB4F401.156
@DYALLOC.1011
C*--------------------------------------------------------------------- @DYALLOC.1012
C Stash item numbers for interface fields @DYALLOC.1013
C Any change to code generating and testing ITEM_INTFA should also ARB1F404.220
C consider the corresponding use of ITEM_BOUNDA in INBOUND1/CHKLKBA1 ARB1F404.221
INTEGER ITEM_INTFA (INTF_LOOKUPSA) ARB1F404.222
C*--------------------------------------------------------------------- @DYALLOC.1019
C* GENINTF1.99
*CALL P_EXNERC GENINTF1.100
GENINTF1.101
CL Internal structure: GENINTF1.102
GENINTF1.103
ICODE=0 GENINTF1.104
CMESSAGE=' ' GENINTF1.105
GENINTF1.106
im_ident = internal_model APB4F401.157
im_index = internal_model_index(im_ident) APB4F401.158
LPACK_32B = INTF_PACK(JINTF).EQ.1 GDR1F400.38
LPACK_PPXREF = INTF_PACK(JINTF).EQ.2 APB4F401.159
GDR1F400.39
CL Atmosphere interface GENINTF1.109
GENINTF1.110
C Logical to indicate if model grid is rotated GENINTF1.111
ROT_IN=A_REALHD(5).NE.90..OR.A_REALHD(6).NE.0. GENINTF1.112
GENINTF1.113
! Set up list of variables expected to be boundary updated. ARB1F404.223
ITEM_INTFA(1) = 1 ! Pstar ARB1F404.224
ITEM_INTFA(2) = 2 ! u-compt wind ARB1F404.225
ITEM_INTFA(3) = 3 ! v-compt wind ARB1F404.226
ITEM_INTFA(4) = 5 ! thetal ARB1F404.227
ITEM_INTFA(5) = 11 ! qt ARB1F404.228
IF (TR_VARS .gt. 0) THEN ARB1F404.229
! Find STASH item no. for each tracer in use. ARB1F404.230
I=0 ! count tracers in use ARB1F404.231
DO J = A_TRACER_FIRST,A_TRACER_LAST ARB1F404.232
IF (SI(J,0,im_index).NE.1) THEN ! tracer is in use ARB1F404.233
I = I+1 ARB1F404.234
ITEM_INTFA(5+I) = J ARB1F404.235
END IF ARB1F404.236
END DO ARB1F404.237
! Number of tracers found should correspond to TR_VARS ARB1F404.238
IF (I.NE.TR_VARS) THEN ARB1F404.239
WRITE(6,*)' GEN_INTF_A: no.of tracers found, ',I, ARB1F404.240
& ', differs from TR_VARS, ',TR_VARS ARB1F404.241
CMESSAGE=' GEN_INTF_A: inconsistency in number of tracers' ARB1F404.242
ICODE = 100 ARB1F404.243
GO TO 999 ARB1F404.244
END IF ARB1F404.245
END IF ARB1F404.246
IF (L_LSPICE) THEN ! mixed phase precipitation scheme ARB1F404.247
ITEM_INTFA(6+TR_VARS) = 12 ! qcf (cloud ice) ARB1F404.248
END IF ARB1F404.249
ARB1F404.250
CL 1.0 Generate data on the boundary zone of limited area grid GENINTF1.114
GENINTF1.115
IADDR=1 GENINTF1.116
GENINTF1.117
C Set up pointers to interpolation coefficients for this area DR240293.312
IP_P = 1 DR240293.313
IP_U = 1 DR240293.314
IF (JINTF.GT.1) THEN DR240293.315
DO J=1,JINTF-1 DR240293.316
IP_P = IP_P + LEN_INTFA_P(J) DR240293.317
IP_U = IP_U + LEN_INTFA_U(J) DR240293.318
ENDDO GENINTF1.132
ENDIF GENINTF1.133
*IF DEF,T3E,AND,DEF,MPP GBCEF405.65
c GBCEF405.66
c--check if there are enough processors to use a parallel algorithm GBCEF405.67
c (remember that PE's 0 and 1 hold only U/V data, PE 2 holds GBCEF405.68
c only THETA data, and PE 3 holds only QT data, etc, so that GBCEF405.69
c the vertical interpolations can be done in parallel after GBCEF405.70
c the horizontal gathers and interpolations) GBCEF405.71
GBCEF405.72
if(nproc.lt.max(p_levels+4, intf_lookupsa)) goto 5000 GBCEF405.73
c GBCEF405.74
c--set up the pe data for the multi-level gathers and horizontal GBCEF405.75
c interpolations GBCEF405.76
do i=1, p_levels GBCEF405.77
pe_for_level_uv(i)=i-1 GBCEF405.78
pe_for_level_theta(i)=i+1 GBCEF405.79
pe_for_level_qt(i)=i+2 GBCEF405.80
local_level(i)=1 GBCEF405.81
end do GBCEF405.82
c GBCEF405.83
c--initialise the 'pe_for_var' array (Vertical Interpolation) GBCEF405.84
do i=1, intf_lookupsa GBCEF405.85
pe_for_var(i)=i-1 GBCEF405.86
end do GBCEF405.87
c GBCEF405.88
c--T3E - exchange remote addresses for 'intf_work' GBCEF405.89
ptr_work=loc(intf_work) GBCEF405.90
call shmem_put(lbc_address_work(mype+1), ptr_work, 1, 0) GBCEF405.91
call barrier() GBCEF405.92
c--now get all the remote addresses GBCEF405.93
call shmem_get(lbc_address_work(1), lbc_address_work(1), nproc, 0) GBCEF405.94
c GBCEF405.95
c--T3E - exchange remote addresses for 'intf_data' GBCEF405.96
ptr_data=loc(intf_data) GBCEF405.97
call shmem_put(lbc_address_data(mype+1), ptr_data, 1, 0) GBCEF405.98
call barrier() GBCEF405.99
c--now get all the remote addresses GBCEF405.100
call shmem_get(lbc_address_data(1), lbc_address_data(1), nproc, 0) GBCEF405.101
GBCEF405.102
CL 1.0 Generate data on the boundary zone of limited area grid GBCEF405.103
GBCEF405.104
iaddr_good=1 GBCEF405.105
iaddr=iaddr_good GBCEF405.106
GBCEF405.107
CL 1.1 P Star GBCEF405.108
GBCEF405.109
*IF DEF,TIME_LBC GBCEF405.110
t1=rtc() GBCEF405.111
t2=0. GBCEF405.112
t3=rtc() GBCEF405.113
*ENDIF GBCEF405.114
call gather_field_ml(PSTAR, WORK_GLOBAL, GBCEF405.115
& lasize(1), lasize(2), 1, GBCEF405.116
& glsize(1), glsize(2), 1, GBCEF405.117
& pe_for_level_uv, local_level, GBCEF405.118
& GC_ALL_PROC_GROUP, info) GBCEF405.119
*IF DEF,TIME_LBC GBCEF405.120
if(mype.eq.0) GBCEF405.121
2 write(0,*)'Time for Gather on PSTAR was ', GBCEF405.122
3 (rtc()-t3)/ticks_per_second GBCEF405.123
*ENDIF GBCEF405.124
GBCEF405.125
*IF DEF,TIME_LBC GBCEF405.126
t2=t2-rtc() GBCEF405.127
t3=rtc() GBCEF405.128
*ENDIF GBCEF405.129
IF (mype .EQ. 0) THEN GBCEF405.130
CL 1.1.1 Horizontal interpolation GBCEF405.131
CALL H_INT_BL(glsize(2),glsize(1),LEN_INTF_P GBCEF405.132
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P),WORK_GLOBAL GBCEF405.133
&, AP_WEIGHT_B_L(IP_P),AP_WEIGHT_B_R(IP_P) GBCEF405.134
&, AP_WEIGHT_T_L(IP_P),AP_WEIGHT_T_R(IP_P) GBCEF405.135
&, INTF_DATA(IADDR)) GBCEF405.136
GBCEF405.137
GBCEF405.138
CL 1.1.2 Save pstar for vertical interpolation GBCEF405.139
IF (INTF_VERT_INTERP(JINTF)) THEN GBCEF405.140
GBCEF405.141
DO I=1,LEN_INTF_P GBCEF405.142
INTF_PSTAR(I)=INTF_DATA(IADDR+I-1) GBCEF405.143
ENDDO GBCEF405.144
ENDIF GBCEF405.145
GBCEF405.146
ENDIF ! IF (mype .EQ. 0) GBCEF405.147
*IF DEF,TIME_LBC GBCEF405.148
if(mype.eq.0) GBCEF405.149
2 write(0,*)'Time for Horizontal on PSTAR was ', GBCEF405.150
3 (rtc()-t3)/ticks_per_second GBCEF405.151
t2=t2+rtc() GBCEF405.152
*ENDIF GBCEF405.153
c GBCEF405.154
c--broadcast this result to everyone GBCEF405.155
call gc_rbcast(8491, len_intf_p, 0, nproc, info, intf_pstar) GBCEF405.156
c--update the address in 'intf_data' GBCEF405.157
iaddr_good=iaddr_good+len_intf_p GBCEF405.158
GBCEF405.159
iaddr=iaddr_good GBCEF405.160
GBCEF405.161
*IF DEF,TIME_LBC GBCEF405.162
t3=rtc() GBCEF405.163
*ENDIF GBCEF405.164
c--loop over levels GBCEF405.165
do level=1, p_levels GBCEF405.166
GBCEF405.167
CL 1.2 U and V components GBCEF405.168
GBCEF405.169
CL 1.2.1 Rotate winds to standard lat-lon if input grid is rotated. GBCEF405.170
GBCEF405.171
IF (ROT_IN) THEN GBCEF405.172
GBCEF405.173
call w_eqtoll(coeff3, coeff4, u(1, level), v(1, level), GBCEF405.174
& u_temp(1, level),v_temp(1, level), GBCEF405.175
& u_field, u_field) GBCEF405.176
GBCEF405.177
ELSE GBCEF405.178
GBCEF405.179
DO I=1,U_FIELD GBCEF405.180
u_temp(i, level)=u(i,level) GBCEF405.181
v_temp(i, level)=v(i,level) GBCEF405.182
ENDDO GBCEF405.183
GBCEF405.184
ENDIF GBCEF405.185
GBCEF405.186
end do GBCEF405.187
CL 1.2.2 Horizontal interpolation - winds GBCEF405.188
call gather_field_ml(U_TEMP, WORK_GLOBAL(1, 1), GBCEF405.189
& lasize(1), lasize(2), p_levels, GBCEF405.190
& glsize(1), glsize(2)-1, 1, GBCEF405.191
& pe_for_level_uv, local_level, GBCEF405.192
& gcg_all, info) GBCEF405.193
GBCEF405.194
call gather_field_ml(V_TEMP, WORK_GLOBAL(1, 2), GBCEF405.195
& lasize(1), lasize(2), p_levels, GBCEF405.196
& glsize(1), glsize(2)-1, 1, GBCEF405.197
& pe_for_level_uv, local_level, GBCEF405.198
& gc_all_proc_group, info) GBCEF405.199
GBCEF405.200
*IF DEF,TIME_LBC GBCEF405.201
if(mype.eq.pe_for_var(1)) GBCEF405.202
2 write(0,*)'Time for Gather on U was ', GBCEF405.203
3 (rtc()-t3)/ticks_per_second GBCEF405.204
if(mype.eq.pe_for_var(2)) GBCEF405.205
2 write(0,*)'Time for Gather on V was ', GBCEF405.206
3 (rtc()-t3)/ticks_per_second GBCEF405.207
*ENDIF GBCEF405.208
GBCEF405.209
*IF DEF,TIME_LBC GBCEF405.210
t2=t2-rtc() GBCEF405.211
t3=rtc() GBCEF405.212
*ENDIF GBCEF405.213
do level=1, p_levels GBCEF405.214
if(mype.eq.pe_for_level_uv(level)) then GBCEF405.215
GBCEF405.216
CALL H_INT_BL(glsize(2)-1,glsize(1),LEN_INTF_U GBCEF405.217
&, AU_INDEX_B_L(IP_U),AU_INDEX_B_R(IP_U) GBCEF405.218
&, WORK_GLOBAL(1,1) GBCEF405.219
&, AU_WEIGHT_B_L(IP_U),AU_WEIGHT_B_R(IP_U) GBCEF405.220
&, AU_WEIGHT_T_L(IP_U),AU_WEIGHT_T_R(IP_U) GBCEF405.221
&, INTF_WORK(1,1)) GBCEF405.222
GBCEF405.223
CALL H_INT_BL(glsize(2)-1,glsize(1),LEN_INTF_U GBCEF405.224
&, AU_INDEX_B_L(IP_U),AU_INDEX_B_R(IP_U) GBCEF405.225
&, WORK_GLOBAL(1,2) GBCEF405.226
&, AU_WEIGHT_B_L(IP_U),AU_WEIGHT_B_R(IP_U) GBCEF405.227
&, AU_WEIGHT_T_L(IP_U),AU_WEIGHT_T_R(IP_U) GBCEF405.228
&, INTF_WORK(1,2)) GBCEF405.229
GBCEF405.230
CALL W_LLTOEQ(COEFF1(IP_U),COEFF2(IP_U), GBCEF405.231
& INTF_WORK(1,1),INTF_WORK(1,2), GBCEF405.232
& INTF_WORK(1,2+LEVEL), GBCEF405.233
& INTF_WORK(1,2+LEVEL+P_LEVELS), GBCEF405.234
& LEN_INTF_U,LEN_INTF_U) GBCEF405.235
GBCEF405.236
GBCEF405.237
endif GBCEF405.238
end do GBCEF405.239
GBCEF405.240
c--make sure everyone has finished computing their data GBCEF405.241
call barrier() GBCEF405.242
c--collect the data on PE zero and one GBCEF405.243
do level=1, p_levels GBCEF405.244
GBCEF405.245
c--U data GBCEF405.246
if(mype.eq.pe_for_var(1)) then GBCEF405.247
ptr_work=lbc_address_work(pe_for_level_uv(level)+1) GBCEF405.248
call shmem_get( GBCEF405.249
2 intf_work(1, 2+level), GBCEF405.250
3 remote_intf_work(1, 2+level), len_intf_u, GBCEF405.251
4 pe_for_level_uv(level)) GBCEF405.252
endif GBCEF405.253
GBCEF405.254
c--V data GBCEF405.255
if(mype.eq.pe_for_var(2)) then GBCEF405.256
ptr_work=lbc_address_work(pe_for_level_uv(level)+1) GBCEF405.257
call shmem_get( GBCEF405.258
2 intf_work(1, 2+level+p_levels), GBCEF405.259
3 remote_intf_work(1, 2+level+p_levels), len_intf_u, GBCEF405.260
4 pe_for_level_uv(level)) GBCEF405.261
endif GBCEF405.262
GBCEF405.263
end do GBCEF405.264
call barrier() GBCEF405.265
GBCEF405.266
*IF DEF,TIME_LBC GBCEF405.267
t2=t2+rtc() GBCEF405.268
if(mype.eq.pe_for_var(1)) GBCEF405.269
2 write(0,*)'Time for Horizontal on U was ', GBCEF405.270
3 (rtc()-t3)/ticks_per_second GBCEF405.271
if(mype.eq.pe_for_var(2)) GBCEF405.272
2 write(0,*)'Time for Horizontal on V was ', GBCEF405.273
3 (rtc()-t3)/ticks_per_second GBCEF405.274
*ENDIF GBCEF405.275
GBCEF405.276
c GBCEF405.277
c--calculate the input pressure levels which everyone needs GBCEF405.278
if (intf_vert_interp(jintf)) then GBCEF405.279
C set up input level pressures GBCEF405.280
C set up for P points and call V_INT for p points with zero data in GBCEF405.281
C extra non U points GBCEF405.282
do level=1,p_levels GBCEF405.283
do i=1,len_intf_p GBCEF405.284
p_tmp(i,level) = ak(level) + intf_pstar(i)*bk(level) GBCEF405.285
enddo GBCEF405.286
enddo GBCEF405.287
endif GBCEF405.288
GBCEF405.289
c--compute transfer addresses and lengths GBCEF405.290
if (intf_vert_interp(jintf)) then GBCEF405.291
len_intf_uv_data=intf_p_levels(jintf)*len_intf_u GBCEF405.292
else GBCEF405.293
len_intf_uv_data=p_levels*len_intf_u GBCEF405.294
endif GBCEF405.295
c--set up the addresses GBCEF405.296
iaddr_u=iaddr_good GBCEF405.297
iaddr_v=iaddr_good+len_intf_uv_data GBCEF405.298
c--now update 'iaddr_good' GBCEF405.299
iaddr_good=iaddr_good+len_intf_uv_data*2 GBCEF405.300
GBCEF405.301
iaddr=iaddr_good GBCEF405.302
GBCEF405.303
CL 1.3 THETAL GBCEF405.304
GBCEF405.305
CL 1.3.1 Horizontal interpolation - thetal GBCEF405.306
GBCEF405.307
*IF DEF,TIME_LBC GBCEF405.308
t3=rtc() GBCEF405.309
*ENDIF GBCEF405.310
GBCEF405.311
c do level=1, p_levels GBCEF405.312
call gather_field_ml(theta(1, 1), WORK_GLOBAL(1,1), GBCEF405.313
& lasize(1), lasize(2), p_levels, GBCEF405.314
& glsize(1), glsize(2), 1, GBCEF405.315
& pe_for_level_theta, local_level, GBCEF405.316
& gcg_all, info) GBCEF405.317
c call gather_field(theta(1, level), WORK_GLOBAL(1,1), GBCEF405.318
c & lasize(1), lasize(2), GBCEF405.319
c & glsize(1), glsize(2), GBCEF405.320
c & pe_for_level_theta(level), GBCEF405.321
c & gcg_all, info) GBCEF405.322
c end do GBCEF405.323
GBCEF405.324
*IF DEF,TIME_LBC GBCEF405.325
if(mype.eq.pe_for_var(3)) GBCEF405.326
2 write(0,*)'Time for Gather on THETA was ', GBCEF405.327
3 (rtc()-t3)/ticks_per_second GBCEF405.328
*ENDIF GBCEF405.329
GBCEF405.330
*IF DEF,TIME_LBC GBCEF405.331
t2=t2-rtc() GBCEF405.332
t3=rtc() GBCEF405.333
*ENDIF GBCEF405.334
c--now do the horizontal interpolation in parallel GBCEF405.335
do level=1, p_levels GBCEF405.336
if(mype.eq.pe_for_level_theta(level)) then GBCEF405.337
GBCEF405.338
CALL H_INT_BL(glsize(2),glsize(1),LEN_INTF_P GBCEF405.339
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P) GBCEF405.340
&, WORK_GLOBAL(1,1) GBCEF405.341
&, AP_WEIGHT_B_L(IP_P),AP_WEIGHT_B_R(IP_P) GBCEF405.342
&, AP_WEIGHT_T_L(IP_P),AP_WEIGHT_T_R(IP_P) GBCEF405.343
&, INTF_WORK(1,2+LEVEL)) GBCEF405.344
GBCEF405.345
endif GBCEF405.346
end do GBCEF405.347
GBCEF405.348
c--make sure everyone has finished computing their data GBCEF405.349
call barrier() GBCEF405.350
c--collect the data on PE two GBCEF405.351
do level=1, p_levels GBCEF405.352
GBCEF405.353
c--THETAL data GBCEF405.354
if(mype.eq.pe_for_var(3)) then GBCEF405.355
ptr_work=lbc_address_work(pe_for_level_theta(level)+1) GBCEF405.356
call shmem_get( GBCEF405.357
2 intf_work(1, 2+level), GBCEF405.358
3 remote_intf_work(1, 2+level), len_intf_p, GBCEF405.359
4 pe_for_level_theta(level)) GBCEF405.360
endif GBCEF405.361
end do GBCEF405.362
GBCEF405.363
call barrier() GBCEF405.364
*IF DEF,TIME_LBC GBCEF405.365
t2=t2+rtc() GBCEF405.366
if(mype.eq.pe_for_var(3)) GBCEF405.367
2 write(0,*)'Time for Horizontal on THETA was ', GBCEF405.368
3 (rtc()-t3)/ticks_per_second GBCEF405.369
*ENDIF GBCEF405.370
GBCEF405.371
c--compute transfer addresses and lengths GBCEF405.372
if (intf_vert_interp(jintf)) then GBCEF405.373
len_intf_theta_data=intf_p_levels(jintf)*len_intf_p GBCEF405.374
else GBCEF405.375
len_intf_theta_data=p_levels*len_intf_p GBCEF405.376
endif GBCEF405.377
iaddr_theta=iaddr_good GBCEF405.378
c--now update 'iaddr_good' GBCEF405.379
iaddr_good=iaddr_good+len_intf_theta_data GBCEF405.380
GBCEF405.381
iaddr=iaddr_good GBCEF405.382
GBCEF405.383
CL 1.4 QT GBCEF405.384
GBCEF405.385
CL 1.4.1 Horizontal interpolation - QT GBCEF405.386
GBCEF405.387
*IF DEF,TIME_LBC GBCEF405.388
t3=rtc() GBCEF405.389
*ENDIF GBCEF405.390
GBCEF405.391
call gather_field_ml(q(1, 1), WORK_GLOBAL(1,1), GBCEF405.392
& lasize(1), lasize(2), q_levels, GBCEF405.393
& glsize(1), glsize(2), 1, GBCEF405.394
& pe_for_level_qt, local_level, GBCEF405.395
& gcg_all, info) GBCEF405.396
GBCEF405.397
*IF DEF,TIME_LBC GBCEF405.398
if(mype.eq.pe_for_var(4)) GBCEF405.399
2 write(0,*)'Time for Gather on QT was ', GBCEF405.400
3 (rtc()-t3)/ticks_per_second GBCEF405.401
*ENDIF GBCEF405.402
GBCEF405.403
*IF DEF,TIME_LBC GBCEF405.404
t2=t2-rtc() GBCEF405.405
t3=rtc() GBCEF405.406
*ENDIF GBCEF405.407
c--now do the horizontal interpolation in parallel GBCEF405.408
do level=1, q_levels GBCEF405.409
if(mype.eq.pe_for_level_qt(level)) then GBCEF405.410
GBCEF405.411
CALL H_INT_BL(glsize(2),glsize(1),LEN_INTF_P GBCEF405.412
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P) GBCEF405.413
&, WORK_GLOBAL(1,1) GBCEF405.414
&, AP_WEIGHT_B_L(IP_P),AP_WEIGHT_B_R(IP_P) GBCEF405.415
&, AP_WEIGHT_T_L(IP_P),AP_WEIGHT_T_R(IP_P) GBCEF405.416
&, INTF_WORK(1,2+LEVEL)) GBCEF405.417
GBCEF405.418
GBCEF405.419
endif GBCEF405.420
end do GBCEF405.421
GBCEF405.422
c--make sure everyone has finished computing their data GBCEF405.423
call barrier() GBCEF405.424
c--collect the data on PE three GBCEF405.425
do level=1, q_levels GBCEF405.426
GBCEF405.427
c--QT data GBCEF405.428
if(mype.eq.pe_for_var(4)) then GBCEF405.429
ptr_work=lbc_address_work(pe_for_level_qt(level)+1) GBCEF405.430
call shmem_get( GBCEF405.431
2 intf_work(1, 2+level), GBCEF405.432
3 remote_intf_work(1, 2+level), len_intf_p, GBCEF405.433
4 pe_for_level_qt(level)) GBCEF405.434
endif GBCEF405.435
GBCEF405.436
end do GBCEF405.437
GBCEF405.438
call barrier() GBCEF405.439
*IF DEF,TIME_LBC GBCEF405.440
t2=t2+rtc() GBCEF405.441
if(mype.eq.pe_for_var(4)) GBCEF405.442
2 write(0,*)'Time for Horizontal on QT was ', GBCEF405.443
3 (rtc()-t3)/ticks_per_second GBCEF405.444
GBCEF405.445
if(mype.eq.0) write(0,*)'Time for Horizontal Interpolation was ', GBCEF405.446
2 t2/ticks_per_second GBCEF405.447
*ENDIF GBCEF405.448
GBCEF405.449
c--compute transfer addresses and lengths GBCEF405.450
if (intf_vert_interp(jintf)) then GBCEF405.451
len_intf_qt_data=intf_q_levels(jintf)*len_intf_p GBCEF405.452
else GBCEF405.453
len_intf_qt_data=q_levels*len_intf_p GBCEF405.454
endif GBCEF405.455
iaddr_qt=iaddr_good GBCEF405.456
c--now update 'iaddr_good' GBCEF405.457
iaddr_good=iaddr_good+len_intf_qt_data GBCEF405.458
GBCEF405.459
CL GBCEF405.460
CL Now do the vertical interpolation in parallel GBCEF405.461
CL GBCEF405.462
*IF DEF,TIME_LBC GBCEF405.463
t2=rtc() GBCEF405.464
*ENDIF GBCEF405.465
GBCEF405.466
iaddr=iaddr_u GBCEF405.467
if (mype.eq.pe_for_var(1) .or. mype.eq.pe_for_var(2)) then GBCEF405.468
*IF DEF,TIME_LBC GBCEF405.469
t3=rtc() GBCEF405.470
*ENDIF GBCEF405.471
GBCEF405.472
CL 1.2.3 Vertical interpolation - winds GBCEF405.473
GBCEF405.474
IF (INTF_VERT_INTERP(JINTF)) THEN GBCEF405.475
GBCEF405.476
DO LEVEL=1,P_LEVELS GBCEF405.477
DO I=LEN_INTF_U+1,LEN_INTF_P GBCEF405.478
INTF_WORK(I,2+LEVEL) = 0.0 GBCEF405.479
INTF_WORK(I,2+LEVEL+P_LEVELS) = 0.0 GBCEF405.480
ENDDO GBCEF405.481
ENDDO GBCEF405.482
GBCEF405.483
DO LEVEL=1,INTF_P_LEVELS(JINTF) GBCEF405.484
C set up output level pressure GBCEF405.485
DO I=1,LEN_INTF_P GBCEF405.486
P_OUT(I) = GBCEF405.487
& INTF_AK(LEVEL,JINTF)+ INTF_PSTAR(I)*INTF_BK(LEVEL,JINTF) GBCEF405.488
ENDDO GBCEF405.489
GBCEF405.490
if(mype.eq.pe_for_var(1)) GBCEF405.491
& CALL V_INT(P_TMP,P_OUT,INTF_WORK(1,3),INTF_WORK(1,1), GBCEF405.492
& LEN_INTF_P,P_LEVELS,TEMP,TEMP,.FALSE., GBCEF405.493
& 1,LEN_INTF_P) GBCEF405.494
GBCEF405.495
if(mype.eq.pe_for_var(2)) GBCEF405.496
& CALL V_INT(P_TMP,P_OUT,INTF_WORK(1,3+P_LEVELS), GBCEF405.497
& INTF_WORK(1,2), GBCEF405.498
& LEN_INTF_P,P_LEVELS,TEMP,TEMP,.FALSE., GBCEF405.499
& 1,LEN_INTF_P) GBCEF405.500
GBCEF405.501
IADDR_V = IADDR + INTF_P_LEVELS(JINTF)*LEN_INTF_U GBCEF405.502
c GBCEF405.503
if(mype.eq.pe_for_var(1)) then GBCEF405.504
do i=1,len_intf_u GBCEF405.505
intf_data(iaddr+i-1) = intf_work(i,1) GBCEF405.506
end do GBCEF405.507
endif GBCEF405.508
GBCEF405.509
if(mype.eq.pe_for_var(2)) then GBCEF405.510
do i=1,len_intf_u GBCEF405.511
intf_data(iaddr_v+i-1) = intf_work(i,2) GBCEF405.512
enddo GBCEF405.513
endif GBCEF405.514
GBCEF405.515
IADDR = IADDR + LEN_INTF_U GBCEF405.516
GBCEF405.517
ENDDO GBCEF405.518
GBCEF405.519
IADDR = IADDR + INTF_P_LEVELS(JINTF)*LEN_INTF_U GBCEF405.520
GBCEF405.521
ELSE GBCEF405.522
GBCEF405.523
DO LEVEL=1,P_LEVELS GBCEF405.524
GBCEF405.525
DO I=1,LEN_INTF_U GBCEF405.526
INTF_DATA(IADDR+I-1) = INTF_WORK(I,2+LEVEL) GBCEF405.527
ENDDO GBCEF405.528
IADDR_V = IADDR + P_LEVELS*LEN_INTF_U GBCEF405.529
DO I=1,LEN_INTF_U GBCEF405.530
INTF_DATA(IADDR_V+I-1)=INTF_WORK(I,2+LEVEL+P_LEVELS) GBCEF405.531
ENDDO GBCEF405.532
IADDR = IADDR + LEN_INTF_U GBCEF405.533
GBCEF405.534
ENDDO GBCEF405.535
GBCEF405.536
IADDR = IADDR + P_LEVELS*LEN_INTF_U GBCEF405.537
GBCEF405.538
ENDIF GBCEF405.539
GBCEF405.540
c--collect the interpolated V data GBCEF405.541
if(mype.eq.pe_for_var(2)) then GBCEF405.542
iaddr_v=iaddr_u+len_intf_uv_data GBCEF405.543
ptr_data=lbc_address_data(1) GBCEF405.544
call shmem_put( GBCEF405.545
& remote_intf_data(iaddr_v), GBCEF405.546
& intf_data(iaddr_v), len_intf_uv_data, 0) GBCEF405.547
endif GBCEF405.548
GBCEF405.549
*IF DEF,TIME_LBC GBCEF405.550
if(mype.eq.pe_for_var(1)) GBCEF405.551
2 write(0,*)'Time for Vertical on U was ', GBCEF405.552
3 (rtc()-t3)/ticks_per_second GBCEF405.553
if(mype.eq.pe_for_var(2)) GBCEF405.554
2 write(0,*)'Time for Vertical on V was ', GBCEF405.555
3 (rtc()-t3)/ticks_per_second GBCEF405.556
*ENDIF GBCEF405.557
ENDIF ! IF (mype.eq.pe_for_var(1) .or. mype.eq.pe_for_var(2)) GBCEF405.558
GBCEF405.559
GBCEF405.560
iaddr=iaddr_theta GBCEF405.561
if (mype .eq. pe_for_var(3)) then GBCEF405.562
*IF DEF,TIME_LBC GBCEF405.563
t3=rtc() GBCEF405.564
*ENDIF GBCEF405.565
GBCEF405.566
CL 1.3.2 Vertical interpolation - thetal GBCEF405.567
GBCEF405.568
IF(INTF_VERT_INTERP(JINTF)) THEN GBCEF405.569
GBCEF405.570
C input level pressures already set up for winds GBCEF405.571
GBCEF405.572
C Calculate pressure and exner pressure at output half levels GBCEF405.573
DO LEVEL=1,INTF_P_LEVELS(JINTF)+1 GBCEF405.574
DO I=1,LEN_INTF_P GBCEF405.575
P_HALF_TMP(I,LEVEL)= GBCEF405.576
& INTF_AKH(LEVEL,JINTF)+INTF_BKH(LEVEL,JINTF)* GBCEF405.577
& INTF_PSTAR(I) GBCEF405.578
P_HALF_TMP_wk(I,LEVEL)=(P_HALF_TMP(I,LEVEL)/PREF) GBCEF405.579
ENDDO GBCEF405.580
ENDDO GBCEF405.581
*IF DEF,VECTLIB PXVECTLB.9
DO LEVEL=1,INTF_P_LEVELS(JINTF)+1 GBCEF405.582
DO I=1,LEN_INTF_P GBCEF405.583
KAPPA_HALF_wk(I,LEVEL)=KAPPA GBCEF405.584
ENDDO GBCEF405.585
ENDDO GBCEF405.586
n_input=LEN_INTF_P*(INTF_P_LEVELS(JINTF)+1) GBCEF405.587
call rtor_v GBCEF405.588
& (n_input,P_HALF_TMP_wk,KAPPA_HALF_wk,P_EXNER_HALF_TMP) GBCEF405.589
*ELSE PXVECTLB.10
DO LEVEL=1,INTF_P_LEVELS(JINTF)+1 PXVECTLB.11
DO I=1,LEN_INTF_P PXVECTLB.12
P_EXNER_HALF_TMP(I,LEVEL)=(P_HALF_TMP_wk(I,LEVEL))**KAPPA PXVECTLB.13
ENDDO PXVECTLB.14
ENDDO PXVECTLB.15
*ENDIF PXVECTLB.16
GBCEF405.590
C Convert input theta to temperature GBCEF405.591
DO LEVEL=1,P_LEVELS GBCEF405.592
DO I=1,LEN_INTF_P GBCEF405.593
P_TMP_wk(I,LEVEL)=P_TMP(I,LEVEL)/PREF GBCEF405.594
ENDDO GBCEF405.595
ENDDO GBCEF405.596
*IF DEF,VECTLIB PXVECTLB.17
DO LEVEL=1,P_LEVELS GBCEF405.597
DO I=1,LEN_INTF_P GBCEF405.598
KAPPA_wk(I,LEVEL)=KAPPA GBCEF405.599
ENDDO GBCEF405.600
ENDDO GBCEF405.601
n_input=LEN_INTF_P*P_LEVELS GBCEF405.602
call rtor_v(n_input,P_TMP_wk,KAPPA_wk,P_TMP_wk) GBCEF405.603
*ELSE PXVECTLB.18
DO LEVEL=1,P_LEVELS PXVECTLB.19
DO I=1,LEN_INTF_P PXVECTLB.20
P_EXNER_HALF_TMP(I,LEVEL)=(P_HALF_TMP_wk(I,LEVEL))**KAPPA PXVECTLB.21
ENDDO PXVECTLB.22
ENDDO PXVECTLB.23
*ENDIF PXVECTLB.24
DO LEVEL=1,P_LEVELS GBCEF405.604
DO I=1,LEN_INTF_P GBCEF405.605
INTF_WORK(I,2+LEVEL)= INTF_WORK(I,2+LEVEL) GBCEF405.606
* *P_TMP_wk(I,LEVEL) GBCEF405.607
ENDDO GBCEF405.608
ENDDO GBCEF405.609
GBCEF405.610
DO LEVEL=1,INTF_P_LEVELS(JINTF) GBCEF405.611
GBCEF405.612
C set up output level pressure GBCEF405.613
DO I=1,LEN_INTF_P GBCEF405.614
P_OUT(I) = GBCEF405.615
& INTF_AK(LEVEL,JINTF)+INTF_PSTAR(I)*INTF_BK(LEVEL,JINTF) GBCEF405.616
ENDDO GBCEF405.617
GBCEF405.618
CALL V_INT(P_TMP,P_OUT,INTF_WORK(1,3),INTF_DATA(IADDR), GBCEF405.619
& LEN_INTF_P,P_LEVELS,TEMP,TEMP,.FALSE., GBCEF405.620
& 1,LEN_INTF_P) GBCEF405.621
GBCEF405.622
C Convert output temperature to theta GBCEF405.623
GBCEF405.624
DO I=1,LEN_INTF_P GBCEF405.625
INTF_DATA(IADDR+I-1) = INTF_DATA(IADDR+I-1) / GBCEF405.626
* P_EXNER_C(P_EXNER_HALF_TMP(I,LEVEL+1), GBCEF405.627
* P_EXNER_HALF_TMP(I,LEVEL),P_HALF_TMP(I,LEVEL+1), GBCEF405.628
* P_HALF_TMP(I,LEVEL),KAPPA) GBCEF405.629
ENDDO GBCEF405.630
GBCEF405.631
IADDR=IADDR+LEN_INTF_P GBCEF405.632
GBCEF405.633
ENDDO GBCEF405.634
GBCEF405.635
ELSE GBCEF405.636
GBCEF405.637
DO LEVEL=1,P_LEVELS GBCEF405.638
DO I=1,LEN_INTF_P GBCEF405.639
INTF_DATA(IADDR+I-1)=INTF_WORK(I,2+LEVEL) GBCEF405.640
ENDDO GBCEF405.641
IADDR=IADDR+LEN_INTF_P GBCEF405.642
ENDDO GBCEF405.643
GBCEF405.644
ENDIF GBCEF405.645
GBCEF405.646
c--collect the interpolated THETA data GBCEF405.647
ptr_data=lbc_address_data(1) GBCEF405.648
call shmem_put( GBCEF405.649
& remote_intf_data(iaddr_theta), GBCEF405.650
& intf_data(iaddr_theta), len_intf_theta_data, 0) GBCEF405.651
GBCEF405.652
*IF DEF,TIME_LBC GBCEF405.653
write(0,*)'Time for Vertical on THETA was ', GBCEF405.654
2 (rtc()-t3)/ticks_per_second GBCEF405.655
*ENDIF GBCEF405.656
ENDIF ! IF (mype .EQ. pe_for_var(3)) GBCEF405.657
GBCEF405.658
GBCEF405.659
iaddr=iaddr_qt GBCEF405.660
IF (mype .EQ. pe_for_var(4)) THEN GBCEF405.661
*IF DEF,TIME_LBC GBCEF405.662
t3=rtc() GBCEF405.663
*ENDIF GBCEF405.664
GBCEF405.665
CL 1.4.2 Vertical interpolation - QT GBCEF405.666
GBCEF405.667
IF (INTF_VERT_INTERP(JINTF)) THEN GBCEF405.668
GBCEF405.669
C input level pressures already calculated for thetal GBCEF405.670
GBCEF405.671
DO LEVEL=1,INTF_Q_LEVELS(JINTF) GBCEF405.672
C set up output level pressure GBCEF405.673
DO I=1,LEN_INTF_P GBCEF405.674
P_OUT(I) = GBCEF405.675
& INTF_AK(LEVEL,JINTF)+INTF_PSTAR(I)*INTF_BK(LEVEL,JINTF) GBCEF405.676
ENDDO GBCEF405.677
GBCEF405.678
CALL V_INT(P_TMP,P_OUT,INTF_WORK(1,3),INTF_DATA(IADDR), GBCEF405.679
& LEN_INTF_P,Q_LEVELS,TEMP,TEMP,.FALSE., GBCEF405.680
& 1,LEN_INTF_P) GBCEF405.681
GBCEF405.682
IADDR=IADDR+LEN_INTF_P GBCEF405.683
GBCEF405.684
ENDDO GBCEF405.685
GBCEF405.686
ELSE GBCEF405.687
GBCEF405.688
DO LEVEL=1,Q_LEVELS GBCEF405.689
DO I=1,LEN_INTF_P GBCEF405.690
INTF_DATA(IADDR+I-1)=INTF_WORK(I,2+LEVEL) GBCEF405.691
ENDDO GBCEF405.692
IADDR=IADDR+LEN_INTF_P GBCEF405.693
ENDDO GBCEF405.694
GBCEF405.695
ENDIF GBCEF405.696
GBCEF405.697
c--collect the interpolated QT data GBCEF405.698
ptr_data=lbc_address_data(1) GBCEF405.699
call shmem_put( GBCEF405.700
& remote_intf_data(iaddr_qt), GBCEF405.701
& intf_data(iaddr_qt), len_intf_qt_data, 0) GBCEF405.702
GBCEF405.703
*IF DEF,TIME_LBC GBCEF405.704
write(0,*)'Time for Vertical on QT was ', GBCEF405.705
2 (rtc()-t3)/ticks_per_second GBCEF405.706
*ENDIF GBCEF405.707
ENDIF ! IF (mype .EQ. pe_for_var(4)) GBCEF405.708
GBCEF405.709
c--ensure that everyone has sent acress their data GBCEF405.710
call barrier() GBCEF405.711
GBCEF405.712
*IF DEF,TIME_LBC GBCEF405.713
if(mype.eq.0) write(0,*)'Time for Vertical Interpolation was ', GBCEF405.714
2 (rtc()-t2)/ticks_per_second GBCEF405.715
GBCEF405.716
if(mype.eq.0) write(0,*)'Time to Collect LBC Variables was ', GBCEF405.717
2 (rtc()-t1)/ticks_per_second GBCEF405.718
*ENDIF GBCEF405.719
GBCEF405.720
c--reset the address for further data (Tracers can be added) GBCEF405.721
iaddr=iaddr_good GBCEF405.722
GBCEF405.723
c--now resume normal processing GBCEF405.724
goto 6000 GBCEF405.725
GBCEF405.726
c--bypass the parallel code if there are not enough processors GBCEF405.727
5000 continue GBCEF405.728
GBCEF405.729
*ENDIF GBCEF405.730
GENINTF1.134
CL 1.1 P Star DR240293.319
GENINTF1.136
*IF DEF,MPP APB4F401.160
CALL GATHER_FIELD(PSTAR,WORK_GLOBAL, APB4F401.161
& lasize(1),lasize(2), APB4F401.162
& glsize(1),glsize(2), APB4F401.163
& 0,GC_ALL_PROC_GROUP, GPB0F402.187
& info) APB4F401.165
APB4F401.166
IF (mype .EQ. 0) THEN APB4F401.167
*ENDIF APB4F401.168
CL 1.1.1 Horizontal interpolation DR240293.320
*IF -DEF,MPP APB4F401.169
CALL H_INT_BL(P_ROWS,ROW_LENGTH,LEN_INTF_P UDG1F400.328
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P),PSTAR UDG1F400.329
*ELSE APB4F401.170
CALL H_INT_BL(glsize(2),glsize(1),LEN_INTF_P APB4F401.171
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P),WORK_GLOBAL APB4F401.172
*ENDIF APB4F401.173
&, AP_WEIGHT_B_L(IP_P),AP_WEIGHT_B_R(IP_P) UDG1F400.330
&, AP_WEIGHT_T_L(IP_P),AP_WEIGHT_T_R(IP_P) APB4F401.174
&, INTF_DATA(IADDR)) APB4F401.175
GDR1F400.54
GENINTF1.138
CL 1.1.2 Save pstar for vertical interpolation DR240293.328
IF (INTF_VERT_INTERP(JINTF)) THEN DR240293.329
GENINTF1.140
DO I=1,LEN_INTF_P DR240293.330
INTF_PSTAR(I)=INTF_DATA(IADDR+I-1) APB4F401.176
ENDDO DR240293.332
ENDIF DR240293.333
*IF DEF,MPP APB4F401.177
APB4F401.178
ENDIF ! IF (mype .EQ. 0) APB4F401.179
*ENDIF APB4F401.180
DR240293.334
IADDR=IADDR+LEN_INTF_P APB4F401.181
APB4F401.182
DO LEVEL=1,P_LEVELS DR240293.335
DR240293.336
CL 1.2 U and V components DR240293.337
DR240293.338
CL 1.2.1 Rotate winds to standard lat-lon if input grid is rotated. DR240293.339
DR240293.340
IF (ROT_IN) THEN DR240293.341
DR240293.342
CALL W_EQTOLL(COEFF3,COEFF4,U(1,LEVEL),V(1,LEVEL), DR240293.343
& U_TEMP,V_TEMP,U_FIELD,U_FIELD) UIE2F401.486
GENINTF1.143
ELSE GENINTF1.144
GENINTF1.145
DO I=1,U_FIELD GENINTF1.146
*IF DEF,T3E,AND,DEF,MPP GBCEF405.731
u_temp(i, 1)=u(i, level) GBCEF405.732
v_temp(i, 1)=v(i, level) GBCEF405.733
*ELSE GBCEF405.734
U_TEMP(I)=U(I,LEVEL) DR240293.344
V_TEMP(I)=V(I,LEVEL) DR240293.345
*ENDIF GBCEF405.735
ENDDO GENINTF1.149
GENINTF1.150
ENDIF GENINTF1.151
GENINTF1.152
CL 1.2.2 Horizontal interpolation - winds DR240293.346
*IF DEF,MPP APB4F401.183
CALL GATHER_FIELD(U_TEMP,WORK_GLOBAL, APB4F401.184
& lasize(1),lasize(2), APB4F401.185
& glsize(1),glsize(2)-1, APB4F401.186
& 0,GCG_ALL, APB4F401.187
& info) APB4F401.188
APB4F401.189
IF (mype .EQ. 0) THEN APB4F401.190
*ENDIF APB4F401.191
GENINTF1.154
*IF -DEF,MPP APB4F401.192
CALL H_INT_BL(U_ROWS,ROW_LENGTH,LEN_INTF_U UDG1F400.332
&, AU_INDEX_B_L(IP_U),AU_INDEX_B_R(IP_U),U_TEMP UDG1F400.333
*ELSE APB4F401.193
CALL H_INT_BL(glsize(2)-1,glsize(1),LEN_INTF_U APB4F401.194
&, AU_INDEX_B_L(IP_U),AU_INDEX_B_R(IP_U),WORK_GLOBAL APB4F401.195
*ENDIF APB4F401.196
&, AU_WEIGHT_B_L(IP_U),AU_WEIGHT_B_R(IP_U) UDG1F400.334
&, AU_WEIGHT_T_L(IP_U),AU_WEIGHT_T_R(IP_U) UDG1F400.335
&, INTF_WORK(1,1)) UDG1F400.336
*IF DEF,MPP APB4F401.197
ENDIF ! IF (mype .EQ. 0) APB4F401.198
APB4F401.199
CALL GATHER_FIELD(V_TEMP,WORK_GLOBAL, APB4F401.200
& lasize(1),lasize(2), APB4F401.201
& glsize(1),glsize(2)-1, APB4F401.202
& 0,GC_ALL_PROC_GROUP, GPB0F402.188
& info) APB4F401.204
APB4F401.205
IF (mype .EQ. 0) THEN APB4F401.206
*ENDIF APB4F401.207
GENINTF1.158
*IF -DEF,MPP APB4F401.208
CALL H_INT_BL(U_ROWS,ROW_LENGTH,LEN_INTF_U UDG1F400.337
&, AU_INDEX_B_L(IP_U),AU_INDEX_B_R(IP_U),V_TEMP UDG1F400.338
*ELSE APB4F401.209
CALL H_INT_BL(glsize(2)-1,glsize(1),LEN_INTF_U APB4F401.210
&, AU_INDEX_B_L(IP_U),AU_INDEX_B_R(IP_U),WORK_GLOBAL APB4F401.211
*ENDIF APB4F401.212
&, AU_WEIGHT_B_L(IP_U),AU_WEIGHT_B_R(IP_U) UDG1F400.339
&, AU_WEIGHT_T_L(IP_U),AU_WEIGHT_T_R(IP_U) UDG1F400.340
&, INTF_WORK(1,2)) UDG1F400.341
GENINTF1.162
CALL W_LLTOEQ(COEFF1(IP_U),COEFF2(IP_U), DR240293.355
& INTF_WORK(1,1),INTF_WORK(1,2), DR240293.356
& INTF_WORK(1,2+LEVEL),INTF_WORK(1,2+LEVEL+P_LEVELS), DR240293.357
& LEN_INTF_U,LEN_INTF_U) UIE2F401.485
*IF DEF,MPP APB4F401.213
APB4F401.214
ENDIF ! IF (mype .EQ. 0) APB4F401.215
*ENDIF APB4F401.216
GENINTF1.166
ENDDO DR240293.359
*IF DEF,MPP APB4F401.217
APB4F401.218
IF (mype .EQ. 0) THEN APB4F401.219
*ENDIF APB4F401.220
GENINTF1.168
CL 1.2.3 Vertical interpolation - winds DR240293.360
GENINTF1.169
IF (INTF_VERT_INTERP(JINTF)) THEN DR240293.361
GENINTF1.173
C set up input level pressures GENINTF1.174
C set up for P points and call V_INT for p points with zero data in GENINTF1.175
C extra non U points GENINTF1.176
DO LEVEL=1,P_LEVELS DR240293.362
DO I=1,LEN_INTF_P DR240293.363
P_TMP(I,LEVEL) = AK(LEVEL) + INTF_PSTAR(I)*BK(LEVEL) DR240293.364
ENDDO GENINTF1.181
ENDDO DR240293.365
DR240293.366
DO LEVEL=1,P_LEVELS DR240293.367
DO I=LEN_INTF_U+1,LEN_INTF_P DR240293.368
INTF_WORK(I,2+LEVEL) = 0.0 GENINTF1.185
INTF_WORK(I,2+LEVEL+P_LEVELS) = 0.0 GENINTF1.186
ENDDO GENINTF1.187
ENDDO DR240293.369
GENINTF1.189
DO LEVEL=1,INTF_P_LEVELS(JINTF) DR240293.370
C set up output level pressure GENINTF1.191
DO I=1,LEN_INTF_P DR240293.371
P_OUT(I) = DR240293.372
& INTF_AK(LEVEL,JINTF)+ INTF_PSTAR(I)*INTF_BK(LEVEL,JINTF) DR240293.373
ENDDO GENINTF1.194
GENINTF1.195
CALL V_INT(P_TMP,P_OUT,INTF_WORK(1,3),INTF_WORK(1,1), GENINTF1.196
& LEN_INTF_P,P_LEVELS,TEMP,TEMP,.FALSE. GSM1F405.735
& ,1,LEN_INTF_P) GSM1F405.736
GENINTF1.198
CALL V_INT(P_TMP,P_OUT,INTF_WORK(1,3+P_LEVELS),INTF_WORK(1,2), GENINTF1.199
& LEN_INTF_P,P_LEVELS,TEMP,TEMP,.FALSE. GSM1F405.737
& ,1,LEN_INTF_P) GSM1F405.738
GENINTF1.201
IADDR_V = IADDR + INTF_P_LEVELS(JINTF)*LEN_INTF_U APB4F401.221
DO I=1,LEN_INTF_U APB4F401.222
INTF_DATA(IADDR+I-1) = INTF_WORK(I,1) APB4F401.223
INTF_DATA(IADDR_V+I-1) = INTF_WORK(I,2) APB4F401.224
ENDDO APB4F401.225
APB4F401.226
IADDR = IADDR + LEN_INTF_U APB4F401.227
GENINTF1.208
ENDDO DR240293.382
GDR1F400.86
IADDR = IADDR + INTF_P_LEVELS(JINTF)*LEN_INTF_U APB4F401.228
GENINTF1.210
ELSE GENINTF1.211
GENINTF1.212
DO LEVEL=1,P_LEVELS GENINTF1.213
GDR1F400.92
DO I=1,LEN_INTF_U APB4F401.229
INTF_DATA(IADDR+I-1) = INTF_WORK(I,2+LEVEL) APB4F401.230
ENDDO APB4F401.231
IADDR_V = IADDR + P_LEVELS*LEN_INTF_U APB4F401.232
DO I=1,LEN_INTF_U APB4F401.233
INTF_DATA(IADDR_V+I-1)=INTF_WORK(I,2+LEVEL+P_LEVELS) APB4F401.234
ENDDO APB4F401.235
IADDR = IADDR + LEN_INTF_U APB4F401.236
GDR1F400.114
ENDDO GENINTF1.220
GENINTF1.221
IADDR = IADDR + P_LEVELS*LEN_INTF_U APB4F401.237
GDR1F400.120
ENDIF GENINTF1.222
*IF DEF,MPP APB4F401.238
ENDIF ! IF (mype .EQ. 0) APB4F401.239
APB4F401.240
*ENDIF APB4F401.241
GENINTF1.225
CL 1.3 THETAL DR240293.390
GENINTF1.227
CL 1.3.1 Horizontal interpolation - thetal DR240293.391
DO LEVEL=1,P_LEVELS DR240293.392
GENINTF1.231
*IF DEF,MPP APB4F401.242
CALL GATHER_FIELD(THETA(1,LEVEL),WORK_GLOBAL, APB4F401.243
& lasize(1),lasize(2), APB4F401.244
& glsize(1),glsize(2), APB4F401.245
& 0,GC_ALL_PROC_GROUP, GPB0F402.189
& info) APB4F401.247
APB4F401.248
IF (mype .EQ. 0) THEN APB4F401.249
*ENDIF APB4F401.250
APB4F401.251
*IF -DEF,MPP APB4F401.252
CALL H_INT_BL(P_ROWS,ROW_LENGTH,LEN_INTF_P UDG1F400.342
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P),THETA(1,LEVEL) UDG1F400.343
*ELSE APB4F401.253
CALL H_INT_BL(glsize(2),glsize(1),LEN_INTF_P APB4F401.254
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P),WORK_GLOBAL APB4F401.255
*ENDIF APB4F401.256
&, AP_WEIGHT_B_L(IP_P),AP_WEIGHT_B_R(IP_P) UDG1F400.344
&, AP_WEIGHT_T_L(IP_P),AP_WEIGHT_T_R(IP_P) UDG1F400.345
&, INTF_WORK(1,2+LEVEL)) UDG1F400.346
*IF DEF,MPP APB4F401.257
ENDIF ! IF (mype .EQ. 0) APB4F401.258
APB4F401.259
*ENDIF APB4F401.260
GENINTF1.233
ENDDO DR240293.398
DR240293.399
*IF DEF,MPP APB4F401.261
APB4F401.262
IF (mype .EQ. 0) THEN APB4F401.263
*ENDIF APB4F401.264
CL 1.3.2 Vertical interpolation - thetal DR240293.400
IF(INTF_VERT_INTERP(JINTF)) THEN DR240293.401
GENINTF1.236
C input level pressures already set up for winds GENINTF1.237
GENINTF1.238
C Calculate pressure and exner pressure at output half levels GENINTF1.239
DO LEVEL=1,INTF_P_LEVELS(JINTF)+1 DR240293.402
DO I=1,LEN_INTF_P DR240293.403
P_HALF_TMP(I,LEVEL)= GENINTF1.242
& INTF_AKH(LEVEL,JINTF)+INTF_BKH(LEVEL,JINTF)*INTF_PSTAR(I) DR240293.404
P_HALF_TMP_wk(I,LEVEL)=(P_HALF_TMP(I,LEVEL)/PREF) GSS9F402.102
ENDDO GENINTF1.246
ENDDO GENINTF1.247
*IF DEF,VECTLIB PXVECTLB.25
DO LEVEL=1,INTF_P_LEVELS(JINTF)+1 GSS9F402.104
DO I=1,LEN_INTF_P GSS9F402.105
KAPPA_HALF_wk(I,LEVEL)=KAPPA GSS9F402.106
ENDDO GSS9F402.107
ENDDO GSS9F402.108
n_input=LEN_INTF_P*(INTF_P_LEVELS(JINTF)+1) GSS9F402.109
call rtor_v GSS9F402.110
& (n_input,P_HALF_TMP_wk,KAPPA_HALF_wk,P_EXNER_HALF_TMP) GSS9F402.111
*ELSE GSS9F402.112
DO LEVEL=1,INTF_P_LEVELS(JINTF)+1 GSS9F402.113
DO I=1,LEN_INTF_P GSS9F402.114
P_EXNER_HALF_TMP(I,LEVEL)=(P_HALF_TMP_wk(I,LEVEL))**KAPPA GSS9F402.115
ENDDO GSS9F402.116
ENDDO GSS9F402.117
*ENDIF GSS9F402.118
GENINTF1.248
C Convert input theta to temperature GENINTF1.249
DO LEVEL=1,P_LEVELS GENINTF1.250
DO I=1,LEN_INTF_P DR240293.405
P_TMP_wk(I,LEVEL)=P_TMP(I,LEVEL)/PREF GSS9F402.119
ENDDO GSS9F402.120
ENDDO GSS9F402.121
*IF DEF,VECTLIB PXVECTLB.26
DO LEVEL=1,P_LEVELS GSS9F402.123
DO I=1,LEN_INTF_P GSS9F402.124
KAPPA_wk(I,LEVEL)=KAPPA GSS9F402.125
ENDDO GSS9F402.126
ENDDO GSS9F402.127
n_input=LEN_INTF_P*P_LEVELS GSS9F402.128
call rtor_v(n_input,P_TMP_wk,KAPPA_wk,P_TMP_wk) GSS9F402.129
*ELSE GSS9F402.130
DO LEVEL=1,P_LEVELS GSS9F402.131
DO I=1,LEN_INTF_P GSS9F402.132
P_TMP_wk(I,LEVEL)=P_TMP_wk(I,LEVEL)**KAPPA GSS9F402.133
ENDDO GSS9F402.134
ENDDO GSS9F402.135
*ENDIF GSS9F402.136
DO LEVEL=1,P_LEVELS GSS9F402.137
DO I=1,LEN_INTF_P GSS9F402.138
INTF_WORK(I,2+LEVEL)= INTF_WORK(I,2+LEVEL) GENINTF1.252
* *P_TMP_wk(I,LEVEL) GSS9F402.139
ENDDO GENINTF1.254
ENDDO GENINTF1.255
GENINTF1.256
DO LEVEL=1,INTF_P_LEVELS(JINTF) DR240293.406
GENINTF1.258
C set up output level pressure GENINTF1.259
DO I=1,LEN_INTF_P DR240293.407
P_OUT(I) = DR240293.408
& INTF_AK(LEVEL,JINTF)+INTF_PSTAR(I)*INTF_BK(LEVEL,JINTF) DR240293.409
ENDDO GENINTF1.262
GENINTF1.263
CALL V_INT(P_TMP,P_OUT,INTF_WORK(1,3),INTF_DATA(IADDR), APB4F401.265
& LEN_INTF_P,P_LEVELS,TEMP,TEMP,.FALSE. GSM1F405.739
& ,1,LEN_INTF_P) GSM1F405.740
GENINTF1.266
GSM1F405.741
C Convert output temperature to theta GENINTF1.267
GENINTF1.268
DO I=1,LEN_INTF_P DR240293.411
INTF_DATA(IADDR+I-1) = INTF_DATA(IADDR+I-1) / APB4F401.266
* P_EXNER_C(P_EXNER_HALF_TMP(I,LEVEL+1), GENINTF1.271
* P_EXNER_HALF_TMP(I,LEVEL),P_HALF_TMP(I,LEVEL+1), GENINTF1.272
* P_HALF_TMP(I,LEVEL),KAPPA) GENINTF1.273
ENDDO GENINTF1.274
GENINTF1.275
IADDR=IADDR+LEN_INTF_P APB4F401.267
GENINTF1.279
ENDDO DR240293.415
GENINTF1.281
ELSE GENINTF1.282
GENINTF1.283
DO LEVEL=1,P_LEVELS GENINTF1.284
DO I=1,LEN_INTF_P APB4F401.268
INTF_DATA(IADDR+I-1)=INTF_WORK(I,2+LEVEL) APB4F401.269
ENDDO APB4F401.270
IADDR=IADDR+LEN_INTF_P APB4F401.271
ENDDO GENINTF1.288
GENINTF1.289
ENDIF GENINTF1.290
*IF DEF,MPP APB4F401.272
ENDIF ! IF (mype .EQ. 0) APB4F401.273
APB4F401.274
*ENDIF APB4F401.275
GENINTF1.291
CL 1.4 QT DR240293.419
GENINTF1.293
CL 1.4.1 Horizontal interpolation - QT DR240293.420
DO LEVEL=1,Q_LEVELS DR240293.421
GENINTF1.297
*IF DEF,MPP APB4F401.276
CALL GATHER_FIELD(Q(1,LEVEL),WORK_GLOBAL, APB4F401.277
& lasize(1),lasize(2), APB4F401.278
& glsize(1),glsize(2), APB4F401.279
& 0,GC_ALL_PROC_GROUP, GPB0F402.190
& info) APB4F401.281
APB4F401.282
IF (mype .EQ. 0) THEN APB4F401.283
*ENDIF APB4F401.284
APB4F401.285
*IF -DEF,MPP APB4F401.286
CALL H_INT_BL(P_ROWS,ROW_LENGTH,LEN_INTF_P UDG1F400.347
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P),Q(1,LEVEL) UDG1F400.348
*ELSE APB4F401.287
CALL H_INT_BL(glsize(2),glsize(1),LEN_INTF_P APB4F401.288
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P),WORK_GLOBAL APB4F401.289
*ENDIF APB4F401.290
&, AP_WEIGHT_B_L(IP_P),AP_WEIGHT_B_R(IP_P) UDG1F400.349
&, AP_WEIGHT_T_L(IP_P),AP_WEIGHT_T_R(IP_P) UDG1F400.350
&, INTF_WORK(1,2+LEVEL)) UDG1F400.351
GENINTF1.299
*IF DEF,MPP APB4F401.291
ENDIF ! IF (mype .EQ. 0) APB4F401.292
APB4F401.293
*ENDIF APB4F401.294
ENDDO DR240293.427
*IF DEF,MPP APB4F401.295
APB4F401.296
IF (mype .EQ. 0) THEN APB4F401.297
*ENDIF APB4F401.298
DR240293.428
CL 1.4.2 Vertical interpolation - QT DR240293.429
IF (INTF_VERT_INTERP(JINTF)) THEN DR240293.430
GENINTF1.302
C input level pressures already calculated for thetal GENINTF1.303
GENINTF1.304
DO LEVEL=1,INTF_Q_LEVELS(JINTF) DR240293.431
C set up output level pressure GENINTF1.306
DO I=1,LEN_INTF_P DR240293.432
P_OUT(I) = DR240293.433
& INTF_AK(LEVEL,JINTF)+INTF_PSTAR(I)*INTF_BK(LEVEL,JINTF) DR240293.434
ENDDO GENINTF1.309
GENINTF1.310
CALL V_INT(P_TMP,P_OUT,INTF_WORK(1,3),INTF_DATA(IADDR), APB4F401.299
& LEN_INTF_P,Q_LEVELS,TEMP,TEMP,.FALSE. GSM1F405.742
& ,1,LEN_INTF_P) GSM1F405.743
GENINTF1.313
IADDR=IADDR+LEN_INTF_P APB4F401.300
GENINTF1.314
ENDDO DR240293.439
GENINTF1.320
ELSE GENINTF1.321
GENINTF1.322
DO LEVEL=1,Q_LEVELS GENINTF1.323
DO I=1,LEN_INTF_P APB4F401.301
INTF_DATA(IADDR+I-1)=INTF_WORK(I,2+LEVEL) APB4F401.302
ENDDO APB4F401.303
IADDR=IADDR+LEN_INTF_P APB4F401.304
ENDDO GENINTF1.327
GENINTF1.328
ENDIF GENINTF1.329
*IF DEF,MPP APB4F401.305
ENDIF ! IF (mype .EQ. 0) APB4F401.306
APB4F401.307
*ENDIF APB4F401.308
GENINTF1.330
CL 1.5 TRACERS DR240293.443
*IF DEF,T3E,AND,DEF,MPP GBCEF405.736
GBCEF405.737
c--resume collective processing GBCEF405.738
6000 continue GBCEF405.739
GBCEF405.740
*ENDIF GBCEF405.741
GENINTF1.331
IF (TR_VARS.GT.0) THEN GENINTF1.332
GENINTF1.335
DO VAR=1,TR_VARS DR240293.444
GENINTF1.340
CL 1.5.1 Horizontal interpolation - tracers DR240293.445
GENINTF1.342
DO LEVEL=1,TR_LEVELS DR240293.446
DR240293.447
*IF DEF,MPP APB4F401.309
CALL GATHER_FIELD(TRACER(VAR,LEVEL),WORK_GLOBAL, APB4F401.310
& lasize(1),lasize(2), APB4F401.311
& glsize(1),glsize(2), APB4F401.312
& 0,GC_ALL_PROC_GROUP, GPB0F402.191
& info) APB4F401.314
APB4F401.315
IF (mype .EQ. 0) THEN APB4F401.316
APB4F401.317
*ENDIF APB4F401.318
APB4F401.319
*IF -DEF,MPP APB4F401.320
CALL H_INT_BL(P_ROWS,ROW_LENGTH,LEN_INTF_P UDG1F400.352
*ELSE APB4F401.321
CALL H_INT_BL(glsize(2),glsize(1),LEN_INTF_P APB4F401.322
*ENDIF APB4F401.323
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P) UDG1F400.353
*IF -DEF,MPP APB4F401.324
&, TRACER((VAR-1)*P_FIELD+1,LEVEL) UDG1F400.354
*ELSE APB4F401.325
&, WORK_GLOBAL APB4F401.326
*ENDIF APB4F401.327
&, AP_WEIGHT_B_L(IP_P),AP_WEIGHT_B_R(IP_P) UDG1F400.355
&, AP_WEIGHT_T_L(IP_P),AP_WEIGHT_T_R(IP_P) UDG1F400.356
&, INTF_WORK(1,2+LEVEL)) UDG1F400.357
DR240293.453
*IF DEF,MPP APB4F401.328
ENDIF ! IF (mype .EQ. 0) APB4F401.329
APB4F401.330
*ENDIF APB4F401.331
APB4F401.332
ENDDO DR240293.454
*IF DEF,MPP APB4F401.333
APB4F401.334
IF (mype .EQ. 0) THEN APB4F401.335
*ENDIF APB4F401.336
DR240293.455
CL 1.5.2 Vertical interpolation - tracers DR240293.456
DR240293.457
IF (INTF_VERT_INTERP(JINTF)) THEN DR240293.458
GENINTF1.345
C input level pressures already calculated GENINTF1.346
GENINTF1.347
DO LEVEL=INTF_P_LEVELS(JINTF)-INTF_TR_LEVELS(JINTF)+1, DR240293.459
& INTF_P_LEVELS(JINTF) GDR2F400.4
C set up output level pressure GENINTF1.349
DO I=1,LEN_INTF_P DR240293.461
P_OUT(I) = DR240293.462
& INTF_AK(LEVEL,JINTF)+INTF_PSTAR(I)*INTF_BK(LEVEL,JINTF) DR240293.463
ENDDO GENINTF1.352
GENINTF1.353
CALL V_INT(P_TMP(1,P_LEVELS-TR_LEVELS+1), DR240293.464
& P_OUT,INTF_WORK(1,3),INTF_DATA(IADDR), APB4F401.337
& LEN_INTF_P,TR_LEVELS,TEMP,TEMP,.FALSE. GSM1F405.744
& ,1,LEN_INTF_P) GSM1F405.745
GENINTF1.357
IADDR=IADDR+LEN_INTF_P APB4F401.338
DR240293.469
ENDDO DR240293.470
GENINTF1.363
ELSE GENINTF1.364
GENINTF1.365
DO LEVEL=1,TR_LEVELS GENINTF1.366
DO I=1,LEN_INTF_P APB4F401.339
INTF_DATA(IADDR+I-1)=INTF_WORK(I,2+LEVEL) APB4F401.340
ENDDO APB4F401.341
IADDR=IADDR+LEN_INTF_P APB4F401.342
ENDDO GENINTF1.370
ENDIF GENINTF1.372
*IF DEF,MPP APB4F401.343
ENDIF ! IF (mype .EQ. 0) APB4F401.344
APB4F401.345
*ENDIF APB4F401.346
GENINTF1.373
ENDDO DR240293.474
ENDIF GENINTF1.375
GENINTF1.376
CL 1.6 QCF ARB1F404.251
ARB1F404.252
IF (L_LSPICE) THEN ! mixed phase precipitation scheme ARB1F404.253
ARB1F404.254
CL 1.6.1 Horizontal interpolation - QCF ARB1F404.255
DO LEVEL=1,Q_LEVELS ARB1F404.256
ARB1F404.257
*IF DEF,MPP ARB1F404.258
CALL GATHER_FIELD(QCF(1,LEVEL),WORK_GLOBAL, ARB1F404.259
& lasize(1),lasize(2), ARB1F404.260
& glsize(1),glsize(2), ARB1F404.261
& 0,GC_ALL_PROC_GROUP, ARB1F404.262
& info) ARB1F404.263
ARB1F404.264
IF (mype .EQ. 0) THEN ARB1F404.265
*ENDIF ARB1F404.266
ARB1F404.267
*IF -DEF,MPP ARB1F404.268
CALL H_INT_BL(P_ROWS,ROW_LENGTH,LEN_INTF_P ARB1F404.269
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P),QCF(1,LEVEL) ARB1F404.270
*ELSE ARB1F404.271
CALL H_INT_BL(glsize(2),glsize(1),LEN_INTF_P ARB1F404.272
&, AP_INDEX_B_L(IP_P),AP_INDEX_B_R(IP_P),WORK_GLOBAL ARB1F404.273
*ENDIF ARB1F404.274
&, AP_WEIGHT_B_L(IP_P),AP_WEIGHT_B_R(IP_P) ARB1F404.275
&, AP_WEIGHT_T_L(IP_P),AP_WEIGHT_T_R(IP_P) ARB1F404.276
&, INTF_WORK(1,2+LEVEL)) ARB1F404.277
ARB1F404.278
*IF DEF,MPP ARB1F404.279
ENDIF ! IF (mype .EQ. 0) ARB1F404.280
ARB1F404.281
*ENDIF ARB1F404.282
ENDDO ARB1F404.283
*IF DEF,MPP ARB1F404.284
ARB1F404.285
IF (mype .EQ. 0) THEN ARB1F404.286
*ENDIF ARB1F404.287
ARB1F404.288
CL 1.6.2 Vertical interpolation - QCF ARB1F404.289
IF (INTF_VERT_INTERP(JINTF)) THEN ARB1F404.290
ARB1F404.291
C input level pressures already calculated for thetal ARB1F404.292
ARB1F404.293
DO LEVEL=1,INTF_Q_LEVELS(JINTF) ARB1F404.294
C set up output level pressure ARB1F404.295
DO I=1,LEN_INTF_P ARB1F404.296
P_OUT(I) = ARB1F404.297
& INTF_AK(LEVEL,JINTF)+INTF_PSTAR(I)*INTF_BK(LEVEL,JINTF) ARB1F404.298
ENDDO ARB1F404.299
ARB1F404.300
CALL V_INT(P_TMP,P_OUT,INTF_WORK(1,3),INTF_DATA(IADDR), ARB1F404.301
& LEN_INTF_P,Q_LEVELS,TEMP,TEMP,.FALSE. GSM1F405.746
& ,1,LEN_INTF_P) GSM1F405.747
ARB1F404.303
IADDR=IADDR+LEN_INTF_P ARB1F404.304
ARB1F404.305
ENDDO ARB1F404.306
ARB1F404.307
ELSE ARB1F404.308
ARB1F404.309
DO LEVEL=1,Q_LEVELS ARB1F404.310
DO I=1,LEN_INTF_P ARB1F404.311
INTF_DATA(IADDR+I-1)=INTF_WORK(I,2+LEVEL) ARB1F404.312
ENDDO ARB1F404.313
IADDR=IADDR+LEN_INTF_P ARB1F404.314
ENDDO ARB1F404.315
ARB1F404.316
ENDIF ARB1F404.317
*IF DEF,MPP ARB1F404.318
ENDIF ! IF (mype .EQ. 0) ARB1F404.319
ARB1F404.320
*ENDIF ARB1F404.321
END IF ! IF (L_LSPICE) - mixed phase precip scheme ARB1F404.322
ARB1F404.323
CL 2.0 Update Information in Headers DR240293.475
GENINTF1.377
CL Open boundary output file if reinitialised during run DR240293.476
DR240293.477
IF (FT_STEPS(NFTOUT).GT.0) THEN GENINTF1.383
STRING=MODEL_FT_UNIT(NFTOUT) GENINTF1.384
PPNAME=STRING(18:31) GENINTF1.385
LEN_PPNAME=LEN(PPNAME) GENINTF1.386
CALL FILE_OPEN(NFTOUT,PPNAME,LEN_PPNAME,1,1,ICODE) GPB1F305.36
IF (ICODE.NE.0) THEN DR240293.478
CMESSAGE="GEN_INTF: Error opening preassigned boundary file" DR240293.479
GO TO 999 ! Return DR240293.480
ENDIF DR240293.481
GENINTF1.389
C Determine position where to Buffer out data to DR240293.482
GENINTF1.391
NTIME=FT_LASTFIELD(NFTOUT)+1 GENINTF1.392
ELSE GENINTF1.393
NTIME=FT_LASTFIELD(NFTOUT)+1 GENINTF1.394
C A_IO=UNIT(NFTOUT) ! Only valid with CRAY-specific BUFFER IN/OUT RB120293.2
GENINTF1.396
ENDIF GENINTF1.397
GENINTF1.398
CL 2.1 Fixed length header DR240293.483
FIXHD_INTFA(152,JINTF) = INTF_LOOKUPSA*NTIME DR240293.484
FIXHD_INTFA(161,JINTF) = LEN_INTF_DATA*NTIME GDG2F304.4
GENINTF1.400
CL 2.2 Integer Constants DR240293.486
INTHD_INTFA(3,JINTF) = NTIME DR240293.487
DR240293.488
CL 2.3 LOOKUP Table APB4F401.355
APB4F401.356
C Determine position in LOOKUP table DR240293.490
LOOKUP_START=FIXHD_INTFA(150,JINTF) + DR240293.491
& FIXHD_INTFA(151,JINTF)*INTF_LOOKUPSA*(NTIME-1) - 1 DR240293.492
DR240293.493
c GBC5F404.62
c--for well-formed I/O, we must read back the GBC5F404.63
c last lookup table entry on disk GBC5F404.64
c GBC5F404.65
if(ntime.ne.1) then GBC5F404.66
call setpos(nftout, lookup_start-len1_lookup, icode) GBC5F404.67
call buffin(nftout, lookup_intfa(1, 1, jintf), len1_lookup, GBC5F404.68
& len_io, a_io) GBC5F404.69
c--check for errors GBC5F404.70
if(a_io.ne.-1.0 .or. len_io.ne.len1_lookup) then GBC5F404.71
call ioerror('GEN_INTF_A: Buffer in of Last Lookup Header', GBC5F404.72
& a_io, len_io, len1_lookup) GBC5F404.73
cmessage=' GEN_INTF_A: I/O Error on Read' GBC5F404.74
icode=5 GBC5F404.75
goto 999 GBC5F404.76
endif GBC5F404.77
c--compute the new disk address from the last address and length GBC5F404.78
disk_address=lookup_intfa(lbegin, 1, jintf)+ GBC5F404.79
& lookup_intfa(lbnrec, 1, jintf) GBC5F404.80
else GBC5F404.81
disk_address=fixhd_intfa(160, jintf)-1 GBC5F404.82
endif GBC5F404.83
c--round this disk to ensure we start on a sector boundary GBC5F404.84
disk_address=((disk_address+um_sector_size-1)/ GBC5F404.85
& um_sector_size)*um_sector_size GBC5F404.86
c--zero the maximum output record size GBC5F404.87
len_buf=0 GBC5F404.88
C Check that there is enough space for this entry in LOOKUP table DR240293.494
IF (FIXHD_INTFA(150,JINTF)+ DR240293.495
& FIXHD_INTFA(151,JINTF)*FIXHD_INTFA(152,JINTF).GT. DR240293.496
& FIXHD_INTFA(160,JINTF)) THEN DR240293.497
CMESSAGE=' GEN_INTF: Insufficient space for headers in boundary DR240293.498
& dataset.' DR240293.499
ICODE=1 GENINTF1.411
GO TO 999 ! Return DR240293.500
ENDIF DR240293.501
GENINTF1.414
START_ADDR = FIXHD_INTFA(161,JINTF)-LEN_INTF_DATA+1 APB4F401.357
APB4F401.358
DO VAR=1,INTF_LOOKUPSA DR240293.502
GENINTF1.415
C Set STASHCODE for variable required for interfacing DR240293.503
DR240293.504
CODE=ITEM_INTFA(VAR) DR240293.505
DR240293.506
DO I=1,LEN1_LOOKUP DR240293.507
LOOKUP_INTFA(I,VAR,JINTF)=A_LOOKUP(I,PPINDEX(CODE,im_index)) APB4F401.359
ENDDO DR240293.509
DR240293.510
SEC = STEPim(a_im) * SECS_PER_PERIODim(a_im) / GDR3F305.203
& STEPS_PER_PERIODim(a_im) GDR3F305.204
DR240293.512
CALL SEC2TIME(0,SEC,BASIS_TIME_DAYS,BASIS_TIME_SECS, TJ080294.259
& YY,MM,DD,HR,MN,SS,DAY_NO,LCAL360) GSS1F304.330
DR240293.514
C Validity time of this field DR240293.515
LOOKUP_INTFA(LBYR ,VAR,JINTF) = YY DR240293.516
LOOKUP_INTFA(LBMON,VAR,JINTF) = MM DR240293.517
LOOKUP_INTFA(LBDAT,VAR,JINTF) = DD DR240293.518
LOOKUP_INTFA(LBHR ,VAR,JINTF) = HR DR240293.519
LOOKUP_INTFA(LBMIN,VAR,JINTF) = MN DR240293.520
LOOKUP_INTFA(LBDAY,VAR,JINTF) = DAY_NO DR240293.521
DR240293.522
LOOKUP_INTFA(LBYRD ,VAR,JINTF) = A_FIXHD(21) DR240293.523
LOOKUP_INTFA(LBMOND,VAR,JINTF) = A_FIXHD(22) DR240293.524
LOOKUP_INTFA(LBDATD,VAR,JINTF) = A_FIXHD(23) DR240293.525
LOOKUP_INTFA(LBHRD ,VAR,JINTF) = A_FIXHD(24) DR240293.526
LOOKUP_INTFA(LBMIND,VAR,JINTF) = A_FIXHD(25) DR240293.527
LOOKUP_INTFA(LBDAYD,VAR,JINTF) = A_FIXHD(27) DR240293.528
DR240293.529
!! GENERALISED FOR MIXED PHASE PRECIP SCHEME ARB1F404.324
IF(VAR.EQ.1) THEN DR240293.530
LEN_DATA = LEN_INTF_P DR240293.531
ELSE IF(VAR.EQ.2.OR.VAR.EQ.3) THEN DR240293.532
LEN_DATA = LEN_INTF_U*INTF_P_LEVELS(JINTF) DR240293.533
ELSE IF(VAR.EQ.4) THEN DR240293.534
LEN_DATA = LEN_INTF_P*INTF_P_LEVELS(JINTF) DR240293.535
ELSE IF(VAR.EQ.5) THEN DR240293.536
LEN_DATA = LEN_INTF_P*INTF_Q_LEVELS(JINTF) DR240293.537
ELSE IF(VAR.GT.5 .AND. CODE.GT.60) THEN ARB1F404.325
LEN_DATA = LEN_INTF_P*INTF_TR_LEVELS(JINTF) DR240293.539
ELSE IF(VAR.GT.5 .AND. CODE.EQ.12) THEN ARB1F404.326
LEN_DATA = LEN_INTF_P*INTF_Q_LEVELS(JINTF) ARB1F404.327
END IF DR240293.540
LOOKUP_INTFA(LBLREC,VAR,JINTF) = LEN_DATA DR240293.541
C New packing information from UM Version 2.8 DR240293.542
N1 = 0 ! Data not packed GDR1F400.181
IF (LPACK_32B) N1 = 2 ! Data packed as 32 bits GDR1F400.182
IF (LPACK_PPXREF) THEN APB4F401.360
N1 = EXPPXI(atmos_im,0,item_intfa(var),ppx_dump_packing, APB4F401.361
*CALL ARGPPX APB4F401.362
& icode,cmessage) APB4F401.363
ENDIF APB4F401.364
N2 = 0 ! Data not compressed DR240293.544
N3 = 0 ! Compression definition DR240293.545
N4 = 0 ! Number format DR240293.546
N5 = 0 ! Not used DR240293.547
NPACK = N5*10000 + N4*1000 +N3*100 + N2*10 + N1 DR240293.548
LOOKUP_INTFA(LBPACK,VAR,JINTF)= NPACK DR240293.549
c GBC5F404.89
c--make sure that the LBC complete record is well formed GBC5F404.90
c GBC5F404.91
c--set the disk address GBC5F404.92
lookup_intfa(lbegin, var, jintf)=disk_address GBC5F404.93
c--fetch the data field length, allowing for packing GBC5F404.94
if(mod(lookup_intfa(lbpack, var, jintf), 10).eq.2) then GBC5F404.95
disk_length=(lookup_intfa(lblrec, var, jintf)+1)/2 GBC5F404.96
else GBC5F404.97
disk_length=lookup_intfa(lblrec, var, jintf) GBC5F404.98
endif GBC5F404.99
c--update the maximum record size GBC5F404.100
len_buf=len_buf+disk_length GBC5F404.101
c--store the rounded-up length GBC5F404.102
lookup_intfa(lbnrec, var, jintf)=disk_length GBC5F404.103
c--update the disk address GBC5F404.104
disk_address=disk_address+disk_length GBC5F404.105
LOOKUP_INTFA(LBCODE,VAR,JINTF)=1 DR240293.550
IF(VAR.EQ.2.OR.VAR.EQ.3) THEN DR240293.551
LOOKUP_INTFA(LBCODE,VAR,JINTF)=2 DR240293.552
END IF DR240293.553
LOOKUP_INTFA(LBHEM,VAR,JINTF)=99 DR240293.554
LOOKUP_INTFA(LBROW,VAR,JINTF)=INTFWIDTHA(JINTF) DR240293.555
LOOKUP_INTFA(LBNPT,VAR,JINTF)=LEN_INTF_P/INTFWIDTHA(JINTF) DR240293.556
IF (VAR.EQ.2.OR.VAR.EQ.3) THEN DR240293.557
LOOKUP_INTFA(LBNPT,VAR,JINTF)=LEN_INTF_U/INTFWIDTHA(JINTF) DR240293.558
END IF DR240293.559
LOOKUP_INTFA(LBLEV,VAR,JINTF)=-1 DR240293.560
LOOKUP_INTFA(NADDR,VAR,JINTF) = START_ADDR APB4F401.365
START_ADDR = START_ADDR + LOOKUP_INTFA(LBLREC,VAR,JINTF) APB4F401.366
DR240293.563
ENDDO DR240293.564
DR240293.565
APB4F401.367
CL 3.0 Pack data as required APB4F401.368
APB4F401.369
IADDR = 1 APB4F401.370
LEN_DATA = 0 APB4F401.371
DO VAR = 1,INTF_LOOKUPSA APB4F401.372
IF (MOD(LOOKUP_INTFA(LBPACK,VAR,JINTF),10).EQ.2) THEN APB4F401.373
*IF DEF,MPP GPB5F403.45
IF (mype .EQ. 0) THEN GPB5F403.46
*ENDIF GPB5F403.47
CALL PACK21(LOOKUP_INTFA(LBLREC,VAR,JINTF), APB4F401.374
& INTF_DATA(IADDR),INTF_DATA(LEN_DATA+1), APB4F401.375
& P21BITS(FIXHD_INTFA(12,JINTF))) APB4F401.376
*IF DEF,MPP GPB5F403.48
ENDIF GPB5F403.49
*ENDIF GPB5F403.50
c--the (+1) in the expression below is unnecessary, since GBC5F404.110
c LBC data is composed of two rows NS and two rows EW, and GBC5F404.111
c thus always has an even number of data points. If this GBC5F404.112
c is not true, then READFLDS will either get the data one GBC5F404.113
c out downwards if the (+1) is omitted, or one word upwards GBC5F404.114
c if the (+1) is added. In other words, the packing will GBC5F404.115
c cause either one word to be omitted or one word added in GBC5F404.116
c the data after the read. This is because READFLDS reads GBC5F404.117
c and converts the whole LBC record at one go, rather than GBC5F404.118
c as a series of separate records. GBC5F404.119
len_data = len_data+(lookup_intfa(lblrec,var,jintf)+1)/2 GBC5F404.120
c--check that we are not packing an odd nuber of words GBC5F404.121
if((lookup_intfa(lblrec,var,jintf)/2)*2 .ne. GBC5F404.122
& lookup_intfa(lblrec,var,jintf)) then GBC5F404.123
write(6,7734) lookup_intfa(lblrec,var,jintf) GBC5F404.124
7734 format(/'LBC Data contains ',i10,' Words, which is', GBC5F404.125
& ' an Odd Number which is not allowed for 32-bit', GBC5F404.126
& ' Packing') GBC5F404.127
*IF DEF,T3E,AND,DEF,MPP GBC5F404.128
if(mype.eq.0) then GBC5F404.129
write(6,7734) lookup_intfa(lblrec,var,jintf) GBC5F404.130
endif GBC5F404.131
*ENDIF GBC5F404.132
endif GBC5F404.133
ELSE APB4F401.378
IF (LEN_DATA+1.LT.IADDR) THEN APB4F401.379
*IF DEF,MPP GPB5F403.51
IF (mype .EQ. 0) THEN GPB5F403.52
*ENDIF GPB5F403.53
DO J = 1,LOOKUP_INTFA(LBLREC,VAR,JINTF) APB4F401.380
INTF_DATA(LEN_DATA+J) = INTF_DATA(IADDR+J-1) APB4F401.381
ENDDO APB4F401.382
*IF DEF,MPP GPB5F403.54
ENDIF GPB5F403.55
*ENDIF GPB5F403.56
ENDIF APB4F401.383
LEN_DATA = LEN_DATA+LOOKUP_INTFA(LBLREC,VAR,JINTF) APB4F401.384
ENDIF APB4F401.385
IADDR = IADDR+LOOKUP_INTFA(LBLREC,VAR,JINTF) APB4F401.386
ENDDO APB4F401.387
CL 4.0 Write out headers/data DR240293.566
DR240293.567
CL 4.1 Fixed length header DR240293.568
GENINTF1.417
IADDR = 0 GENINTF1.418
CALL SETPOS (NFTOUT,IADDR,ICODE) GTD0F400.79
CALL BUFFOUT(NFTOUT,FIXHD_INTFA(1,JINTF),LEN_FIXHD,LEN_IO,A_IO) DR240293.570
GENINTF1.421
C Check for I/O Errors GENINTF1.422
GENINTF1.423
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN_FIXHD) THEN GENINTF1.424
CALL IOERROR('buffer out of fixed length header',A_IO,LEN_IO, GENINTF1.425
& LEN_FIXHD) GENINTF1.426
CMESSAGE=' GEN_INTF: I/O ERROR ' GENINTF1.427
ICODE=2 GENINTF1.428
GO TO 999 ! Return DR240293.571
END IF GENINTF1.430
GENINTF1.431
CL 4.2 Integer constants DR240293.572
GENINTF1.433
CALL BUFFOUT (NFTOUT,INTHD_INTFA(1,JINTF), DR240293.573
& PP_LEN_INTHD,LEN_IO,A_IO) DR240293.574
GENINTF1.435
C Check for I/O Errors GENINTF1.436
GENINTF1.437
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.PP_LEN_INTHD) THEN GENINTF1.438
CALL IOERROR('buffer out of integer header',A_IO,LEN_IO, RB120293.3
& PP_LEN_INTHD) GENINTF1.440
CMESSAGE=' GEN_INTF: I/O ERROR ' GENINTF1.441
ICODE=3 GENINTF1.442
GO TO 999 ! Return DR240293.575
END IF GENINTF1.444
GENINTF1.445
CL 4.3 PP headers in LOOKUP table DR240293.576
CALL SETPOS(NFTOUT,LOOKUP_START,ICODE) GTD0F400.80
CALL BUFFOUT(NFTOUT,LOOKUP_INTFA(1,1,JINTF), DR240293.577
& LEN1_LOOKUP*INTF_LOOKUPSA,LEN_IO,A_IO) GENINTF1.506
GENINTF1.507
C Check for I/O Errors GENINTF1.508
GENINTF1.509
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN1_LOOKUP*INTF_LOOKUPSA) THEN GENINTF1.510
CALL IOERROR('buffer out of PP header',A_IO,LEN_IO, GENINTF1.511
& LEN1_LOOKUP*INTF_LOOKUPSA) GENINTF1.512
CMESSAGE=' GEN_INTF: I/O ERROR ' GENINTF1.513
ICODE=4 GENINTF1.514
GO TO 999 ! Return DR240293.578
END IF GENINTF1.516
GENINTF1.517
CL 4.4 Interface data DR240293.579
C Determine position in data section DR240293.580
GDR1F400.183
DATA_START = DR240293.581
& lookup_intfa(lbegin, 1, jintf) GBC5F404.106
c--round this disk length to a multiple of the sector size GBC5F404.107
len_data=((len_data+um_sector_size-1)/ GBC5F404.108
& um_sector_size)*um_sector_size GBC5F404.109
CALL SETPOS(NFTOUT,DATA_START,ICODE) GTD0F400.81
CALL BUFFOUT(NFTOUT,INTF_DATA(1),LEN_DATA,LEN_IO,A_IO) GDR1F400.191
GENINTF1.520
C Check for I/O Errors GENINTF1.521
GENINTF1.522
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.LEN_DATA) THEN GDR1F400.192
CALL IOERROR('buffer out of boundary data',A_IO,LEN_IO, GENINTF1.524
& LEN_DATA) GDR1F400.193
CMESSAGE=' GEN_INTF: I/O ERROR ' GENINTF1.526
ICODE=51 GDR1F400.194
GO TO 999 ! Return DR240293.583
END IF GENINTF1.529
GENINTF1.530
CL Close boundary output file if reinitialised during run DR240293.584
IF (FT_STEPS(NFTOUT).GT.0) THEN GENINTF1.533
LEN_PPNAME=LEN(PPNAME) GENINTF1.534
CALL FILE_CLOSE(NFTOUT,PPNAME,LEN_PPNAME,1,0,ICODE) GTD0F400.4
END IF GENINTF1.536
GENINTF1.537
CL Update FT_LASTFIELD DR240293.585
FT_LASTFIELD(NFTOUT) = FT_LASTFIELD(NFTOUT) + 1 GENINTF1.540
GENINTF1.541
999 RETURN DR240293.587
END GENINTF1.557
*ENDIF GSS1F304.331
*ENDIF GENINTF1.559