SUBROUTINE POLAR_ROW_ADJ(u,v,row_length,levels,n_rows, 2,2PR_ADJ1A.23
& pp_pos,len1_lookup,len2_lookup, PR_ADJ1A.24
*CALL ARGPPX 
PR_ADJ1A.25
& lookup,rlookup) PR_ADJ1A.26
PR_ADJ1A.27
IMPLICIT NONE PR_ADJ1A.28
! PR_ADJ1A.29
! Description: Recalculated polar row u using geometric wind PR_ADJ1A.30
! across the pole. PR_ADJ1A.31
! PR_ADJ1A.32
! Method: PR_ADJ1A.33
! PR_ADJ1A.34
! Current Code Owner: I Edmond PR_ADJ1A.35
! PR_ADJ1A.36
! History: PR_ADJ1A.37
! Version Date Comment PR_ADJ1A.38
! ------- ---- ------- PR_ADJ1A.39
! 4.4 15/6/96 Original code. Ian Edmond PR_ADJ1A.40
! PR_ADJ1A.41
! Code Description: PR_ADJ1A.42
! Language: FORTRAN 77 + common extensions. PR_ADJ1A.43
! This code is written to UMDP3 v6 programming standards. PR_ADJ1A.44
! PR_ADJ1A.45
! System component covered: <appropriate code> PR_ADJ1A.46
! System Task: <appropriate code> PR_ADJ1A.47
! PR_ADJ1A.48
! Declarations: PR_ADJ1A.49
! These are of the form:- PR_ADJ1A.50
! INTEGER ExampleVariable !Description of variable PR_ADJ1A.51
! PR_ADJ1A.52
! 1.0 Global variables (*CALLed COMDECKs etc...): PR_ADJ1A.53
*CALL CSUBMODL PR_ADJ1A.54
*CALL CPPXREF PR_ADJ1A.55
*CALL PPXLOOK PR_ADJ1A.56
! Subroutine arguments PR_ADJ1A.57
! Scalar arguments with intent(in): PR_ADJ1A.58
INTEGER PR_ADJ1A.59
& row_length ! Dimensions of input field: No. of columns PR_ADJ1A.60
&,levels ! No. of levels. PR_ADJ1A.61
&,n_rows ! No. of rows. PR_ADJ1A.62
&,len1_lookup PR_ADJ1A.63
&,len2_lookup PR_ADJ1A.64
&,pp_pos PR_ADJ1A.65
PR_ADJ1A.66
! Array arguments with intent(in/out): PR_ADJ1A.67
INTEGER PR_ADJ1A.68
& lookup(len1_lookup,len2_lookup) PR_ADJ1A.69
PR_ADJ1A.70
REAL PR_ADJ1A.71
& u(row_length,n_rows,levels) PR_ADJ1A.72
&,v(row_length,n_rows-1,levels) PR_ADJ1A.73
PR_ADJ1A.74
REAL PR_ADJ1A.75
& rlookup(len1_lookup,len2_lookup) PR_ADJ1A.76
PR_ADJ1A.77
! Local scalars: PR_ADJ1A.78
INTEGER PR_ADJ1A.79
& top_row ! Counter specifing the UM row no. PR_ADJ1A.80
&,bottom_row ! Counter specifing the equivalent PF row no. PR_ADJ1A.81
&,point ! Counter specifing the column no. PR_ADJ1A.82
&,k ! Counter specifing the level no. PR_ADJ1A.83
&,icode PR_ADJ1A.84
&,model PR_ADJ1A.85
&,item_code PR_ADJ1A.86
&,section PR_ADJ1A.87
&,ppxref_grid_type PR_ADJ1A.88
PR_ADJ1A.89
INTEGER exppxi ! Function to extract integer PR_ADJ1A.90
! from ppxref file PR_ADJ1A.91
REAL temp ! Temp. storage of data values. PR_ADJ1A.92
PR_ADJ1A.93
COMPLEX PR_ADJ1A.94
& Cexp_dlong PR_ADJ1A.95
&,Cexp_long(row_length) PR_ADJ1A.96
&,sum PR_ADJ1A.97
&,Csum PR_ADJ1A.98
PR_ADJ1A.99
CHARACTER *80 cmessage PR_ADJ1A.100
PR_ADJ1A.101
external exppxi PR_ADJ1A.102
!- End of header PR_ADJ1A.103
PR_ADJ1A.104
if (pp_pos .ne. 0) then PR_ADJ1A.105
PR_ADJ1A.106
item_code=mod(lookup(42,pp_pos),1000) PR_ADJ1A.107
section=(lookup(42,pp_pos)-item_code)/1000 PR_ADJ1A.108
model=lookup(45,pp_pos) PR_ADJ1A.109
ppxref_grid_type=exppxi(model,section,item_code,ppx_grid_type, PR_ADJ1A.110
*CALL ARGPPX PR_ADJ1A.111
& icode,cmessage) PR_ADJ1A.112
PR_ADJ1A.113
if (ppxref_grid_type.eq.18) then PR_ADJ1A.114
PR_ADJ1A.115
!Calculate sine table PR_ADJ1A.116
Cexp_dlong = CEXP(CMPLX(0.0,rlookup(62,pp_pos))) PR_ADJ1A.117
Cexp_long(1) = CMPLX(1.0,0.0) PR_ADJ1A.118
Do point = 2,row_length PR_ADJ1A.119
Cexp_long(point) = Cexp_long(point-1) * Cexp_dlong PR_ADJ1A.120
End do PR_ADJ1A.121
PR_ADJ1A.122
Do k =1,levels PR_ADJ1A.123
PR_ADJ1A.124
sum =0.0 PR_ADJ1A.125
! Northern boundary PR_ADJ1A.126
Do point =1,row_length PR_ADJ1A.127
sum = sum + Cexp_long(point) * v(point,n_rows-1,k) PR_ADJ1A.128
End do PR_ADJ1A.129
Csum = CMPLX(0.0,-2.0/row_length) * sum PR_ADJ1A.130
Do point = 1,row_length PR_ADJ1A.131
u(point,n_rows,k) = REAL(Cexp_long(point) * Csum ) PR_ADJ1A.132
End do PR_ADJ1A.133
PR_ADJ1A.134
sum =0.0 PR_ADJ1A.135
! Southern boundary PR_ADJ1A.136
Do point =1,row_length PR_ADJ1A.137
sum = sum + Cexp_long(row_length+1-point) * v(point,1,k) PR_ADJ1A.138
End do PR_ADJ1A.139
Csum = CMPLX(0.0,-2.0/row_length) * sum PR_ADJ1A.140
Do point = 1,row_length PR_ADJ1A.141
u(point,1,k) = REAL(Cexp_long(row_length+1-point)*Csum) PR_ADJ1A.142
End do PR_ADJ1A.143
PR_ADJ1A.144
End do PR_ADJ1A.145
PR_ADJ1A.146
endif PR_ADJ1A.147
PR_ADJ1A.148
else PR_ADJ1A.149
Call ABORT PR_ADJ1A.150
PR_ADJ1A.151
endif PR_ADJ1A.152
PR_ADJ1A.153
RETURN PR_ADJ1A.154
END PR_ADJ1A.155
*ENDIF PR_ADJ1A.156