SUBROUTINE REGROUP(PSPEC,KWTRA,PETO,PERIO,PDIR,KBLO,KJS,KJL, 1,1REGROUP.25
% KANG,KFRE,KWTMAX,KWTOT, REGROUP.26
% PEMINR,PEMAXR,PDTMIN,PFREQ,PFBIN,PTHETA, REGROUP.27
% PEMIN,PMISS,df) REGROUP.28
C REGROUP.29
C**** *REGROUP* - ROUTINE TO REDUCE NUMBER OF WAVE TRAINS REGROUP.30
C REGROUP.31
C A.GUILLAUME ECMWF 26/06/92 REGROUP.32
C A.GUILLAUME reduce memory space 09/02/94 REGROUP.33
C M. HOLT set pmiss for zero ht 20/2/96 REGROUP.34
C REGROUP.35
C PURPOSE. REGROUP.36
C -------- REGROUP.37
C REGROUP.38
C *REGROUP* REDUCES THE NB OF WT REGROUP.39
C REGROUP.40
C** INTERFACE. REGROUP.41
C ---------- REGROUP.42
C REGROUP.43
C *CALL* *REGROUP(PSPEC,KWTRA,PETO,PERIO,PDIR,KBLO,KJS,KJL, REGROUP.44
C KANG,KFRE,KWTMAX,KWTOT, REGROUP.45
C PEMINR,PEMAXR,PDTMIN,PFREQ,PFBIN,PTHETA, REGROUP.46
C PEMIN,PMISS) REGROUP.47
C REGROUP.48
C I *PSPEC* - WAVE SPECTRUM. REGROUP.49
C I/O *KWTRA* - WAVE TRAIN INDEX ASSOCIATED WITH EACH BIN OF PSPEC. REGROUP.50
C I/O *PETO* - TOTAL ENERGY OF WAVE TRAINS. REGROUP.51
C I/O *PERIO* - MEAN PERIOD OF WAVE TRAINS. REGROUP.52
C I/O *PDIR* - MEAN DIRECTION OF WAVE TRAINS. REGROUP.53
C I/ *KBLO* - DIMENSION OF ONE BLOCK. REGROUP.54
C I/ *KJS* - INDEX OF FIRST POINT OF BLOCK TO USE. REGROUP.55
C I/ *KJL* - INDEX OF LAST POINT OF BLOCK TO USE. REGROUP.56
C I/ *KANG* - NUMBER OF DIRECTIONS. REGROUP.57
C I/ *KFRE* - NUMBER OF FREQUENCIES. REGROUP.58
C I/ *KWTMAX* - MAX NUMBER OF WAVE TRAINS. REGROUP.59
C /O *KWTOT* - NUMBER OF WAVE TRAINS. REGROUP.60
C I/ *PEMINR* - FOR MERGING WAVE TRAINS WITH CLOSE PERIODS REGROUP.61
C I/ *PEMAXR* - FOR MERGING WAVE TRAINS WITH CLOSE PERIODS REGROUP.62
C I/ *PDTMIN* - FOR MERGING WAVE TRAINS WITH CLOSE DIRECTIONS REGROUP.63
C I/ *PFREQ* - FREQUENCY MATRIX. REGROUP.64
C I/ *PFBIN* - PFREQ(IF+1)=PFREQ(IF)*(1+PFBIN) REGROUP.65
C I/ *PTHETA* - DIRECTION MATRIX. REGROUP.66
C I/ *PEMIN* - MIN ENERGY CUT-OFF REGROUP.67
C I/ *PMISS* - MISSING VALUE REGROUP.68
C REGROUP.69
C METHOD. REGROUP.70
C ------- REGROUP.71
C REGROUP.72
C REGROUP.73
C EXTERNALS. REGROUP.74
C ---------- REGROUP.75
C VTOTT REGROUP.76
C VAGDIRT REGROUP.77
C REGROUP.78
C REFERENCE. REGROUP.79
C ---------- REGROUP.80
C REGROUP.81
C NONE. REGROUP.82
C REGROUP.83
DIMENSION PSPEC(KBLO,KANG,KFRE),KWTRA(KJL-KJS+1,KANG,KFRE) REGROUP.84
DIMENSION PETO(KBLO,KWTMAX),PERIO(KBLO,KWTMAX), REGROUP.85
% PDIR(KBLO,KWTMAX),KWTOT(KBLO),PEMIN(KBLO) REGROUP.86
DIMENSION PFREQ(KFRE),PTHETA(KANG),df(kfre) REGROUP.87
C..WORKING ARRAYS: REGROUP.88
DIMENSION ZWORK(KJL-KJS+1,KANG,KFRE),ZPER(KBLO) REGROUP.89
DIMENSION ZTET1(KBLO),ZTET2(KBLO) REGROUP.90
C REGROUP.91
C* *PARAMETER* OF GLOBAL CONSTANTS. REGROUP.92
C REGROUP.93
CCC PARAMETER (G = 9.806, PI = 3.14159265358978, CIRC = 40000000., REGROUP.94
CCC 1 ZPI = 2.*PI, RAD = PI/180., DEG = 180./PI, REGROUP.95
CCC 2 R = CIRC/ZPI) REGROUP.96
REGROUP.97
*CALL C_G 
REGROUP.98
*CALL C_PI REGROUP.99
REGROUP.100
C REGROUP.101
C..FUNCTION IN LINE REGROUP.102
IDELTA(I,J)=(ISIGN(1,I-J)+ISIGN(1,J-I))/2 REGROUP.103
REGROUP.104
ZPI=2.*PI REGROUP.105
RAD=PI_OVER_180 REGROUP.106
DEG=RECIP_PI_OVER_180 REGROUP.107
REGROUP.108
C REGROUP.109
C 1. MERGING LOOP. REGROUP.110
C ------------- REGROUP.111
C REGROUP.112
ccc WRITE(6,*)'in routine regroup array pfreq kfre' GIE0F403.592
ccc WRITE(6,*)kfre,pfreq GIE0F403.593
100 CONTINUE REGROUP.115
DO 101 JWTR=KWTMAX,1,-1 REGROUP.116
DO 101 JWTR2=JWTR-1,1,-1 REGROUP.117
DO 102 J=KJS,KJL REGROUP.118
ZPER(J)=PERIO(J,JWTR2)/PERIO(J,JWTR) REGROUP.119
ZTET1(J)=MOD(PDIR(J,JWTR)-PDIR(J,JWTR2)+ZPI,ZPI) REGROUP.120
ZTET2(J)=MOD(PDIR(J,JWTR2)-PDIR(J,JWTR)+ZPI,ZPI) REGROUP.121
ZTET1(J)=AMIN1(ABS(ZTET1(J)),ABS(ZTET2(J))) REGROUP.122
102 CONTINUE REGROUP.123
C REGROUP.124
C 1.1 REGROUPEMENT PAR PERIODE ET PAR DIRECTION. REGROUP.125
C ------------------------------------------ REGROUP.126
C REGROUP.127
110 CONTINUE REGROUP.128
DO 111 J=KJS,KJL REGROUP.129
CAG WRITE(6,*)'J IN REGROUP ',J,' JWTR,JWTR2 ',JWTR,JWTR2 GIE0F403.594
CAG WRITE(6,*)' ZTET1(J),ZTET2(J),ZPER(J) ', GIE0F403.595
CAG % ZTET1(J),ZTET2(J),ZPER(J) REGROUP.132
CAG PRINT 115,KWTRA REGROUP.133
115 FORMAT('KWTRA IN REGROUP',(24I2)) REGROUP.134
IF((ZPER(J).LT.PEMAXR).AND.(ZPER(J).GT.PEMINR)) THEN REGROUP.135
IF(ZTET1(J).LT.PDTMIN) THEN REGROUP.136
DO 112 JFRE=1,KFRE REGROUP.137
DO 112 JANG=1,KANG REGROUP.138
KWTRA(J-KJS+1,JANG,JFRE)= REGROUP.139
% JWTR2*IDELTA(KWTRA(J-KJS+1,JANG,JFRE),JWTR) REGROUP.140
% +KWTRA(J-KJS+1,JANG,JFRE) REGROUP.141
% *(1-IDELTA(KWTRA(J-KJS+1,JANG,JFRE),JWTR)) REGROUP.142
112 CONTINUE REGROUP.143
PETO(J,JWTR)=0. REGROUP.144
PERIO(J,JWTR)=PMISS REGROUP.145
PDIR(J,JWTR)=PMISS REGROUP.146
ENDIF REGROUP.147
ENDIF REGROUP.148
111 CONTINUE REGROUP.149
C REGROUP.150
C 1.2. COMPUTE INTEGRATED PARAMETERS OF NEW WAVE TRAIN. REGROUP.151
C ----------------------------------------------- REGROUP.152
C REGROUP.153
120 CONTINUE REGROUP.154
DO 123 JFRE=1,KFRE REGROUP.155
DO 123 JANG=1,KANG REGROUP.156
DO 123 J=1,KJL-KJS+1 REGROUP.157
ZWORK(J,JANG,JFRE)= REGROUP.158
%PSPEC(J+KJS-1,JANG,JFRE)*IDELTA(KWTRA(J,JANG,JFRE),JWTR2) REGROUP.159
123 CONTINUE REGROUP.160
CALL VINTPAR(ZWORK,PETO(KJS,JWTR2),PERIO(KJS,JWTR2), REGROUP.161
% PDIR(KJS,JWTR2),KJL-KJS+1,1,KJL-KJS+1,KANG,KFRE, REGROUP.162
% PFREQ,PFBIN,PTHETA,PMISS,df) REGROUP.163
101 CONTINUE REGROUP.164
CAG WRITE(6,*)' NB TRAINS AVANT REGROUPEMENT ',KWTOT GIE0F403.596
C REGROUP.166
C 2. COUNT AND REORGANIZE WAVE TRAINS. REGROUP.167
C --------------------------------- REGROUP.168
C REGROUP.169
200 CONTINUE REGROUP.170
DO 201 J=KJS,KJL REGROUP.171
KWTOT(J)=0 REGROUP.172
201 CONTINUE REGROUP.173
DO 202 J=KJS,KJL REGROUP.174
DO 203 JWTR=1,KWTMAX REGROUP.175
CCMH * note that pemin is proportion of total energy so REGROUP.176
CCMH * if ice point we have REGROUP.177
CCMH * total energy is 2pi*emin or zero ? so the pemin test is passed REGROUP.178
IF((PETO(J,JWTR).NE.PMISS) REGROUP.179
% .AND.(PETO(J,JWTR).GT.1.e-2) REGROUP.180
% .AND.(PETO(J,JWTR).GT.PEMIN(J))) THEN REGROUP.181
KWTOT(J)=KWTOT(J)+1 REGROUP.182
PETO(J,KWTOT(J))=PETO(J,JWTR) REGROUP.183
PDIR(J,KWTOT(J))=PDIR(J,JWTR) REGROUP.184
PERIO(J,KWTOT(J))=PERIO(J,JWTR) REGROUP.185
DO 204 JFRE=1,KFRE REGROUP.186
DO 204 JANG=1,KANG REGROUP.187
KWTRA(J-KJS+1,JANG,JFRE)= REGROUP.188
% KWTOT(J)*IDELTA(KWTRA(J-KJS+1,JANG,JFRE),JWTR) REGROUP.189
% +KWTRA(J-KJS+1,JANG,JFRE) REGROUP.190
% *(1-IDELTA(KWTRA(J-KJS+1,JANG,JFRE),JWTR)) REGROUP.191
204 CONTINUE REGROUP.192
ELSE REGROUP.193
PETO(J,JWTR)=0. REGROUP.194
PDIR(J,JWTR)=PMISS REGROUP.195
PERIO(J,JWTR)=PMISS REGROUP.196
DO 205 JFRE=1,KFRE REGROUP.197
DO 205 JANG=1,KANG REGROUP.198
KWTRA(J-KJS+1,JANG,JFRE)= REGROUP.199
% (KWTMAX+1)*IDELTA(KWTRA(J-KJS+1,JANG,JFRE),JWTR) REGROUP.200
% +KWTRA(J-KJS+1,JANG,JFRE) REGROUP.201
% *(1-IDELTA(KWTRA(J-KJS+1,JANG,JFRE),JWTR)) REGROUP.202
205 CONTINUE REGROUP.203
ENDIF REGROUP.204
203 CONTINUE REGROUP.205
DO 206 JWTR=KWTOT(J)+1,KWTMAX REGROUP.206
PETO(J,JWTR)=0. REGROUP.207
PDIR(J,JWTR)=PMISS REGROUP.208
PERIO(J,JWTR)=PMISS REGROUP.209
206 CONTINUE REGROUP.210
202 CONTINUE REGROUP.211
CAG WRITE(6,*)' NB TRAINS APRES REGROUPEMENT ',KWTOT GIE0F403.597
RETURN REGROUP.213
END REGROUP.214
*ENDIF REGROUP.215