SUBROUTINE PROPDOT(ishallo, irefra, ,1PROPDOT.4
*CALL ARGWVAL 
PROPDOT.5
*CALL ARGWVCU PROPDOT.6
*CALL ARGWVFD PROPDOT.7
*CALL ARGWVGD PROPDOT.8
*CALL ARGWVMP PROPDOT.9
*CALL ARGWVRF PROPDOT.10
*CALL ARGWVSH PROPDOT.11
*CALL ARGWVKL PROPDOT.12
& icode) PROPDOT.13
PROPDOT.14
*CALL PARWVSH PROPDOT.15
PROPDOT.16
*CALL TYPWVCU PROPDOT.17
*CALL TYPWVFD PROPDOT.18
*CALL TYPWVGD PROPDOT.19
*CALL TYPWVMP PROPDOT.20
*CALL TYPWVRF PROPDOT.21
*CALL TYPWVSH PROPDOT.22
*CALL TYPWVKL PROPDOT.23
*CALL TYPWVAL PROPDOT.24
PROPDOT.25
C ---------------------------------------------------------------------- PROPDOT.26
C PROPDOT.27
C**** *PROPDOT* - PROPAGATION DOT TERMS FROM DEPTH AND CURRENT GRADIENT. PROPDOT.28
C PROPDOT.29
C H. GUNTHER GKSS/ECMWF 17/02/91 PROPDOT.30
C PROPDOT.31
C* PURPOSE. PROPDOT.32
C -------- PROPDOT.33
C PROPDOT.34
C COMPUTATION OF COMMON REFDOT FOR PROPAGATION. PROPDOT.35
C PROPDOT.36
C** INTERFACE. PROPDOT.37
C ---------- PROPDOT.38
C PROPDOT.39
C *CALL* *PROPDOT* PROPDOT.40
C PROPDOT.41
C METHOD. PROPDOT.42
C ------- PROPDOT.43
C PROPDOT.44
C IN A LOOP OVER THE BLOCKS THE COMMON UBUF IS READ, PROPDOT.45
C THE DEPTH AND CURRENT GRADIENTS ARE COMPUTED, PROPDOT.46
C COMMON REFDOT (DEPTH AND CURRENT REFRACTION FOR THETA DOT) PROPDOT.47
C IS COMPUTED AND WRITTEN TO MASS STORAGE (IU16). PROPDOT.48
C IN CASE OF CURRENT REFRACTION THE COMPLETE SIGMA DOT TERM PROPDOT.49
C IS COMPUTED AND WRITTEN TO IU16 ADDITIONALLY. PROPDOT.50
C WRITE OPERATIONS ARE NOT DONE FOR COMMON UBUF AND REFDOT PROPDOT.51
C IF THIS IS A ONE BLOCK MODEL. PROPDOT.52
C PROPDOT.53
C EXTERNALS. PROPDOT.54
C ---------- PROPDOT.55
C PROPDOT.56
C *GRADI* - COMPUTES DEPTH AND CURRENT GRADIENTS. PROPDOT.57
C PROPDOT.58
C REFERENCE. PROPDOT.59
C ---------- PROPDOT.60
C PROPDOT.61
C NONE. PROPDOT.62
C PROPDOT.63
C ---------------------------------------------------------------------- PROPDOT.64
C PROPDOT.65
ccc*CALL PARALL PROPDOT.66
C PROPDOT.67
ccc*CALL COMCURR PROPDOT.68
C PROPDOT.69
ccc*CALL COMFRED PROPDOT.70
C PROPDOT.71
ccc*CALL COMGRID PROPDOT.72
C PROPDOT.73
ccc*CALL COMMAP PROPDOT.74
C PROPDOT.75
ccc*CALL COMREFD PROPDOT.76
C PROPDOT.77
ccc*CALL COMSHAL PROPDOT.78
C PROPDOT.79
ccc*CALL COMSOUR PROPDOT.80
C PROPDOT.81
ccc*CALL COMSTAT PROPDOT.82
C PROPDOT.83
ccc*CALL COMUBUF PROPDOT.84
C PROPDOT.85
ccc*CALL COMUNIT PROPDOT.86
C PROPDOT.87
C ---------------------------------------------------------------------- PROPDOT.88
C PROPDOT.89
C local arrays for one block only PROPDOT.90
C PROPDOT.91
DIMENSION DDPHI(NIBLD), DDLAM(NIBLD), DUPHI(NIBLC), DULAM(NIBLC), PROPDOT.92
1 DVPHI(NIBLC), DVLAM(NIBLC), DCO(NIBLD), OMDD(NIBLC) PROPDOT.93
C PROPDOT.94
C ---------------------------------------------------------------------- PROPDOT.95
C PROPDOT.96
ccmh notes - array sl from comSR is used as work space only PROPDOT.97
ccmh for shallow water current refraction need array (ij,k,l) PROPDOT.98
ccmh for deep water current refraction use array (ij,k) PROPDOT.99
PROPDOT.100
C* 1. IF CARTESIAN PROPAGATION SET COSINE OF LAT TO 1. PROPDOT.101
C ----------------------------------------------- PROPDOT.102
C PROPDOT.103
WRITE(6,*)'in propdot' GIE0F403.561
1000 CONTINUE PROPDOT.105
IF (ICASE.NE.1) THEN PROPDOT.106
DO 1001 IJ = 1,NIBLD PROPDOT.107
DCO(IJ) = 1. PROPDOT.108
1001 CONTINUE PROPDOT.109
ENDIF PROPDOT.110
C PROPDOT.111
C* 2. LOOP OVER BLOCKS. PROPDOT.112
C ----------------- PROPDOT.113
C PROPDOT.114
DO 2000 IG = 1,IGL PROPDOT.115
C PROPDOT.116
C* 2.1 IF MULTI BLOCK VERSION. PROPDOT.117
C ----------------------- PROPDOT.118
C PROPDOT.119
cccc IF (IGL.NE.1) THEN ! UMwave needs to do block one also PROPDOT.120
C PROPDOT.121
C* 2.1.2 COMPUTE SHALLOW WATER TABLE INDICES. for this block PROPDOT.122
c but not for block 1 ?? where is indep filled for block one?? PROPDOT.123
C ------------------------------------ PROPDOT.124
C PROPDOT.125
IF (ISHALLO.NE.1) THEN PROPDOT.126
DO 2121 IJ=1,IJLT(IG) PROPDOT.127
if(depth(ij,ig).gt.0.) then PROPDOT.128
XD = LOG(DEPTH(IJ,IG)/DEPTHA)/LOG(DEPTHD)+1. PROPDOT.129
ID = NINT(XD) PROPDOT.130
ID = MAX(ID,1) PROPDOT.131
INDEP(IJ) = MIN(ID,NDEPTH) PROPDOT.132
else PROPDOT.133
WRITE(6,*)'fatal error in propags: zero depth encountered' GIE0F403.562
icode=1 PROPDOT.135
goto 999 PROPDOT.136
endif PROPDOT.137
2121 CONTINUE PROPDOT.138
ENDIF PROPDOT.139
CSHALLOW PROPDOT.140
cccc ENDIF ! commented out as UMwave needs to do block one also PROPDOT.141
C PROPDOT.142
C* 2.2 DEPTH AND CURRENT GRADIENTS. for this block / every block PROPDOT.143
C ---------------------------- PROPDOT.144
C PROPDOT.145
WRITE(6,*)'calling gradi from propdot' GIE0F403.563
CALL GRADI (IG, IREFRA, DDPHI, DDLAM, DUPHI, PROPDOT.147
& DULAM, DVPHI, DVLAM, PROPDOT.148
*CALL ARGWVAL PROPDOT.149
*CALL ARGWVCU PROPDOT.150
*CALL ARGWVGD PROPDOT.151
*CALL ARGWVSH PROPDOT.152
*CALL ARGWVKL PROPDOT.153
& icode) PROPDOT.154
C PROPDOT.155
C* 2.3 COSINE OF LATITUDES IF SPHERICAL PROPAGATION. PROPDOT.156
C --------------------------------------------- PROPDOT.157
C PROPDOT.158
IF (ICASE.EQ.1) THEN PROPDOT.159
DO 2301 IJ = IJS(IG),IJL(IG) PROPDOT.160
JH = KXLT(IJ,IG) PROPDOT.161
DCO(IJ) = 1./COSPH(JH) PROPDOT.162
2301 CONTINUE PROPDOT.163
ENDIF PROPDOT.164
C PROPDOT.165
C* 2.4 DEPTH GRADIENT PART OF SIGMA DOT. PROPDOT.166
C --------------------------------- PROPDOT.167
C PROPDOT.168
IF (ISHALLO.NE.1 .AND. IREFRA.EQ.2) THEN PROPDOT.169
DO 2401 IJ = IJS(IG),IJL(IG) PROPDOT.170
OMDD(IJ) = V(IJ,IG)*DDPHI(IJ) + PROPDOT.171
1 U(IJ,IG)*DDLAM(IJ)*DCO(IJ) PROPDOT.172
2401 CONTINUE PROPDOT.173
ENDIF PROPDOT.174
C PROPDOT.175
C* 2.5. LOOP OVER DIRECTIONS. PROPDOT.176
C --------------------- PROPDOT.177
C PROPDOT.178
DO 2501 K=1,NANG PROPDOT.179
SD = SINTH(K) PROPDOT.180
CD = COSTH(K) PROPDOT.181
C PROPDOT.182
C* 2.5.1. DEPTH GRADIENT OF THETA DOT. PROPDOT.183
C ---------------------------- PROPDOT.184
C PROPDOT.185
IF (ISHALLO.NE.1) THEN PROPDOT.186
DO 2511 IJ = IJS(IG),IJL(IG) PROPDOT.187
THDD(IJ,K,ig) = SD*DDPHI(IJ) - CD*DDLAM(IJ)*DCO(IJ) PROPDOT.188
2511 CONTINUE PROPDOT.189
ENDIF PROPDOT.190
C PROPDOT.191
C* 2.5.2 SIGMA DOT AND THETA DOT PART FROM CURRENT GRADIENT. PROPDOT.192
C --------------------------------------------------- PROPDOT.193
C PROPDOT.194
IF (IREFRA.EQ.2) THEN PROPDOT.195
SS = SD**2 PROPDOT.196
SC = SD*CD PROPDOT.197
CC = CD**2 PROPDOT.198
DO 2521 IJ = IJS(IG),IJL(IG) PROPDOT.199
ccc old line SL(IJ,K,NFRE) = -SC*DUPHI(IJ) - CC*DVPHI(IJ) PROPDOT.200
SIDC(IJ,K,NFRE,ig) = -SC*DUPHI(IJ) - CC*DVPHI(IJ) PROPDOT.201
1 - (SS*DULAM(IJ) + SC*DVLAM(IJ))*DCO(IJ) PROPDOT.202
THDC(IJ,K,ig) = SS*DUPHI(IJ) + SC*DVPHI(IJ) PROPDOT.203
1 - (SC*DULAM(IJ) + CC*DVLAM(IJ))*DCO(IJ) PROPDOT.204
2521 CONTINUE PROPDOT.205
C PROPDOT.206
C* 2.5.3 LOOP OVER FREQUENCIES. if shallow water + currents PROPDOT.207
C ---------------------- PROPDOT.208
C PROPDOT.209
IF (ISHALLO.NE.1) THEN PROPDOT.210
DO 2530 M=1,NFRE PROPDOT.211
DO 2531 IJ=IJS(IG),IJL(IG) PROPDOT.212
ccc old line SL(IJ,K,M) = (SL(IJ,K,NFRE)*TCGOND(INDEP(IJ),M) PROPDOT.213
SIDC(IJ,K,M,ig) = (SIDC(IJ,K,NFRE,ig)*TCGOND(INDEP(IJ),M) PROPDOT.214
1 + OMDD(IJ)*TSIHKD(INDEP(IJ),M)) PROPDOT.215
2 * TFAK(INDEP(IJ),M) PROPDOT.216
2531 CONTINUE PROPDOT.217
C PROPDOT.218
C* BRANCH BACK TO 2.5.3 FOR NEXT FREQUENCY. PROPDOT.219
C PROPDOT.220
2530 CONTINUE PROPDOT.221
ENDIF PROPDOT.222
ENDIF PROPDOT.223
C PROPDOT.224
C* BRANCH BACK TO 2.5 FOR NEXT DIRECTION. PROPDOT.225
C PROPDOT.226
2501 CONTINUE PROPDOT.227
C PROPDOT.228
C* BRANCH BACK TO 2. FOR NEXT BLOCK. PROPDOT.229
C PROPDOT.230
2000 CONTINUE PROPDOT.231
PROPDOT.232
999 continue PROPDOT.233
RETURN PROPDOT.234
END PROPDOT.235
*ENDIF PROPDOT.236