SUBROUTINE MBLOCK (ka,ke,ipp,ia1, 2,3MBLOCK.4
*CALL ARGWVAL 
MBLOCK.5
*CALL ARGWVMP MBLOCK.6
*CALL ARGWVGD MBLOCK.7
& icode) MBLOCK.8
MBLOCK.9
*CALL PARCONS MBLOCK.10
MBLOCK.11
integer ka ! in MBLOCK.12
integer ke ! in MBLOCK.13
MBLOCK.14
integer ipp(ngy) ! in MBLOCK.15
logical ia1(ngx,ngy) ! in land-sea mask WVV0F401.26
MBLOCK.17
*CALL TYPWVMP MBLOCK.18
*CALL TYPWVGD MBLOCK.19
*CALL TYPWVAL MBLOCK.20
MBLOCK.21
C ---------------------------------------------------------------------- MBLOCK.22
C MBLOCK.23
C**** *MBLOCK* - ROUTINE TO ARRANGE WAMODEL GRID FOR ONE BLOCK. MBLOCK.24
C MBLOCK.25
C H.GUNTHER ECMWF 04/04/1990 MBLOCK.26
C MBLOCK.27
C* PURPOSE. MBLOCK.28
C ------- MBLOCK.29
C MBLOCK.30
C *MBLOCK* ARRANGES WAMODEL GRID FOR A BLOCK AND MBLOCK.31
C COMPUTES VARIOUS MODEL CONSTANTS MBLOCK.32
C MBLOCK.33
C** INTERFACE. MBLOCK.34
C ---------- MBLOCK.35
C MBLOCK.36
C *CALL* *MBLOCK (IA1, KA, KE, IPP)* MBLOCK.37
C *IA1* - TOPOGRAPHIC DATA. MBLOCK.38
C *KA* - NUMBER OF FIRST LAT IN BLOCK. MBLOCK.39
C *KE* - NUMBER OF LAST LAT IN BLOCK. MBLOCK.40
C *IPP* - NUMBER OF SEA POINTS PER LAT. MBLOCK.41
C MBLOCK.42
C METHOD. MBLOCK.43
C ------- MBLOCK.44
C MBLOCK.45
C THE LAND POINTS ARE REMOVED. ALL MODEL CONSTANTS WHICH ARE MBLOCK.46
C GRID DEPENDENT ARE COMPUTED AND STORED IN THE COMMON BLOCKS. MBLOCK.47
C MBLOCK.48
C EXTERNALS. MBLOCK.49
C ---------- MBLOCK.50
C MBLOCK.51
C REFERENCE. MBLOCK.52
C ---------- MBLOCK.53
C MBLOCK.54
C NONE. MBLOCK.55
C MBLOCK.56
C ---------------------------------------------------------------------- MBLOCK.57
C* 1. UPDATE BLOCK NUMBER AND INITIALIZES ARRAYS. MBLOCK.58
C ------------------------------------------- MBLOCK.59
C MBLOCK.60
iu06=6 MBLOCK.61
MBLOCK.62
1000 CONTINUE MBLOCK.63
IGL = IGL + 1 MBLOCK.64
IF (IGL.GT.NBLO) THEN MBLOCK.65
WRITE (IU06,*) '**********************************************' MBLOCK.66
WRITE (IU06,*) '* *' MBLOCK.67
WRITE (IU06,*) '* FATAL ERROR IN SUB. MBLOCK *' MBLOCK.68
WRITE (IU06,*) '* ========================== *' MBLOCK.69
WRITE (IU06,*) '* *' MBLOCK.70
WRITE (IU06,*) '* MORE BLOCKS THAN DIMENSION ALLOWS. *' MBLOCK.71
WRITE (IU06,*) '* BLOCK NUMBER IS IGL = ', IGL MBLOCK.72
WRITE (IU06,*) '* DIMENSION IS NBLO = ', NBLO MBLOCK.73
WRITE (IU06,*) '* NUMBER OF FIRST LATITUDE IS KA = ', KA MBLOCK.74
WRITE (IU06,*) '* NUMBER OF LAST LATITUDE IS KE = ', KE MBLOCK.75
WRITE (IU06,*) '* *' MBLOCK.76
WRITE (IU06,*) '* PROGRAM WILL BE ABORTED *' MBLOCK.77
WRITE (IU06,*) '* *' MBLOCK.78
WRITE (IU06,*) '**********************************************' MBLOCK.79
icode=-1 MBLOCK.80
call abort MBLOCK.81
ENDIF MBLOCK.82
DO 1001 IJ=1,NIBLO MBLOCK.83
IXLG(IJ,IGL) = 0 MBLOCK.84
KXLT(IJ,IGL) = 0 MBLOCK.85
1001 CONTINUE MBLOCK.86
MBLOCK.87
C ---------------------------------------------------------------------- MBLOCK.88
C MBLOCK.89
C* 2. THE FIRST AND LAST BLOCK MUST CONTAIN MORE THAN 2 MBLOCK.90
C* ALL OTHER BLOCKS MORE THAN 3 LATITUDES. MBLOCK.91
C ------------------------------------------------- MBLOCK.92
C MBLOCK.93
2000 CONTINUE MBLOCK.94
cc MBLOCK.95
cc MBLOCK.96
ccUM the if test below was originally : MBLOCK.97
ccUM 1 ((KA.NE.1) .AND. (KE.EQ.NY) .AND. (KE-KA.LT.2))) THEN MBLOCK.98
ccUM ~~~~ MBLOCK.99
ccUM corrected to .NE. after UM Review MBLOCK.100
ccUM S Kelsall / M Holt 26/7/95 MBLOCK.101
cc MBLOCK.102
cc this now matches what is described in the comment block above MBLOCK.103
cc MBLOCK.104
IF ((KE.EQ.1) .OR. (KA.EQ.NY) .OR. MBLOCK.105
1 ((KA.NE.1) .AND. (KE.NE.NY) .AND. (KE-KA.LT.2))) THEN MBLOCK.106
WRITE (IU06,*) '**********************************************' MBLOCK.107
WRITE (IU06,*) '* *' MBLOCK.108
WRITE (IU06,*) '* FATAL ERROR IN SUB. MBLOCK *' MBLOCK.109
WRITE (IU06,*) '* ========================== *' MBLOCK.110
WRITE (IU06,*) '* *' MBLOCK.111
WRITE (IU06,*) '* BLOCK LENGTH IS TO SHORT. *' MBLOCK.112
WRITE (IU06,*) '* LESS THAN 2 LATITUDES IN FIRST OR LAST, OR *' MBLOCK.113
WRITE (IU06,*) '* LESS THAN 3 LATITUDES IN OTHER BLOCKS. *' MBLOCK.114
WRITE (IU06,*) '* BLOCK NUMBER IS IGL = ', IGL MBLOCK.115
WRITE (IU06,*) '* BLOCK LENGTH IS NIBLO = ', NIBLO MBLOCK.116
WRITE (IU06,*) '* NUMBER OF FIRST LATITUDE IS KA = ', KA MBLOCK.117
WRITE (IU06,*) '* NUMBER OF LAST LATITUDE IS KE = ', KE MBLOCK.118
WRITE (IU06,*) '* *' MBLOCK.119
WRITE (IU06,*) '* PROGRAM WILL BE ABORTED *' MBLOCK.120
WRITE (IU06,*) '* *' MBLOCK.121
WRITE (IU06,*) '**********************************************' MBLOCK.122
icode=-1 MBLOCK.123
call abort MBLOCK.124
ENDIF MBLOCK.125
C MBLOCK.126
C ---------------------------------------------------------------------- MBLOCK.127
C MBLOCK.128
C* 3. COMPUTE INDICES OF FIRST, SECOND, BEFORE LAST, AND LAST LAT. MBLOCK.129
C ----------------------------------------------------------- MBLOCK.130
C MBLOCK.131
3000 CONTINUE MBLOCK.132
IF (KA.EQ.1) THEN MBLOCK.133
IJS (IGL) = 1 MBLOCK.134
IJL2(IGL) = IPP(1) MBLOCK.135
ELSE MBLOCK.136
IJS (IGL) = IPP(KA)+1 MBLOCK.137
IJL2(IGL) = IPP(KA)+IPP(KA+1) MBLOCK.138
ENDIF MBLOCK.139
IJLT(IGL) = 0 MBLOCK.140
DO 3001 K=KA,KE MBLOCK.141
IJLT(IGL) = IJLT(IGL)+IPP(K) MBLOCK.142
3001 CONTINUE MBLOCK.143
IF (KE.EQ.NY) THEN MBLOCK.144
IJL (IGL) = IJLT(IGL) MBLOCK.145
ELSE MBLOCK.146
IJL (IGL) = IJLT(IGL)-IPP(KE) MBLOCK.147
ENDIF MBLOCK.148
IJLS(IGL) = IJL(IGL)-IPP(KE-1)+1 MBLOCK.149
C MBLOCK.150
C ---------------------------------------------------------------------- MBLOCK.151
C MBLOCK.152
C* 4. REMOVE LAND POINTS AND STORE COS AND SIN OF LAT. MBLOCK.153
C ------------------------------------------------ MBLOCK.154
C MBLOCK.155
4000 CONTINUE MBLOCK.156
IP = 0 MBLOCK.157
DO 4001 K=KA,KE MBLOCK.158
DO 4002 I=1,NX MBLOCK.159
IF (.not.IA1(I,K)) THEN ! a sea point WVV0F401.27
IP = IP+1 MBLOCK.161
IXLG(IP,IGL) = I MBLOCK.162
KXLT(IP,IGL) = K MBLOCK.163
ENDIF MBLOCK.164
4002 CONTINUE MBLOCK.165
4001 CONTINUE MBLOCK.166
IF (IP.NE.IJLT(IGL)) THEN MBLOCK.167
WRITE (IU06,*) '**********************************************' MBLOCK.168
WRITE (IU06,*) '* *' MBLOCK.169
WRITE (IU06,*) '* FATAL ERROR IN SUB. MBLOCK *' MBLOCK.170
WRITE (IU06,*) '* ========================== *' MBLOCK.171
WRITE (IU06,*) '* *' MBLOCK.172
WRITE (IU06,*) '* TOTAL NUMBER OF SEAPOINTS DO NOT MATCH. *' MBLOCK.173
WRITE (IU06,*) '* BLOCK NUMBER IGL = ', IGL MBLOCK.174
WRITE (IU06,*) '* NO. OF SEAPOINTS COUNTED IP = ', IP MBLOCK.175
WRITE (IU06,*) '* NO. OF SEAPOINTS EXPECTED IJLT(IGL) = ', MBLOCK.176
1 IJLT(IGL) MBLOCK.177
WRITE (IU06,*) '* *' MBLOCK.178
WRITE (IU06,*) '* PROGRAM WILL BE ABORTED *' MBLOCK.179
WRITE (IU06,*) '* *' MBLOCK.180
WRITE (IU06,*) '**********************************************' MBLOCK.181
icode=-1 MBLOCK.182
call abort MBLOCK.183
ENDIF MBLOCK.184
C MBLOCK.185
C ---------------------------------------------------------------------- MBLOCK.186
C MBLOCK.187
C* 5. PRINTER PROTOCOL OF BLOCK. MBLOCK.188
C -------------------------- MBLOCK.189
C MBLOCK.190
5000 CONTINUE MBLOCK.191
IF (IGL.EQ.1) THEN MBLOCK.192
WRITE (IU06,'(1H0,'' BLOCKING INFORMATION:'')') MBLOCK.193
WRITE (IU06,'(1H ,'' LATITUDES '', MBLOCK.194
1 '' SECOND LAT. INDEX '', MBLOCK.195
2 '' SECOND TO LAST LAT '', MBLOCK.196
3 '' TOTAL'')') MBLOCK.197
WRITE (IU06,'(1H ,'' NO SOUTH NORTH'', MBLOCK.198
1 '' START END'', MBLOCK.199
2 '' START END'', MBLOCK.200
3 '' POINTS'')') MBLOCK.201
ENDIF MBLOCK.202
WRITE (IU06,'(1X,I4,2F10.2,5I10)') MBLOCK.203
1 IGL, AMOSOP+(KA-1)*XDELLA, AMOSOP+(KE-1)*XDELLA, MBLOCK.204
2 IJS(IGL), IJL2(IGL), IJLS(IGL), IJL(IGL), IJLT(IGL) MBLOCK.205
MBLOCK.206
RETURN MBLOCK.207
END MBLOCK.208
*ENDIF MBLOCK.209