C***********************************************************************
      SUBROUTINE OP_FILES1 (IU01, IU02, IU05,IU06)
C ----------------------------------------------------------------------
C
C**** TAKE NAMES AND OPEN OF INPUT & OUTPUT FILES
C
C     ISAAC GERTMAN    20-MAR-96
C
C     -------
C
C
C       *IU01*   - LOGICAL UNIT FOR INPUT OF TOPOGRAPHIC DATA.
C                  (SEE SUB TOPOAR).                  (topocat)
C       *IU02*   - LOGICAL UNIT FOR INPUT OF CURRENTS.
C                  (SEE SUB READCUR).                 (currcat)
C       *IU05*   - LOGICAL UNIT FOR USER INPUT. (SEE SUB UIPREP).
C       *IU06*   - LOGICAL UNIT FOR PRINTER OUTPUT UNIT
C
      CHARACTER LINE*80
      CHARACTER USERINP*80
      CHARACTER TOPOCAT*80
      CHARACTER CURRCAT*80
C
C ----------------------------------------------------------------------
C
      WRITE (IU06,'(''***   PROGRAM PREPROC   ***'')')
C     ------------------------------------------------
C
C
      WRITE (IU06,'(/,''OLD USER INPUT FILE NAME ?:'')')
C
C*    1 READ INPUT AND PRINT.
C
 1000 CONTINUE
      READ (*,'(A80)') LINE
      IF (LINE(1:1).EQ.'C') GOTO 1000
      READ  (LINE,'(A80)') USERINP
      WRITE (IU06,'(''FILE NAME:  '',A)') USERINP
C
C*    1.1 OPEN USER INPUT FILE
C
      OPEN(IU05,FILE=USERINP,STATUS='OLD',
     +     FORM='FORMATTED',IOSTAT=IERRCODE)
      IF(IERRCODE.GT.0) THEN
	 WRITE (IU06,*) ' *********************************************'
	 WRITE (IU06,*) ' *                                           *'
	 WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. OP_FILES1       *'
	 WRITE (IU06,*) ' *      ===========================          *'
	 WRITE (IU06,*) ' *                                           *'
	 WRITE (IU06,*) ' * CAN NOT OPEN:  ', USERINP
	 WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                   *'
	 WRITE (IU06,*) ' *********************************************'
	 CALL ABORT
      ENDIF
C
C ----------------------------------------------------------------------
C
C
      WRITE (IU06,'(/,''TOPOGRAPHY DATA FILE NAME ?:'')')
C
C*    2 READ INPUT AND PRINT.
C
 2000 CONTINUE
      READ (*,'(A80)') LINE
      WRITE (*,*) LINE
      IF (LINE(1:1).EQ.'C') GOTO 2000
      READ  (LINE,'(A80)') TOPOCAT
      WRITE (IU06,'(''FILE NAME:  '',A)') TOPOCAT
C
C*    2.1 OPEN USER INPUT FILE
C
      OPEN(IU01,FILE=TOPOCAT,STATUS='OLD'
     +     ,FORM='FORMATTED',IOSTAT=IERRCODE)
      IF(IERRCODE.GT.0) THEN
	 WRITE (IU06,*) ' *********************************************'
	 WRITE (IU06,*) ' *                                           *'
	 WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. OP_FILES1       *'
	 WRITE (IU06,*) ' *      ===========================          *'
	 WRITE (IU06,*) ' *                                           *'
	 WRITE (IU06,*) ' * CAN NOT OPEN:  ', TOPOCAT
	 WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                   *'
	 WRITE (IU06,*) ' *********************************************'
	 CALL ABORT
      ENDIF
C
C ----------------------------------------------------------------------
C
C
      WRITE (IU06,'(/,''CURRENT DATA FILE NAME ?:'')')
C
C*    3 READ INPUT AND PRINT.
C
 3000 CONTINUE
      READ (*,'(A80)') LINE
      IF (LINE(1:1).EQ.'C') GOTO 3000
      READ  (LINE,'(A80)') CURRCAT
      WRITE (IU06,'(''FILE NAME:  '',A)') CURRCAT
C
C*    3.1 OPEN USER INPUT FILE
C
      OPEN(IU02,FILE=CURRCAT,STATUS='OLD',
     +    FORM='FORMATTED',IOSTAT=IERRCODE)
      IF(IERRCODE.GT.0) THEN
	 WRITE (IU06,*) ' *********************************************'
	 WRITE (IU06,*) ' *                                           *'
	 WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. OP_FILES1       *'
	 WRITE (IU06,*) ' *      ===========================          *'
	 WRITE (IU06,*) ' *                                           *'
	 WRITE (IU06,*) ' * CAN NOT OPEN:  ', CURRCAT
	 WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                   *'
	 WRITE (IU06,*) ' *********************************************'
	 CALL ABORT
      ENDIF
C
C ----------------------------------------------------------------------
C
      RETURN
      END
C***********************************************************************
      SUBROUTINE OP_FILES2 (IU03, IU06, IU07, IU08, IU09
     1                    , IU10, IU16, IU17, IU18, IU19, IU20
     2                    ,IBOUNC,IBOUNF, IFORM)
C ----------------------------------------------------------------------
C
C**** TAKE NAMES AND OPEN OF INPUT & OUTPUT FILES
C
C     ISAAC GERTMAN    21-MAR-96
C
C     -------
C
C
C       *IU03*   - LOGICAL UNIT FOR INPUT OF COARSE GRID
C                  BOUNDARY ORGANISATION (COMMON CBOUND).
C                  IF THIS IS A FINE GRID PREPROC.
C                  FORMATED IF IFORM = 2 OTHERWISE UNFORMATED.
C                  (SEE SUB MBOUNF).                  (/coarse/bouccatu)
C       *IU06*   - LOGICAL UNIT FOR PRINTER OUTPUT UNIT
C       *IU07*   - LOGICAL UNIT FOR OUTPUT OF GRID ORGANISATION
C                  AND COMPUTED CONSTANTS. (UNFORMATED)
C                  (SEE SUB OUTCOM).                  (/coarse/gridcatu)
C       *IU08*   - LOGICAL UNIT FOR OUTPUT OF COMMON UBUF.
C                  (UNFORMATED) (SEE SUB OUTUBUF).    (/coarse/ubufcatu)
C       *IU09*   - LOGICAL UNIT FOR UNFORMATED OUTPUT OF COARSE
C                  GRID BOUNDARY ORGANISATION (COMMON CBOUND),
C                  IF THIS IS A COARSE GRID PREPROC.
C                  (SEE SUB MBOUNC).                  (/coarse/bouccatu)
C       *IU10*   - LOGICAl UNIT FOR UNFORMATED OUTPUT OF FINE
C                  GRID BOUNDARY ORGANISATION (COMMON CBOUND).
C                  IF THIS IS A FINE GRID PREPROC.
C                  (SEE SUB MBOUNF).                  (/fine/boufcatu)
C       *IU17*   - SAME AS IU07 BUT FORMATED.
C       *IU18*   - SAME AS IU08 BUT FORMATED.
C       *IU19*   - SAME AS IU09 BUT FORMATED.
C       *IU20*   - SAME AS IU10 BUT FORMATED.
C
      CHARACTER LINE*80
      CHARACTER INP_COARS_GRID_BOUND*80
C
      CHARACTER OUT_GRID_ORG_UNF*80
      CHARACTER OUT_COMMON_UBUF_UNF*80
      CHARACTER OUT_COARSE_GRID_UNF*80
      CHARACTER OUT_FINE_GRID_UNF*80
C
      CHARACTER OUT_GRID_ORG_FRM*80
      CHARACTER OUT_COMMON_UBUF_FRM*80
      CHARACTER OUT_COARSE_GRID_FRM*80
      CHARACTER OUT_FINE_GRID_FRM*80
C
C ----------------------------------------------------------------------
C
      WRITE (IU06,'(/,''GRID ORGANISATION OUTPUT FILE NAME ?:'')')
C
C*    1 READ INPUT AND PRINT.
C
 1000 CONTINUE
      READ (*,'(A80)') LINE
      WRITE (*,*) LINE
      IF (LINE(1:1).EQ.'C') GOTO 1000
      I=1
      DO WHILE ( LINE(I:I).EQ.' ' )
	I=I+1
      END DO
      DO WHILE ( LINE(I:I).NE.' ' )
	I=I+1
      END DO
      LINE(I:I+3)='.UNF'
      OUT_GRID_ORG_UNF=LINE
      LINE(I:I+3)='.FRM'
      OUT_GRID_ORG_FRM=LINE
      WRITE (IU06,'(''FILE NAME:  '',A)') OUT_GRID_ORG_FRM
C
C*    1.1 OPEN GRID ORGANISATION OUTPUT FILE FORMATTED OR UNFORMATTED
C
      IF (IFORM.NE.2)
     1   OPEN(IU07,FILE=OUT_GRID_ORG_UNF,
     +    STATUS='NEW',FORM='UNFORMATTED'
     +   ,IOSTAT=IERRCODE)
      IF (IFORM.NE.1)
     1   OPEN(IU17,FILE=OUT_GRID_ORG_FRM,STATUS='NEW',FORM='FORMATTED'
     2   ,IOSTAT=IERRCODE)
      IF(IERRCODE.GT.0) THEN
	 WRITE (IU06,*) ' *********************************************'
	 WRITE (IU06,*) ' *                                           *'
	 WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. OP_FILES2       *'
	 WRITE (IU06,*) ' *      ===========================          *'
	 WRITE (IU06,*) ' *                                           *'
	 WRITE (IU06,*) ' * CAN NOT OPEN: ', OUT_GRID_ORG_UNF
	 WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                   *'
	 WRITE (IU06,*) ' *********************************************'
	 CALL ABORT
      ENDIF
C
C ----------------------------------------------------------------------
C
      WRITE (IU06,'(/,''COMMON UNBUF OUTPUT FILE NAME ?:'')')
C
C*    2 READ INPUT AND PRINT.
C
 2000 CONTINUE
      READ (*,'(A80)') LINE
      IF (LINE(1:1).EQ.'C') GOTO 2000
      I=1
      DO WHILE ( LINE(I:I).EQ.' ' )
	I=I+1
      END DO
      DO WHILE ( LINE(I:I).NE.' ' )
	I=I+1
      END DO
      LINE(I:I+3)='.UNF'
      OUT_COMMON_UBUF_UNF=LINE
      LINE(I:I+3)='.FRM'
      OUT_COMMON_UBUF_FRM=LINE
      WRITE (IU06,'(''FILE NAME:  '',A)') OUT_COMMON_UBUF_FRM
C
C*    2.1 OPEN COMMON UNBUF OUTPUT FILE
C
      IF (IFORM.NE.2)
     1  OPEN(IU08,FILE=OUT_COMMON_UBUF_UNF,
     +       STATUS='NEW',FORM='UNFORMATTED'
     +       ,IOSTAT=IERRCODE)
      IF (IFORM.NE.1)
     +  OPEN(IU18,FILE=OUT_COMMON_UBUF_FRM,
     +  STATUS='NEW',FORM='FORMATTED'
     + ,IOSTAT=IERRCODE)
      IF(IERRCODE.GT.0) THEN
	 WRITE (IU06,*) ' *********************************************'
	 WRITE (IU06,*) ' *                                           *'
	 WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. OP_FILES2       *'
	 WRITE (IU06,*) ' *      ===========================          *'
	 WRITE (IU06,*) ' *                                           *'
	 WRITE (IU06,*) ' * CAN NOT OPEN:  ', OUT_COMMON_UBUF_UNF
	 WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                   *'
	 WRITE (IU06,*) ' *********************************************'
	 CALL ABORT
      ENDIF
C========================================================================
      IF (IBOUNC.EQ.1) THEN
C
C--------  COARSE GRID PREPROC OPTION  ---------------------------
C
	WRITE (IU06,'(/,''COARSE GRID OUTPUT FILE NAME ?:'')')
C
C*    3 READ INPUT AND PRINT.
C
 3000 	CONTINUE
	READ (*,'(A80)') LINE
	IF (LINE(1:1).EQ.'C') GOTO 3000
	I=1
	DO WHILE ( LINE(I:I).EQ.' ' )
	   I=I+1
	END DO
	DO WHILE ( LINE(I:I).NE.' ' )
	   I=I+1
	END DO
	LINE(I:I+3)='.UNF'
	OUT_COARSE_GRID_UNF=LINE
	LINE(I:I+3)='.FRM'
	OUT_COARSE_GRID_FRM=LINE
	WRITE (IU06,'(''FILE NAME:  '',A)') OUT_COARSE_GRID_FRM
C
C*    3.1 OPEN COARSE GRID OUTPUT FILE FORMATTED OR UNFORMATTED
C
	IF (IFORM.NE.2)
     1    OPEN(IU09,FILE=OUT_COARSE_GRID_UNF,
     +      STATUS='NEW',FORM='UNFORMATTED'
     2   ,IOSTAT=IERRCODE)
	IF (IFORM.NE.1)
     1	  OPEN(IU19,FILE=OUT_COARSE_GRID_FRM,
     +    STATUS='NEW',FORM='FORMATTED'
     2   ,IOSTAT=IERRCODE)
	IF(IERRCODE.GT.0) THEN
		WRITE (IU06,*) ' *********************************************'
		WRITE (IU06,*) ' *                                           *'
		WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. OP_FILES2       *'
		WRITE (IU06,*) ' *      ===========================          *'
		WRITE (IU06,*) ' *                                           *'
		WRITE (IU06,*) ' * CAN NOT OPEN:  ', OUT_COARSE_GRID_UNF
		WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                   *'
		WRITE (IU06,*) ' *********************************************'
		CALL ABORT
	ENDIF
C---------------------------------------------------------------
      ENDIF

      IF (IBOUNF.EQ.1) THEN
C---  FINE GRID PREPROC OPTION  --------------------------------
	WRITE (IU06,'(/,''COARSE GRID INPUT  FILE NAME ?:'')')
C
C*    4 READ INPUT AND PRINT.
C
 4000 	CONTINUE
	READ (*,'(A80)') LINE
	IF (LINE(1:1).EQ.'C') GOTO 4000
C 12SEP98 Isaac: Take COARSE GRID INPUT FILE UNFORMATTED ONLY
      I=1
	DO WHILE ( LINE(I:I).EQ.' ' )
	   I=I+1
	END DO
	DO WHILE ( LINE(I:I).NE.' ' )
	   I=I+1
	END DO
	LINE(I:I+3)='.UNF'
	INP_COARS_GRID_BOUND=LINE
	WRITE (IU06,'(''FILE NAME:  '',A)') INP_COARS_GRID_BOUND
C
C*    4.1 OPEN COARSE GRID INPUT FILE UNFORMATTED
C
	OPEN(IU03,FILE=INP_COARS_GRID_BOUND,
     +    STATUS='OLD',FORM='UNFORMATTED'
     1   ,IOSTAT=IERRCODE)
	
	IF(IERRCODE.GT.0) THEN
		WRITE (IU06,*) ' *********************************************'
		WRITE (IU06,*) ' *                                           *'
		WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. OP_FILES2       *'
		WRITE (IU06,*) ' *      ===========================          *'
		WRITE (IU06,*) ' *                                           *'
		WRITE (IU06,*) ' * CAN NOT OPEN:  ', INP_COARS_GRID_BOUND
		WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                   *'
		WRITE (IU06,*) ' *********************************************'
		CALL ABORT
	ENDIF
C
C ----------------------------------------------------------------------
C
	WRITE (IU06,'(/,''FINE GRID OUTPUT FILE NAME ?:'')')
C
C*    5 READ INPUT AND PRINT.
C
 5000 	CONTINUE
	READ (*,'(A80)') LINE
	IF (LINE(1:1).EQ.'C') GOTO 5000
	I=1
	DO WHILE ( LINE(I:I).EQ.' ' )
	   I=I+1
	END DO
	DO WHILE ( LINE(I:I).NE.' ' )
	   I=I+1
	END DO
	LINE(I:I+3)='.UNF'
	OUT_FINE_GRID_UNF=LINE
	LINE(I:I+3)='.FRM'
	OUT_FINE_GRID_FRM=LINE
	WRITE (IU06,'(''FILE NAME:  '',A)') OUT_FINE_GRID_FRM
C
C*    5.1 OPEN FINE GRID OUTPUT FILE FORMATTED OR UNFORMATTED
C
	IF (IFORM.NE.2)
     1   OPEN(IU10,FILE=OUT_FINE_GRID_UNF,
     +   STATUS='NEW',FORM='UNFORMATTED'
     2   ,IOSTAT=IERRCODE)
	IF (IFORM.NE.1)
     1   OPEN(IU20,FILE=OUT_FINE_GRID_FRM,
     +    STATUS='NEW',FORM='FORMATTED'
     2   ,IOSTAT=IERRCODE)
	IF(IERRCODE.GT.0) THEN
		WRITE (IU06,*) ' *********************************************'
		WRITE (IU06,*) ' *                                           *'
		WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. OP_FILES2       *'
		WRITE (IU06,*) ' *      ===========================          *'
		WRITE (IU06,*) ' *                                           *'
		WRITE (IU06,*) ' * CAN NOT OPEN:  ', OUT_FINE_GRID_UNF
		WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                   *'
		WRITE (IU06,*) ' *********************************************'
		CALL ABORT
	ENDIF
      ENDIF
	RETURN
      END
C***********************************************************************
      SUBROUTINE ADJUST(WEST, EAST)

C ----------------------------------------------------------------------
C
C**** *ADJUST* - ROUTINE TO CORRECT BORDERS OF INTERVALS.
C
C     H.GUNTHER            ECMWF       04/04/1990
C
C*    PURPOSE.
C     -------
C
C       ADJUSTS INTERVAL BORDERS GIVEN IN DEGREE.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *ADJUST (WEST, EAST)*
C          *WEST*    - LEFT INTERVAL BORDER IN DEGREE.
C          *EAST*    - RIGHT INTERVAL BORDER IN DEGREE.
C
C     METHOD.
C     -------
C
C       THE INTERVAL BORDERS ARE CHANGED TO FULLFILL:
C         0. .LE. EAST  .AND. EAST .LT. 360. .AND. WEST .LE. EAST
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C* 1. CORRECT BORDERS.
C     ----------------

      WEST = AMODA(WEST+720.,360.)
      EAST = AMODA(EAST+720.,360.)
      IF (WEST.GT.EAST) WEST = WEST-360.


      RETURN
      END
      REAL FUNCTION AKI (OM, BETA)

C ----------------------------------------------------------------------
C
C**** *AKI* - FUNCTION TO COMPUTE WAVE NUMBER.
C
C     G. KOMEN, P. JANSSEN   KNMI        01/06/1986
C
C*    PURPOSE.
C     -------
C
C       *AKI* COMPUTES THE WAVE NUMBER AS FUNCTION OF
C             CIRCULAR FREQUENCY AND WATER DEPTH.
C
C**   INTERFACE.
C     ----------
C
C       *FUNCTION* *AKI (OM, BETA)*
C          *OM*      - CIRCULAR FREQUENCY.
C          *BETA*    - WATER DEPTH.
C
C     METHOD.
C     -------
C
C       NEWTONS METHOD TO SOLVE THE DISPERSION RELATION IN SHALLOW
C       WATER.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER* OF GLOBAL CONSTANTS.
C
      PARAMETER (G = 9.806, PI = 3.14159265358978, CIRC = 40000000.,
     1           ZPI = 2.*PI, RAD = PI/180., DEG = 180./PI,
     2           R = CIRC/ZPI)
C
C*    *PARAMETER*  RELATIVE ERROR LIMIT OF NEWTON'S METHOD.
C
      PARAMETER (EBS = 0.0001)
C
C ----------------------------------------------------------------------
C
C*    1. START VALUE:  MAXIMUM FROM DEEP  AND EXTREM SHALLOW WATER
C                      WAVE NUMBER.
C        ---------------------------------------------------------
C
 1000 CONTINUE
      AKM1=OM**2/(4.*G)
      AKM2=OM/(2.*SQRT(G*BETA))
      AO=AMAX1(AKM1,AKM2)
C
C ----------------------------------------------------------------------
C
C*    2. ITERATION LOOP.
C        ---------------
C
 2000 CONTINUE
      AKP = AO
      BO = BETA*AO
      IF (BO.GT.10.) THEN
        AKI = OM**2/G
      ELSE
        TH = G*AO*TANH(BO)
        STH = SQRT(TH)
        AO = AO+(OM-STH)*STH*2./(TH/AO+G*BO/COSH(BO)**2)
        IF (ABS(AKP-AO).GT.EBS*AO) GO TO 2000
        AKI = AO
      ENDIF

      RETURN
      END
      SUBROUTINE CHECK (IREFRA, ML, KL, IINPC)

C ----------------------------------------------------------------------
C
C**** *CHECK* - ROUTINE TO CHECK CONSISTENCY BETWEEN COMPUTED BLOCKS.
C
C     H.GUNTHER            ECMWF       04/04/1990
C
C*    PURPOSE.
C     -------
C
C       *CHECK* CHECKS CONSISTENCY BETWEEN BLOCK INDICES.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *CHECK (IREFRA, ML, KL, IINPC)*
C          *IREFRA*  - REFRACTION OPTION.
C          *ML*      - NUMBER OF FREQUENCIES.
C          *KL*      - NUMBER OF DIRECTIONS.
C          *IINPC*   - NUMBER INPUT POINTS FROM A PREVIOUS COARSE GRID.
C
C     METHOD.
C     -------
C
C       NONE.
C
C     EXTERNALS.
C     ----------
C
C       *ABORT*     - TERMINATES PROCESSING.
C       *OUTPP*     - WRITE OUT A GRID.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
       INCLUDE 'preprowk.h'
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS FOR PREPROC ONLY.
C
      PARAMETER (NBMAX = (NGX+NGY)*2-4)
C
C*    *COMMON* *CPBOUN* USED FOR THE COURSE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /CPBOUN/ IBOUNC, NBOUNC(NESTMAX), 
     1                IJARC(NBMAX), IGARC(NBMAX),
     1                DLAMAC, DPHIAC, AMOSOC(NESTMAX), 
     1                AMONOC(NESTMAX), AMOEAC(NESTMAX), AMOWEC(NESTMAX),
     2                BLATC(NBMAX), BLNGC(NBMAX)

      COMMON /CCHECK/ IJJARC(NBMAX,NESTMAX), IGGARC(NBMAX,NESTMAX)
C
C*    *COMMON* *FPBOUN* USED FOR THE FINE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /FPBOUN/ IBOUNF, NBOUNF, IJARF(NBMAX), IGARF(NBMAX),
     1                IBFL(NBMAX), IBFR(NBMAX), BFW(NBMAX)
C
C*    *COMMON* *COUT*  OUTPUT POINTS INDICES AND FLAGS.
C
      LOGICAL FFLAG(14), FFLAG20, FFLAG21, FFLAG25, FFLAG26,
     1        PFLAG(14), PFLAG20, PFLAG21, PFLAG25, PFLAG26
      COMMON /COUT/ NGOUT, IGAR(MOUTP), IJAR(MOUTP),
     1              NOUTT, IOUTT(MOUTT),
     2              FFLAG, FFLAG20, FFLAG21, FFLAG25, FFLAG26,
     3              PFLAG, PFLAG20, PFLAG21, PFLAG25, PFLAG26
C
C*    *COMMON* *CURRENT* - CURRENT FIELD.
C
      COMMON /CURRENT/ U(0:NIBLC,NBLC), V(0:NIBLC,NBLC)
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *SHALLOW*   SHALLOW WATER TABLES.
C
      PARAMETER (NDEPTH = 63)
C
      COMMON /SHALLOW/ DEPTH(NIBLO, NBLO), DEPTHA, DEPTHD,
     1                 TCGOND(NDEPTH,NFRE), TFAK(NDEPTH,NFRE),
     2                 TSIHKD(NDEPTH,NFRE), INDEP(NIBLO)
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER* OF GLOBAL CONSTANTS.
C
      PARAMETER (G = 9.806, PI = 3.14159265358978, CIRC = 40000000.,
     1           ZPI = 2.*PI, RAD = PI/180., DEG = 180./PI,
     2           R = CIRC/ZPI)
C
      CHARACTER*1 LST(NGX,NGY)
      CHARACTER TITL*100
      DIMENSION GRID(NGX,NGY)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *LSTAB*     CHARACTER  LAND SEA TABLE  L = LAND
C                                             S = SEA
C                                             + = SEA AND OUTPUT POINT.
C      *GRID*      REAL       ARRAY FOR GRIDDED PRINT OUTPUT.
C
C ----------------------------------------------------------------------
C
C*    1. COMPARE LENGTH OF OVERLAPPING LAT.
C        -----------------------------------
C
 1000 CONTINUE
      DO 1001 IG=1,IGL-1
         IU1 = IJS(IG+1)-1
         IO2 = IJL(IG)-IJLS(IG)+1
         IF (IU1.NE.IO2) THEN
            WRITE (IU06,*) ' *****************************************'
            WRITE (IU06,*) ' *                                       *'
            WRITE (IU06,*) ' *      FATAL ERROR IN SUB. CHECK        *'
            WRITE (IU06,*) ' *      =========================        *'
            WRITE (IU06,*) ' *                                       *'
            WRITE (IU06,*) ' * LENGTH OF FIRST LAT. IN BLOCK IG+1    *'
            WRITE (IU06,*) ' * IS NOT EQUAL TO SECOND TO LAST OF     *'
            WRITE (IU06,*) ' * BLOCK IG                              *'
            WRITE (IU06,*) ' * BLOCK  NUMBER IS IG = ', IG
            WRITE (IU06,*) ' * LENGTH IN BLOCK IG   IS IU1 = ', IU1
            WRITE (IU06,*) ' * LENGTH IN BLOCK IG+1 IS IO2 = ', IO2
            WRITE (IU06,*) ' *                                       *'
            WRITE (IU06,*) ' *****************************************'
         ENDIF
         IU2 = IJL2(IG+1)-IJS(IG+1)+1
         IO1 = IJLT(IG)-IJL(IG)
         IF (IU2.NE.IO1) THEN
            WRITE (IU06,*) ' *****************************************'
            WRITE (IU06,*) ' *                                       *'
            WRITE (IU06,*) ' *      FATAL ERROR IN SUB. CHECK        *'
            WRITE (IU06,*) ' *      =========================        *'
            WRITE (IU06,*) ' *                                       *'
            WRITE (IU06,*) ' * LENGTH OF SECOND LAT. IN BLOCK IG+1   *'
            WRITE (IU06,*) ' * IS NOT EQUAL TO LAST OF BLOCK IG      *'
            WRITE (IU06,*) ' * BLOCK  NUMBER IS IG = ', IG
            WRITE (IU06,*) ' * LENGTH IN BLOCK IG   IS IU2 = ', IU2
            WRITE (IU06,*) ' * LENGTH IN BLOCK IG+1 IS IO1 = ', IO1
            WRITE (IU06,*) ' *                                       *'
            WRITE (IU06,*) ' *****************************************'
         ENDIF
 1001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    2. GENERATE LAND SEA TABLE FROM INDEX ARRAYS.
C        ------------------------------------------
C
 2000 CONTINUE
      DO 2001 K=1,NY
      DO 2001 I=1,NX
         LST(I,K) = 'L'
 2001 CONTINUE

      IERR = 0
      DO 2002 IG=1,IGL
         DO 2003 IJ=IJS(IG),IJL(IG)
            IF (IXLG(IJ,IG).NE.0.OR.KXLT(IJ,IG).NE.0)
     1          LST(IXLG(IJ,IG),KXLT(IJ,IG)) = 'S'
 2003    CONTINUE
 2002 CONTINUE
C
C*    2.1 INCLUDE OUTPUT POINTS.
C         ----------------------
C
 2100 CONTINUE
      IF (NGOUT.GT.0) THEN
         DO 2101 IO=1,NGOUT
            IG = IGAR(IO)
            IJ = IJAR(IO)
            IF (IG.LT.1.OR.IG.GT.IGL) THEN
               IERR = IERR+1
               WRITE (IU06,*) ' ***************************************'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' *      FATAL ERROR IN SUB. CHECK      *'
               WRITE (IU06,*) ' *      =========================      *'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' * BLOCK NUMBER OF OUTPUT POINT IS     *'
               WRITE (IU06,*) ' * OUT OF RANGE.                       *'
               WRITE (IU06,*) ' * OUTPUT POINT NUMBER IS  IO = ', IO
               WRITE (IU06,*) ' * BLOCK NUMBER IS         IG = ', IG
               WRITE (IU06,*) ' * MAX. BLOCK NUMBER IS   IGL = ', IGL
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' ***************************************'
               IF (IERR.GT.20) CALL ABORT
            ENDIF
            IF (IJ.LT.IJS(IG).OR.IJ.GT.IJL(IG)) THEN
               IERR = IERR+1
               WRITE (IU06,*) ' ***************************************'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' *      FATAL ERROR IN SUB. CHECK      *'
               WRITE (IU06,*) ' *      =========================      *'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' * GRID POINT NUMBER OF OUTPUT POINT IS*'
               WRITE (IU06,*) ' * OUT OF RANGE.                       *'
               WRITE (IU06,*) ' * OUTPUT POINT NUMBER IS IO = ', IO
               WRITE (IU06,*) ' * GRID POINT NUMBER IS   IJ = ', IJ
               WRITE (IU06,*) ' * MIN. NUMBER IS        IJS = ', IJS(IG)
               WRITE (IU06,*) ' * MAX. NUMBER IS        IJL = ', IJL(IG)
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' ***************************************'
               IF (IERR.GT.20) CALL ABORT
            ENDIF
            IF (IXLG(IJ,IG).NE.0.OR.KXLT(IJ,IG).NE.0)
     1          LST(IXLG(IJ,IG),KXLT(IJ,IG)) = '+'
 2101    CONTINUE
      ENDIF
C
C*    2.2 INCLUDE COARSE GRID NEST OUTPUT POINTS.
C         ---------------------------------------
C
 2200 CONTINUE
      IF (IBOUNC.EQ.1) THEN
         DO NEST = 1,NESTS
               WRITE (IU06, *) '*************************'
               WRITE (IU06, *) 'NEST NUMBER:', NEST
               WRITE (IU06, *) '*************************'
         DO 2201 IO=1,NBOUNC(NEST)
            IG = IGGARC(IO,NEST)
            IJ = IJJARC(IO,NEST)
            IF (IG.LT.1.OR.IG.GT.IGL) THEN
               IERR = IERR+1
               WRITE (IU06,*) ' ***************************************'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' *      FATAL ERROR IN SUB. CHECK      *'
               WRITE (IU06,*) ' *      =========================      *'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' * BLOCK NUMBER OF OUTPUT POINT IS     *'
               WRITE (IU06,*) ' * OUT OF RANGE.                       *'
               WRITE (IU06,*) ' * BOUNDARY POINT NUMBER IS  IO = ', IO
               WRITE (IU06,*) ' * BLOCK NUMBER IS         IG = ', IG
               WRITE (IU06,*) ' * MAX. BLOCK NUMBER IS   IGL = ', IGL
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' ***************************************'
               IF (IERR.GT.20) CALL ABORT
            ENDIF
            IF (IJ.LT.IJS(IG).OR.IJ.GT.IJL(IG)) THEN
               IERR = IERR+1
               WRITE (IU06,*) ' ***************************************'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' *      FATAL ERROR IN SUB. CHECK      *'
               WRITE (IU06,*) ' *      =========================      *'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' * GRID POINT NUMBER OF OUTPUT POINT IS*'
               WRITE (IU06,*) ' * OUT OF RANGE.                       *'
               WRITE (IU06,*) ' * BOUNDARY POINT NUMBER IS IO = ', IO
               WRITE (IU06,*) ' * GRID POINT NUMBER IS   IJ = ', IJ
               WRITE (IU06,*) ' * MIN. NUMBER IS        IJS = ', IJS(IG)
               WRITE (IU06,*) ' * MAX. NUMBER IS        IJL = ', IJL(IG)
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' ***************************************'
               IF (IERR.GT.20) CALL ABORT
            ENDIF
            IF (IXLG(IJ,IG).NE.0.OR.KXLT(IJ,IG).NE.0)
     1          LST(IXLG(IJ,IG),KXLT(IJ,IG)) = '/'
 2201    CONTINUE
      END DO
      ENDIF
C
C*    2.3 INCLUDE FINE GRID NEST INPUT POINTS.
C         ------------------------------------
C
 2300 CONTINUE
      IF (IBOUNF.EQ.1) THEN
         DO 2301 IO=1,NBOUNF
            IG = IGARF(IO)
            IJ = IJARF(IO)
            IF (IG.LT.1.OR.IG.GT.IGL) THEN
               IERR = IERR+1
               WRITE (IU06,*) ' ***************************************'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' *      FATAL ERROR IN SUB. CHECK      *'
               WRITE (IU06,*) ' *      =========================      *'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' * BLOCK NUMBER OF OUTPUT POINT IS     *'
               WRITE (IU06,*) ' * OUT OF RANGE.                       *'
               WRITE (IU06,*) ' * BOUNDARY POINT NUMBER IS  IO = ', IO
               WRITE (IU06,*) ' * BLOCK NUMBER IS         IG = ', IG
               WRITE (IU06,*) ' * MAX. BLOCK NUMBER IS   IGL = ', IGL
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' ***************************************'
               IF (IERR.GT.20) CALL ABORT
            ENDIF
            IF (IJ.LT.IJS(IG).OR.IJ.GT.IJL(IG)) THEN
               IERR = IERR+1
               WRITE (IU06,*) ' ***************************************'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' *      FATAL ERROR IN SUB. CHECK      *'
               WRITE (IU06,*) ' *      =========================      *'
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' * GRID POINT NUMBER OF OUTPUT POINT IS*'
               WRITE (IU06,*) ' * OUT OF RANGE.                       *'
               WRITE (IU06,*) ' * BOUNDARY POINT NUMBER IS IO = ', IO
               WRITE (IU06,*) ' * GRID POINT NUMBER IS   IJ = ', IJ
               WRITE (IU06,*) ' * MIN. NUMBER IS        IJS = ', IJS(IG)
               WRITE (IU06,*) ' * MAX. NUMBER IS        IJL = ', IJL(IG)
               WRITE (IU06,*) ' *                                     *'
               WRITE (IU06,*) ' ***************************************'
               IF (IERR.GT.20) CALL ABORT
            ENDIF
            IF (IXLG(IJ,IG).NE.0.OR.KXLT(IJ,IG).NE.0)
     1          LST(IXLG(IJ,IG),KXLT(IJ,IG)) = 'B'
 2301    CONTINUE
      ENDIF
C
C*    2.4 PRINT LAND SEA MAP.
C         -------------------
C
 2400 CONTINUE
      ILEN = 120
      IPAGE = (NX+ILEN-1)/ILEN
      IF (IPAGE.GT.1) THEN
         LAST = (NX-ILEN*(IPAGE-1)+IPAGE-2)/(IPAGE-1)
         IF (LAST.LE.10) THEN
            ILEN = ILEN + 10
            IPAGE = (NX+ILEN-1)/ILEN
         ENDIF
      ENDIF
      DO 2401 L=1,IPAGE
         IA = (L-1)*ILEN
         IE = MIN(IA+ILEN,NX)
         IA = IA + 1
         BMOWEP = AMOWEP +REAL(IA-1)*XDELLO
         BMOEAP = AMOWEP +REAL(IE-1)*XDELLO
         WRITE (IU06,'(1H1,'' LAND SEA MAP OF FULL GRID '',
     1               ''   L = LAND  S = SEA  + = OUTPUT POINT'',
     2               ''                PAGE: '',I2)') L
         WRITE (IU06,'(2X,''LONGITUDE IS FROM '',F7.2,'' TO '',F7.2)')
     1              BMOWEP, BMOEAP
         WRITE (IU06,'(2X,''LATITUDE  IS FROM '',F7.2,'' TO '',F7.2)')
     1              AMONOP, AMOSOP
         WRITE (IU06,'(2X,130I1)') (AMODA(I,10),I=IA,IE)
         DO 2402 K=NY,1,-1
            WRITE (IU06,'(1X,I1,130A1)') AMODA(K,10),(LST(I,K),I=IA,IE)
 2402    CONTINUE
         WRITE (IU06,'(2X,130I1)') (AMODA(I,10),I=IA,IE)
 2401 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    3. OUTPUT OF DEPTH FIELD.
C        ----------------------
C
 3000 CONTINUE
      DO 3001 K=1,NY
      DO 3001 I=1,NX
          GRID(I,K) = 99999
 3001 CONTINUE

      DO 3002 IG=1,IGL
         DO 3003 IJ=IJS(IG),IJL(IG)
             GRID(IXLG(IJ,IG),NY+1-KXLT(IJ,IG)) = MIN(DEPTH(IJ,IG),999.)
 3003    CONTINUE
 3002 CONTINUE

      TITL = 'WATER DEPTH IN METERS. '//
     1       '(DEPTH DEEPER THAN 999M ARE PRINTED AS 999)'
      CALL OUTPP (0, IU06, TITL, 1., GRID)
C
C ----------------------------------------------------------------------
C
C*    4. OUTPUT OF CURRENT FIELD.
C        ------------------------
C
 4000 CONTINUE

      IF (IREFRA.LT.2) GOTO 5000

      DO 4001 K=1,NY
      DO 4001 I=1,NX
          GRID(I,K) = 99999
 4001 CONTINUE

      DO 4002 IG=1,IGL
         DO 4003 IJ=IJS(IG),IJL(IG)
             GRID(IXLG(IJ,IG),NY+1-KXLT(IJ,IG)) =
     1          SQRT(U(IJ,IG)**2+V(IJ,IG)**2)
 4003    CONTINUE
 4002 CONTINUE

      TITL = 'CURRENT SPEED IN 0.01 METRES/SECOND '
      CALL OUTPP (0, IU06, TITL, 100., GRID)

      DO 4101 K=1,NY
      DO 4101 I=1,NX
          GRID(I,K) = 99999
 4101 CONTINUE

      DO 4102 IG=1,IGL
         DO 4103 IJ=IJS(IG),IJL(IG)
             GRID(IXLG(IJ,IG),NY+1-KXLT(IJ,IG)) =
     1           AMODA(ATAN2(U(IJ,IG),V(IJ,IG)+0.1E-10)*DEG+360.,360.)
 4103    CONTINUE
 4102 CONTINUE

      TITL = 'CURRENT DIRECTIOM IN DEGREES (CLOCKWISE FROM NORTH)'
      CALL OUTPP (0, IU06, TITL, 1., GRID)
C
C ----------------------------------------------------------------------
C
C*    5. OUTPUT OF OVERALL GRID INFORMATION.
C        -----------------------------------
C
 5000 CONTINUE
      WRITE (IU06,'(1H1,'' GRID SUMMERY:'')')
      WRITE (IU06,*) ' NUMBER OF BLOCKS GENERATED IS IGL ....: ', IGL
      IJFLAT = 0
      IJLLAT = 0
      IJMAX = 0
      ISEA = 0
      IPOI = 0
      DO 5001 IG=1,IGL
         IJFLAT= MAX(IJFLAT,IJS(IG)-1)
         IJLLAT= MAX(IJLLAT,IJLT(IG)-IJL(IG))
         IJMAX = MAX(IJMAX,IJLT(IG))
         IPOI  = IPOI + IJLT(IG)
         ISEA  = ISEA + IJL(IG)-IJS(IG) + 1
 5001 CONTINUE
      IOV = IPOI-ISEA
      WRITE (IU06,*) ' MAXIMUM NUMBER OF POINTS IN A BLOCK ..: ', IJMAX
      WRITE (IU06,*) ' TOTAL NUMBER OF POINT IN ALL BLOCKS ..: ', IPOI
      WRITE (IU06,*) ' TOTAL NUMBER OF SEA POINTS ...........: ', ISEA
      WRITE (IU06,*) ' TOTAL NUMBER OF POINTS IN OVERLAP.....: ', IOV
      WRITE (IU06,*) ' MAXIMUM LENGTH OF FIRST LAT OF A BLOCK: ', IJFLAT
      WRITE (IU06,*) ' MAXIMUM LENGTH OF LAST  LAT OF A BLOCK: ', IJLLAT
C
C ----------------------------------------------------------------------
C
C*    6. OUTPUT OF OPTIMAL DIMENSIONS.
C        -----------------------------
C
 6000 CONTINUE
      WRITE (IU06,'(//,'' DIMENSIONS OF ARRAYS, WHICH ARE USED'',
     1             '' IN PRESET AND CHIEF '',/)')
      WRITE (IU06,'(''                                     DEFINED'',
     1           ''      USED'',''  REQUIRED'')')
      WRITE (IU06,'('' NUMBER OF DIRECTIONS        NANG '', 3I10)')
     1           NANG, KL, KL
      WRITE (IU06,'('' NUMBER OF FREQUENCIES       NFRE '', 3I10)')
     1           NFRE, ML, ML
      WRITE (IU06,'('' NUMBER LONGITUDE GRID POINTS NGX '', 3I10)')
     1           NGX, NX, NX
      WRITE (IU06,'('' NUMBER LATITUDE GRID POINTS  NGY '', 3I10)')
     1           NGY, NY, NY
      WRITE (IU06,'('' NUMBER OF BLOCKS            NBLO '', 3I10)')
     1           NBLO, IGL, NBLO
      WRITE (IU06,'('' MAXIMUM BLOCK LENGTH       NIBLO '', 3I10)')
     1           NIBLO, IJMAX, NIBLO
      WRITE (IU06,'('' NUMBER POINTS IN FIRST LAT NOVER '', 3I10)')
     1           NOVER, MAX(1,IJFLAT), MAX(1,IJFLAT)
      WRITE (IU06,'('' NUMBER OF OUTPUT POINTS    MOUTP '', 3I10)')
     1           MOUTP, MAX(1,NGOUT), MOUTP
      DO NEST = 1,NESTS
      WRITE (IU06,'('' BOUNDARY POINTS (COURSE).  NMAXC '', 3I10)')
     1           NMAXC, MAX(1,NBOUNC(NEST)), MAX(1,NBOUNC(NEST))
      END DO
      WRITE (IU06,'('' BOUNDARY POINTS (FINE).    NMAXF '', 3I10)')
     1           NMAXF, MAX(1,NBOUNF), MAX(1,NBOUNF)
      WRITE (IU06,'('' BOUNDARY POINTS (INPUT)    NBINP '', 3I10)')
     1           NBINP, MAX(1,IINPC), MAX(1,IINPC)

      IF (IGL.EQ.1) THEN
         WRITE (IU06,'('' 1 BLOCK VERSION           NIBL1 '', 3I10)')
     1           NIBL1, 1, 1
      ELSE
         WRITE (IU06,'('' MULTI BLOCK VERSION        NIBL1 '', 3I10)')
     1           NIBL1, IJMAX, NIBLO
      ENDIF
      IF (IREFRA.EQ.0) THEN
         WRITE (IU06,'('' DEPTH REFRAC. BLOCK LENGTH NIBLD '', 3I10)')
     1           NIBLD, 1, 1
         WRITE (IU06,'('' DEPTH REFRAC. BLOCK NUMBER  NBLD '', 3I10)')
     1           NBLD, 1, 1
         WRITE (IU06,'('' CURR. REFRAC. BLOCK LENGTH NIBLC '', 3I10)')
     1           NIBLC, 1, 1
         WRITE (IU06,'('' CURR. REFRAC. BLOCK NUMBER  NBLC '', 3I10)')
     1           NBLC, 1, 1
      ELSE IF (IREFRA.EQ.1) THEN
         WRITE (IU06,'('' DEPTH REFRAC. BLOCK LENGTH NIBLD '', 3I10)')
     1           NIBLD, IJMAX, NIBLO
         WRITE (IU06,'('' DEPTH REFRAC. BLOCK NUMBER  NBLD '', 3I10)')
     1           NBLD, IGL, NBLO
         WRITE (IU06,'('' CURR. REFRAC. BLOCK LENGTH NIBLC '', 3I10)')
     1           NIBLC, 1, 1
         WRITE (IU06,'('' CURR. REFRAC. BLOCK NUMBER  NBLC '', 3I10)')
     1           NBLC, 1, 1
      ELSE IF (IREFRA.EQ.2) THEN
         WRITE (IU06,'('' DEPTH REFRAC. BLOCK LENGTH NIBLD '', 3I10)')
     1           NIBLD, IJMAX, NIBLO
         WRITE (IU06,'('' DEPTH REFRAC. BLOCK NUMBER  NBLD '', 3I10)')
     1           NBLD, IGL, NBLO
         WRITE (IU06,'('' CURR. REFRAC. BLOCK LENGTH NIBLC '', 3I10)')
     1           NIBLC, IJMAX, NIBLO
         WRITE (IU06,'('' CURR. REFRAC. BLOCK NUMBER  NBLC '', 3I10)')
     1           NBLC, IGL, NBLO
      ENDIF

      WRITE (IU06,'('' SHALLOW WATER TABLE LEN.  NDEPTH '', 3I10)')
     1           NDEPTH, NDEPTH, NDEPTH

      WRITE (IU06,'(/,'' THE DIMENSIONS IN PRESET AND CHIEF HAVE TO '',
     1             '' BE THE VALUES IN COLUMN - REQUIRED - '')')
      WRITE (IU06,'(  '' IF YOU WANT TO USE THE OPTIMAL DIMENSION'',
     1             '' LENGTH IN THE WAMODEL, THEN  '',/,
     2             '' RERUN PREPROC WITH THE DIMENSION'',
     3             '' GIVEN AS -USED-'')')

      RETURN
      END
      SUBROUTINE FINDB (NDIM, NBOUN, BLATB, BLNGB, IGARB, IJARB)

C ----------------------------------------------------------------------
C
C**** *FINDB* - FIND BLOCK AND GRID POINT NUMBER.
C
C     R. PORTZ     MPI         15/01/1991
C
C*    PURPOSE.
C     -------
C
C       FIND BLOCK AND GRID POINT NUMBER FOR A GIVEN ARRAY
C       OF LONGITUDES AND LATITUDES.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *FINDB (NDIM, NBOUN, BLATB, BLNGB, IGARB, IJARB)*
C          *NDIM*    - DIMENSION OF ARRAYS.
C          *NBOUN*   - NUMBER OF POINTS IN ARRAYS.
C          *BLATB*   - INPUT LATITUDES.
C          *BLNGB*   - INPUT LONGITUDES.
C          *IGARB*   - OUTPUT BLOCK NUMBERS.
C          *IJARB*   - OUTPUT SEA POINT NUMBERS.
C
C     METHOD.
C     -------
C
C       NONE.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C
       INCLUDE 'preprowk.h'
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C ----------------------------------------------------------------------
C
      DIMENSION BLATB(NDIM), BLNGB(NDIM), IGARB(NDIM), IJARB(NDIM)
C
C ----------------------------------------------------------------------
C
C*    1. LOOP OVER INPUT LATITUDES, LONGITUDES.
C        --------------------------------------
C
 1000 CONTINUE
      DO 1001 IO = 1,NBOUN
C
C*    1.1 COMPUTE GRID MATRIX INDICES.
C         ----------------------------
C
         IOLT = NINT((BLATB(IO)-AMOSOP)/XDELLA+1.0)
         ALONG = AMODA(BLNGB(IO)-AMOWEP+720.,360.)
         IOLG = NINT(ALONG/XDELLO+1.0)
         IF ((AMOWEP+(IOLG-1)*XDELLO.EQ.AMOEAP+XDELLO)
     1     .AND. IPER.EQ.1) IOLG = 1
C
C*    1.2 SEARCH BLOCK NUMBER AND SEA POINT NUMBER.
C         -----------------------------------------
C
         DO 1201 IG=1,IGL
         DO 1201 IJ = IJS(IG),IJL(IG)
            IF (IXLG(IJ,IG).EQ.IOLG .AND. KXLT(IJ,IG).EQ.IOLT) THEN
               IGARB(IO) = IG
               IJARB(IO) = IJ
               GOTO 1001
            ENDIF
 1201    CONTINUE
         IGARB(IO) = 0
         IJARB(IO) = 0
 1001 CONTINUE

      RETURN
      END
      INTEGER FUNCTION JAFU (CL, J, IAN)

C ----------------------------------------------------------------------
C
C**** *JAFU* - FUNCTION TO COMPUTE THE INDEX ARRAY FOR THE
C              ANGLES OF THE INTERACTING WAVENUMBERS.
C
C     S. HASSELMANN        MPIFM        01/12/1985.
C
C*    PURPOSE.
C     --------
C
C       INDICES DEFINING BINS IN FREQUENCY AND DIRECTION PLANE INTO
C       WHICH NONLINEAR ENERGY TRANSFER INCREMENTS ARE STORED. NEEDED
C       FOR COMPUTATION OF THE NONLINEAR ENERGY TRANSFER.
C
C**   INTERFACE.
C     ----------
C
C       *FUNCTION* *JAFU (CL, J, IAN)*
C          *CL*  - WEIGHTS.
C          *J*   - INDEX IN ANGULAR ARRAY.
C          *IAN* - NUMBER OF ANGLES IN ARRAY.
C
C     METHOD.
C     -------
C
C       SEE REFERENCE.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C        S. HASSELMANN AND K. HASSELMANN,JPO, 1985 B.
C
C ----------------------------------------------------------------------
C
      IDPH = CL
      JA = J+IDPH
      IF (JA.LE.0)   JA = IAN+JA-1
      IF (JA.GE.IAN) JA = JA-IAN+1
      JAFU = JA

      RETURN
      END
      SUBROUTINE LOCINT (IG, IJS, IJL, NC, NR, KCOL, KROW, IGPER,
     1                  DLAM, DPHI, RLONL, RLATS, U, V, US, DS)

C ----------------------------------------------------------------------
C
C**** *LOCINT* - LOCATE WAM POINT IN INPUT GRID AND INTERPOLATE.
C
C     H. GUNTHER    ECMWF/GKSS  DECEMBER 1990  MODIFIED FOR CYCLE_4.
C
C*    PURPOSE.
C     --------
C
C        *LOCINT* - LOCATE AND INTERPOLATE IN INPUT GRID.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *LOCINT (IG, IJS, IJL, NC, NR, KCOL, KROW, IGPER,
C                       DLAM, DPHI, RLONL, RLATS, U, V, US, DS)*
C         *IG*      - BLOCK NUMBER.
C         *IJS*     - FIRST POINT IN BLOCK.
C         *IJL*     - LAST POINT IN BLOCK.
C         *NC*      - DIMENSION OF INPUT ARRAY, NUMBER OF COLUMNES.
C         *NR*      - DIMENSION OF INPUT ARRAY, NUMBER OF ROWS.
C         *KCOL*    - NUMBER OF COLUMNES IN INPUT (USED).
C         *KROW*    - NUMBER OF ROWS     IN INPUT (USED).
C         *IGPER*   - INDICATOR PERIODICAL INPUT GRID OR NOT
C                     1 = PERIODICAL
C                     OTHERWISE NON-PERIODICAL
C         *DLAM*    - STEPSIZE BETWEEN LONGITUDES IN INPUT (DEG).
C         *DPHI*    - STEPSIZE BETWEEN LATITUDES  IN INPUT (DEG).
C         *RLATS*   - MOST SOUTHERN LATITUDE OF INPUT (DEG).
C         *RLONL*   - MOST WESTERN LONGITUDE OF INPUT (DEG).
C         *U(I,J)*  - "HORIZONTAL" COMPONENT (INPUT).
C         *V(I,J)*  - "VERTICAL  " COMPONENT (INPUT).
C         *US*      - SPACE INTERPOLATED "HORIZONTAL" COMPONENT.
C         *DS*      - SPACE INTERPOLATED "VERTICAL  " COMPONENT.
C
C     METHOD.
C     -------
C
C       DOUBLE LINEAR INTERPOLATION WITHIN A MESH FOR U AND V.
C
C     EXTERNALS.
C     ----------
C
C       *ABORT*     - TERMINATES PROCESSING.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
       INCLUDE 'preprowk.h'
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
      DIMENSION U(NC,NR), V(NC,NR), US(NIBLO), DS(NIBLO)
C
C ----------------------------------------------------------------------
C
C*    1. LOOP OVER POINTS IN WAMODEL BLOCKS.
C        -----------------------------------
C
 1000 CONTINUE
      DO 1001 IJ=IJS,IJL
C
C*    1.1 TRANSFORM WAM COORDINATE TO INPUT GRID.
C         ---------------------------------------
C
         XI = AMOWEP + REAL(IXLG(IJ,IG)-1)*XDELLO-RLONL
         XI = AMODA(XI+720.,360.)
         XI = XI/DLAM+1.00001
         XJ = AMOSOP + REAL(KXLT(IJ,IG)-1)*XDELLA-RLATS
         XJ = XJ/DPHI+1.00001
C
C*    1.2 COMPUTE CORNER POINT INDICES OF INPUT GRID.
C         -------------------------------------------
C
         I1  = XI
         J1  = XJ
         J2  = MIN(KROW,J1+1)
         I2  = I1+1
C
C*    1.3 DISTANCES OF INTERPOLATION POINT FROM CORNER POINTS.
C         ----------------------------------------------------
C
         DI1 = XI-I1
         DI2 = 1.-DI1
         DJ1 = XJ-J1
         DJ2 = 1.-DJ1
C
C*    1.4. CORRECTIONS FOR FIRST AND LAST GRID LINES
C          PERIODIC OR UNPERIODIC GRIDS ARE CONSIDERED.
C          --------------------------------------------
C
         IF (IGPER.EQ.1) THEN
            IF (I1.EQ.KCOL) I2 = 1
            IF (I1.EQ.0   ) I1 = KCOL
         ELSE
            IF (I1.EQ.KCOL) I2 = KCOL
         ENDIF
C
C*    1.5 CHECK WHETHER POINTS ARE IN GRID.
C         ---------------------------------
C
         IF (I1.LT.1 .OR. I1.GT.KCOL .OR. J1.LT.1 .OR. J1.GT.KROW) THEN
            WRITE(IU06,*) ' *******************************************'
            WRITE(IU06,*) ' *                                         *'
            WRITE(IU06,*) ' *          FATAL ERROR IN LOCINT          *'
            WRITE(IU06,*) ' *          =====================          *'
            WRITE(IU06,*) ' * POINT IS OUTSIDE OF INPUT GRID          *'
            WRITE(IU06,*) ' * DIMENSION OF INPUT GRID IS KCOL = ', KCOL
            WRITE(IU06,*) ' *                            KROW = ', KROW
            WRITE(IU06,*) ' * POINT REQUESTED IS         XI   = ', XI
            WRITE(IU06,*) ' *                            XJ   = ', XJ
            WRITE(IU06,*) ' *                                         *'
            WRITE(IU06,*) ' *  PROGRAM ABORTS     PROGRAM ABORTS      *'
            WRITE(IU06,*) ' *                                         *'
            WRITE(IU06,*) ' *******************************************'
            CALL ABORT
         ENDIF
C
C*    1.6 LINEAR INTERPOLATION.
C         ---------------------
c        SPECIAL VALUE
         XLAND = 1.E5 

         FF = AMIN1(U(I1,J1),U(I2,J1),U(I1,J2),U(I2,J2))
         FFV = AMIN1(V(I1,J1),V(I2,J1),V(I1,J2),V(I2,J2))
         IF (FF.EQ.XLAND.OR.FFV.EQ.XLAND) THEN
         WRITE(IU06,*) ' *******************************************'
         WRITE(IU06,*) '  SUBROUTINE LOCINT                         '
         WRITE(IU06,*) 'CANNOT FIND VALUE FOR POINT:',I1,J1
         CALL CORRECT(U,V,I1,J1,XM_U,XM_V,NC,NR,KCOL,KROW,XLAND,LRR)
         FF = XM_U
         FFV = XM_V
         WRITE(IU06,*) 'VALUES ASSIGNED',FF,FFV
         WRITE(IU06,*) 'NUMBER OF SCANS:',LRR
         WRITE(IU06,*) ' *******************************************'
         END IF
         IF(U(I1,J1).EQ.XLAND)U(I1,J1)=FF
         IF(U(I2,J1).EQ.XLAND)U(I2,J1)=FF
         IF(U(I1,J2).EQ.XLAND)U(I1,J2)=FF
         IF(U(I2,J2).EQ.XLAND)U(I2,J2)=FF
         IF(V(I1,J1).EQ.XLAND)V(I1,J1)=FFV
         IF(V(I2,J1).EQ.XLAND)V(I2,J1)=FFV
         IF(V(I1,J2).EQ.XLAND)V(I1,J2)=FFV
         IF(V(I2,J2).EQ.XLAND)V(I2,J2)=FFV

C
         U1 = U(I1,J1)*DI2 + U(I2,J1)*DI1
         U2 = U(I1,J2)*DI2 + U(I2,J2)*DI1
         US(IJ) = U1*DJ2 + U2*DJ1
         V1 = V(I1,J1)*DI2 + V(I2,J1)*DI1
         V2 = V(I1,J2)*DI2 + V(I2,J2)*DI1
         DS(IJ) = V1*DJ2 + V2*DJ1
 1001 CONTINUE

      RETURN
      END
      SUBROUTINE CORRECT(U,V,IE,JE,XM_U,XM_V,NC,NR,IM,JM,XLAND,LRR)
      dimension U(nc,nr), V(nc,nr)

      lr = 1

50    continue

      ist = ie -lr
      iend = ie + lr
      jst = je - lr
      jend = je + lr
      if (ist.lt.1) ist = 1
      if (iend.gt.im) iend = im
      if (jst.lt.1) jst = 1
      if (jend.gt.jm) jend = jm
       cc = 0.0
       xm_u = 0.0
       xm_v = 0.0
       do 100 i = ist,iend
       do 100 j = jst,jend
       if (u(i,j).ne.xland) then
       cc = cc + 1.
       xm_u = xm_u + u(i,j)
       xm_v = xm_v + v(i,j)
       end if
100    continue

       if (cc.eq.0.) then
        lr = lr + 1
        goto 50
       end if

       xm_u = xm_u/cc
       xm_v = xm_v/cc

       lrr = lr

       return
       end

      SUBROUTINE MBLOCK (IA1, KA, KE, IPP)

C ----------------------------------------------------------------------
C
C**** *MBLOCK* - ROUTINE TO ARRANGE WAMODEL GRID FOR ONE BLOCK.
C
C     H.GUNTHER            ECMWF       04/04/1990
C
C*    PURPOSE.
C     -------
C
C       *MBLOCK* ARRANGES WAMODEL GRID FOR A BLOCK AND
C                COMPUTES VARIOUS MODEL CONSTANTS
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *MBLOCK (IA1, KA, KE, IPP)*
C          *IA1*     - TOPOGRAPHIC DATA.
C          *KA*      - NUMBER OF FIRST LAT IN BLOCK.
C          *KE*      - NUMBER OF LAST LAT IN BLOCK.
C          *IPP*     - NUMBER OF SEA POINTS PER LAT.
C
C     METHOD.
C     -------
C
C       THE LAND POINTS ARE REMOVED. ALL MODEL CONSTANTS WHICH ARE
C       GRID DEPENDENT ARE COMPUTED AND STORED IN THE COMMON BLOCKS.
C
C     EXTERNALS.
C     ----------
C
C       *ABORT*     - TERMINATES PROCESSING.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
       INCLUDE 'preprowk.h'
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS OF TOPOGRAPHIE DATA.
C
      PARAMETER (JLONI = 1500 , JLATI = 400, IOUTA = 80)
C
C*    *COMMON* *CINP* USER INPUT: AREAS TO BE CHANGED, AND
C*                    SPECIAL OUTPUT POINTS.
C
      COMMON /CINP/ NOUT, XOUTW(IOUTA), XOUTS(IOUTA), XOUTE(IOUTA),
     1              XOUTN(IOUTA), NOUTD(IOUTA),
     2              OUTLONG(MOUTP), OUTLAT(MOUTP)
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *SHALLOW*   SHALLOW WATER TABLES.
C
      PARAMETER (NDEPTH = 63)
C
      COMMON /SHALLOW/ DEPTH(NIBLO, NBLO), DEPTHA, DEPTHD,
     1                 TCGOND(NDEPTH,NFRE), TFAK(NDEPTH,NFRE),
     2                 TSIHKD(NDEPTH,NFRE), INDEP(NIBLO)
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
      DIMENSION IA1(NGX, NGY), IPP(NGY)
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER* OF GLOBAL CONSTANTS.
C
      PARAMETER (G = 9.806, PI = 3.14159265358978, CIRC = 40000000.,
     1           ZPI = 2.*PI, RAD = PI/180., DEG = 180./PI,
     2           R = CIRC/ZPI)
C
C ----------------------------------------------------------------------
C
C*    1. UPDATE BLOCK NUMBER AND INITIALIZES ARRAYS.
C        -------------------------------------------
C
 1000 CONTINUE
      IGL = IGL + 1
      IF (IGL.GT.NBLO) THEN
         WRITE (IU06,*) '**********************************************'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '*        FATAL ERROR IN SUB. MBLOCK          *'
         WRITE (IU06,*) '*        ==========================          *'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '* MORE BLOCKS THAN DIMENSION ALLOWS.         *'
         WRITE (IU06,*) '* BLOCK NUMBER IS                 IGL = ', IGL
         WRITE (IU06,*) '* DIMENSION IS                   NBLO = ', NBLO
         WRITE (IU06,*) '* NUMBER OF FIRST LATITUDE IS      KA = ', KA
         WRITE (IU06,*) '* NUMBER OF LAST  LATITUDE IS      KE = ', KE
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '*  PROGRAM WILL BE ABORTED                   *'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '**********************************************'
         CALL ABORT
      ENDIF
      DO 1001 IJ=1,NIBLO
         DEPTH(IJ,IGL) = 0.
         IXLG(IJ,IGL) = 0
         KXLT(IJ,IGL) = 0
 1001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    2. THE FIRST AND LAST BLOCK MUST CONTAIN MORE THAN 2
C*       ALL OTHER BLOCKS MORE  THAN 3 LATITUDES.
C        -------------------------------------------------
C
 2000 CONTINUE
      IF ((KE.EQ.1) .OR. (KA.EQ.NY) .OR.
     1    ((KA.NE.1) .AND. (KE.EQ.NY) .AND. (KE-KA.LT.2))) THEN
         WRITE (IU06,*) '**********************************************'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '*        FATAL ERROR IN SUB. MBLOCK          *'
         WRITE (IU06,*) '*        ==========================          *'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '* BLOCK LENGTH IS TO SHORT.                  *'
         WRITE (IU06,*) '* LESS THAN 2 LATITUDES IN FIRST OR LAST, OR *'
         WRITE (IU06,*) '* LESS THAN 3 LATITUDES IN OTHER BLOCKS.     *'
         WRITE (IU06,*) '* BLOCK NUMBER IS               IGL = ', IGL
         WRITE (IU06,*) '* BLOCK LENGTH IS             NIBLO = ', NIBLO
         WRITE (IU06,*) '* NUMBER OF FIRST LATITUDE IS    KA = ', KA
         WRITE (IU06,*) '* NUMBER OF LAST  LATITUDE IS    KE = ', KE
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '*  PROGRAM WILL BE ABORTED                   *'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '**********************************************'
         CALL ABORT
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    3. COMPUTE INDICES OF FIRST, SECOND, BEFORE LAST, AND LAST LAT.
C        -----------------------------------------------------------
C
 3000 CONTINUE
      IF (KA.EQ.1) THEN
         IJS (IGL) = 1
         IJL2(IGL) = IPP(1)
      ELSE
        IJS (IGL) = IPP(KA)+1
        IJL2(IGL) = IPP(KA)+IPP(KA+1)
      ENDIF
      IJLT(IGL) = 0
      DO 3001 K=KA,KE
         IJLT(IGL) = IJLT(IGL)+IPP(K)
 3001 CONTINUE
      IF (KE.EQ.NY) THEN
         IJL (IGL) = IJLT(IGL)
      ELSE
         IJL (IGL) = IJLT(IGL)-IPP(KE)
      ENDIF
      IJLS(IGL) = IJL(IGL)-IPP(KE-1)+1
C
C ----------------------------------------------------------------------
C
C*    4. REMOVE LAND POINTS AND STORE COS AND SIN OF LAT.
C        ------------------------------------------------
C
 4000 CONTINUE
      IP = 0
      DO 4001 K=KA,KE
         DO 4002 I=1,NX
            IF (IA1(I,K).GT.-990) THEN
              IP = IP+1
              DEPTH(IP,IGL) = REAL(IA1(I,K))
              IXLG(IP,IGL) = I
              KXLT(IP,IGL) = K
            ENDIF
 4002    CONTINUE
 4001 CONTINUE
      IF (IP.NE.IJLT(IGL)) THEN
         WRITE (IU06,*) '**********************************************'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '*        FATAL ERROR IN SUB. MBLOCK          *'
         WRITE (IU06,*) '*        ==========================          *'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '* TOTAL NUMBER OF SEAPOINTS DO NOT MATCH.    *'
         WRITE (IU06,*) '* BLOCK NUMBER                    IGL = ', IGL
         WRITE (IU06,*) '* NO. OF SEAPOINTS COUNTED         IP = ', IP
         WRITE (IU06,*) '* NO. OF SEAPOINTS EXPECTED IJLT(IGL) = ',
     1                                            IJLT(IGL)
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '*  PROGRAM WILL BE ABORTED                   *'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '**********************************************'
         CALL ABORT
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    5. PRINTER PROTOCOL OF BLOCK.
C        --------------------------
C
 5000 CONTINUE
      IF (IGL.EQ.1) THEN
         WRITE (IU06,'(1H0,'' BLOCKING INFORMATION:'')')
	 WRITE (IU06,'(1H ,''            LATITUDES   '',
     1                     ''   SECOND LAT. INDEX '',
     2                     '' SECOND TO LAST LAT  '',
     3                     ''   TOTAL'')')
	 WRITE (IU06,'(1H ,''  NO     SOUTH     NORTH'',
     1                     ''     START       END'',
     2                     ''     START       END'',
     3                     ''    POINTS'')')
      ENDIF
      WRITE (IU06,'(1X,I4,2F10.2,5I10)')
     1        IGL, AMOSOP+(KA-1)*XDELLA, AMOSOP+(KE-1)*XDELLA,
     2        IJS(IGL), IJL2(IGL), IJLS(IGL), IJL(IGL), IJLT(IGL)

      RETURN
      END
      SUBROUTINE MBOUNC (IU09, IU19, IFORM)

C ----------------------------------------------------------------------
C
C**** *MBOUNC* - MAKE COARSE GRID BOUNDARY.
C
C     R. PORTZ     MPI         15/01/1991
C
C*    PURPOSE.
C     -------
C
C       COMPUTE ALL INFORMATION FOR COARSE GRID BOUNDARY VALUE
C       OUTPUT (COMMON CBOUND).
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *MBOUNC (IU09, IU19, IFORM)*
C          *IU09*   - LOGICAL UNIT FOR  UNFORMATED WRITE.
C          *IU19*   - LOGICAL UNIT FOR    FORMATED WRITE.
C          *IFORM*  - FORMAT OPTION  = 1  UNFORMATED WRITE.
C                                    = 2  FORMATED WRITE.
C                                      OTHERWISE BOTH.
C
C     METHOD.
C     -------
C
C       NONE.
C
C     EXTERNALS.
C     ----------
C
C       *FINDB*     - FIND BLOCK AND SEA POINT NUMBERS.
C       *MBOXB*     - FIND LAT AND LONG OF BOUNDARY POINTS.
C       *PACKI*     - PACKS AN INTEGER ARRAY.
C       *PACKC*     - PACKS A  REAL    ARRAY.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
       INCLUDE 'preprowk.h'
C

C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS FOR PREPROC ONLY.
C
      PARAMETER (NBMAX = (NGX+NGY)*2-4)
C
C*    *COMMON* *CPBOUN* USED FOR THE COURSE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /CPBOUN/ IBOUNC, NBOUNC(NESTMAX), 
     1                IJARC(NBMAX), IGARC(NBMAX),
     1                DLAMAC, DPHIAC, AMOSOC(NESTMAX), 
     1                AMONOC(NESTMAX), AMOEAC(NESTMAX), AMOWEC(NESTMAX),
     2                BLATC(NBMAX), BLNGC(NBMAX)

       COMMON /CCHECK/ IJJARC(NBMAX,NESTMAX), IGGARC(NBMAX,NESTMAX)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
  998 FORMAT(10I8)
  999 FORMAT(5E16.7)
C
C ----------------------------------------------------------------------
C
C*    1. INITIAL.
C        --------
C
 1000 CONTINUE
      DPHIAC = XDELLA
      DLAMAC = XDELLO
C

      DO 9500 NEST = 1,NESTS

      DO 1001 I = 1,NBMAX
	 IJARC(I) = 0
	 IGARC(I) = 0
	 IJJARC(I,NEST) = 0
	 IGGARC(I,NEST) = 0
	 BLATC(I) = 0.
	 BLNGC(I) = 0.
 1001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    2. COMPUTED THE SQUARE BOX.
C        ------------------------
C
 2000 CONTINUE
      CALL MBOXB (NBOUNC(NEST), AMOWEC(NEST), AMOSOC(NEST), 
     1       AMOEAC(NEST),    AMONOC(NEST), BLATC, BLNGC)
C
C ----------------------------------------------------------------------
C
C*    3. SEARCH BLOCK NUMBER AND SEA POINT NUMBER.
C        -----------------------------------------
C
 3000 CONTINUE
      CALL FINDB (NBMAX, NBOUNC(NEST), BLATC, BLNGC, IGARC, IJARC)
C
C ----------------------------------------------------------------------
C
C*    4. PACKED ALL ARRAYS.
C        -------------------
C
      CALL PACKR (NBOUNC(NEST), NBOUNEW, NBMAX, IGARC, BLATC)
      CALL PACKR (NBOUNC(NEST), NBOUNEW, NBMAX, IGARC, BLNGC)
      CALL PACKI (NBOUNC(NEST), NBOUNEW, NBMAX, IGARC, IJARC)
      CALL PACKI (NBOUNC(NEST), NBOUNEW, NBMAX, IGARC, IGARC)
      NBOUNC(NEST) = NBOUNEW
C
      DO I = 1,NBMAX
        IGGARC(I,NEST) = IGARC(I)
        IJJARC(I,NEST) = IJARC(I)
      END DO
C ----------------------------------------------------------------------
C
C*    5. PRINTER PROTOCOL.
C        -----------------
C
 5000 CONTINUE
      WRITE (IU06,'(''1BOUNDARY OUTPUT POINTS OF THIS GRID:'')')
      WRITE (IU06,*) '===================================='
      WRITE (IU06,*) '  NUMBER OF BOUNDARY POINTS IS NBOUNC = ', 
     1                                                NBOUNC(NEST)
      WRITE (IU06,'(4X,''     |-----INPUT-----|'',
     1               ''-POINT INDEX--|'')')
      WRITE (IU06,'(4X,''  NO.    LAT.   LONG.  BLOCK.'',
     1              ''  POINT.'')')
      DO 5001 IO=1,NBOUNC(NEST)
	 WRITE (IU06,'(4X,I5,2F8.2,2I8)')
     1     IO, BLATC(IO), BLNGC(IO), IGARC(IO), IJARC(IO)
 5001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    6. WRITE COMMON CBOUND.
C        --------------------
C
 6000 CONTINUE
      IF (IFORM.NE.2) THEN
	 WRITE(IU09) NBOUNC(NEST)
	 WRITE(IU09) (IGARC(I),I=1,NBOUNC(NEST)), 
     1               (IJARC(I),I=1,NBOUNC(NEST))
	 WRITE(IU09) DLAMAC, DPHIAC, AMOSOC(NEST), AMONOC(NEST), 
     1                AMOEAC(NEST), AMOWEC(NEST),
     1   (BLNGC(I),I=1,NBOUNC(NEST)), (BLATC(I),I=1,NBOUNC(NEST))
      ENDIF
      IF (IFORM.NE.1) THEN
	 WRITE(IU19,998) NBOUNC(NEST)
	 WRITE(IU19,998) (IGARC(I),I=1,NBOUNC(NEST)), 
     1                   (IJARC(I),I=1,NBOUNC(NEST))
	 WRITE(IU19,999) DLAMAC,DPHIAC, 
     1   AMOSOC(NEST), AMONOC(NEST), AMOEAC(NEST), AMOWEC(NEST),
     1  (BLNGC(I),I=1,NBOUNC(NEST)), (BLATC(I),I=1,NBOUNC(NEST))
         
      ENDIF
C
 9500   CONTINUE
C ----------------------------------------------------------------------
C
      RETURN
      END
      SUBROUTINE MBOUNF (IU03, IU10, IU20, IFORM, IINPC)

C ----------------------------------------------------------------------
C
C**** *MBOUNF* - MAKE FINE GRID BOUNDARY.
C
C     R. PORTZ     MPI         15/01/1991
C
C*    PURPOSE.
C     -------
C
C       COMPUTE ALL INFORMATION FOR FINE GRID BOUNDARY VALUE
C       INPUT (COMMON FBOUND).
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *MBOUNF (IU03, IU10, IU20, IFORM, IINPC)
C          *IU03*  -  INPUT UNIT OF COARSE GRID BOUNDARY INFORMATION
C                     COMMON CBOUND GENERATED BY A COARSE GRID PREPROC
C                     (UNFORMATED).
C          *IU10*   - LOGICAL OUTPUT UNIT FOR  UNFORMATED WRITE OF
C                     COMMON FBOUND.
C          *IU20*   - LOGICAL OUTPUT UNIT FOR    FORMATED WRITE OF
C                     COMMON FBOUND.
C          *IFORM*  - FORMAT OPTION  = 1  UNFORMATED WRITE/READ.
C                                    = 2  FORMATED WRITE/READ
C                                    OTHERWISE WRITE BOTH
C                                              READ UNFORMATED.
C          *IINPC*  - NUMBER OF INPUT POINTS FROM COARSE GRID.
C
C     METHOD.
C     -------
C
C       NONE.
C
C     EXTERNALS.
C     ----------
C
C       *ABORT*     - TERMINATES PROCESSING.
C       *FINDB*     - FIND BLOCK AND SEA POINT NUMBERS.
C       *MBOXB*     - FIND LAT AND LONG OF BOUNDARY POINTS.
C       *MINTF*     - MAKES INTERPOLATION TABLE FOR FINE TO COARSE GRID.
C       *PACKI*     - PACKS AN INTEGER ARRAY.
C       *PACKC*     - PACKS A  REAL    ARRAY.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C
       INCLUDE 'preprowk.h'
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS FOR PREPROC ONLY.
C
      PARAMETER (NBMAX = (NGX+NGY)*2-4)
C
C*    *COMMON* *CPBOUN* USED FOR THE COURSE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /CPBOUN/ IBOUNC, NBOUNC(NESTMAX), 
     1                IJARC(NBMAX), IGARC(NBMAX),
     1                DLAMAC, DPHIAC, AMOSOC(NESTMAX), AMONOC(NESTMAX), 
     1                AMOEAC(NESTMAX), AMOWEC(NESTMAX),
     2                BLATC(NBMAX), BLNGC(NBMAX)
C
C*    *COMMON* *FPBOUN* USED FOR THE FINE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /FPBOUN/ IBOUNF, NBOUNF, IJARF(NBMAX), IGARF(NBMAX),
     1                IBFL(NBMAX), IBFR(NBMAX), BFW(NBMAX)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
      DIMENSION BLATF(NBMAX), BLNGF(NBMAX)
C
C ----------------------------------------------------------------------
C
  998 FORMAT(10I8)
  999 FORMAT(5E16.7)
C
C ----------------------------------------------------------------------
C
C*    1. INITIAL.
C     -----------
C
 1000 CONTINUE

      DO 1001 I = 1,NBMAX
	 IJARF(I) = 0
	 IGARF(I) = 0
	 IBFL (I) = 0
	 IBFR (I) = 0
	 BFW  (I) = 0.
	 BLATF(I) = 0.
	 BLNGF(I) = 0.
 1001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    2. READ COMMON BOUNDC
C     ---------------------
C
 2000 CONTINUE
      DO 9500 NEST = 1,NESTNUM-1
      IF (IFORM.NE.2) THEN
	 READ (IU03) NBOUNC(NEST)
	 READ (IU03) (IGTRAP,I=1,NBOUNC(NEST)), 
     1                (IJTRAP,I=1,NBOUNC(NEST))
	 READ (IU03) DLAMAC, DPHIAC, AMOSOA, AMONOA, AMOEAA, AMOWEA,
     1                (BLTRAP,I=1,NBOUNC(NEST)), 
     1                (BLTRAP,I=1,NBOUNC(NEST))
      ELSE
	 READ (IU03,998) NBOUNC(NEST)
	 READ (IU03,998) (IGTRAP,I=1,NBOUNC(NEST)), 
     1                   (IJTRAP,I=1,NBOUNC(NEST))
	 READ (IU03,999) DLAMAC,DPHIAC, AMOSOA, AMONOA, AMOEAA, AMOWEA,
     1                   (BLTRAP,I=1,NBOUNC(NEST)), 
     1                   (BLTRAP,I=1,NBOUNC(NEST))
      ENDIF

9500  CONTINUE

      IF (IFORM.NE.2) THEN
         READ (IU03) NBOUNC(NESTNUM)
         READ (IU03) (IGARC(I),I=1,NBOUNC(NESTNUM)),
     1                (IJARC(I),I=1,NBOUNC(NESTNUM))
         READ (IU03) DLAMAC, DPHIAC, AMOSOA, AMONOA, AMOEAA, AMOWEA,
     1                (BLNGC(I),I=1,NBOUNC(NESTNUM)),
     1                (BLATC(I),I=1,NBOUNC(NESTNUM))
      ELSE
         READ (IU03,998) NBOUNC(NESTNUM)
         READ (IU03,998) (IGARC(I),I=1,NBOUNC(NESTNUM)),
     1                   (IJARC(I),I=1,NBOUNC(NESTNUM))
         READ (IU03,999) DLAMAC,DPHIAC, AMOSOA, AMONOA, AMOEAA, AMOWEA,
     1                   (BLNGC(I),I=1,NBOUNC(NESTNUM)),
     1                   (BLATC(I),I=1,NBOUNC(NESTNUM))
      ENDIF
      IINPC = NBOUNC(NESTNUM)
C
C ----------------------------------------------------------------------
C
C*    3. CHECK THE INPUT
C     ------------------
C
C     IS THE FINE GRID THE SAME AS IN THE COURSE GRID ?
C
      IF (AMOWEP.NE.AMOWEA .OR. AMOEAP.NE.AMOEAA .OR.
     +    AMONOP.NE.AMONOA .OR. AMOSOP.NE.AMOSOA) THEN
	  WRITE(IU06,*) '***********************************'
	  WRITE(IU06,*) '*                                 *'
	  WRITE(IU06,*) '*  FATAL ERROR IN SUB. MBOUNF     *'
	  WRITE(IU06,*) '*  ==========================     *'
	  WRITE(IU06,*) '*                                 *'
	  WRITE(IU06,*) '*  THIS IS NOT THE SAME GRID      *'
	  WRITE(IU06,*) '*  AS YOU HAD DELARED IN THE      *'
	  WRITE(IU06,*) '*  COURSE GRID                    *'
	  WRITE(IU06,*) '*                                 *'
	  WRITE(IU06,*) '*  AMOSOP: ', AMOSOP, ' AMOSOA: ', AMOSOA
	  WRITE(IU06,*) '*  AMONOP: ', AMONOP, ' AMONOA: ', AMONOA
	  WRITE(IU06,*) '*  AMOWEP: ', AMOWEP, ' AMOWEA: ', AMOWEA
	  WRITE(IU06,*) '*  AMOEAP: ', AMOEAP, ' AMOEAA: ', AMOEAA
	  WRITE(IU06,*) '*                                 *'
	  WRITE(IU06,*) '*     THE PROGRAM ABORT           *'
	  WRITE(IU06,*) '***********************************'
          CALL ABORT
      ENDIF
C
C     IS THE STEP OF LAT. AND LONG. OF THE FINE GRID A MULTIPLE
C              OF THE COURSE GRID ?
C
      IDELA=10*((AMONOP-AMOSOP)/XDELLA )
      IDPHI=10*((AMONOP-AMOSOP)/DPHIAC )
c     IDELA=10*((AMONOP-AMOSOP)/XDELLA + 0.1)
c     IDPHI=10*((AMONOP-AMOSOP)/DPHIAC + 0.1)
      WRITE(6,*)'IDELA: ',IDELA,' IDPHI: ',IDPHI
      IF (AMODA(IDELA,IDPHI).NE.0) THEN
          WRITE(IU06,*) '***********************************'
          WRITE(IU06,*) '*                                 *'
          WRITE(IU06,*) '*  FATAL ERROR IN SUB. MBOUNF     *'
          WRITE(IU06,*) '*  --------------------------     *'
          WRITE(IU06,*) '*                                 *'
          WRITE(IU06,*) '*  THE STEP OF THE LAT. OF THE    *'
          WRITE(IU06,*) '*  FINE GRID IS NOT A MULTIPLE    *'
          WRITE(IU06,*) '*  OF THE COURSE GRID             *'
          WRITE(IU06,*) '*                                 *'
          WRITE(IU06,*) '*  FINE GRID XDELLA: ', XDELLA
          WRITE(IU06,*) '*  COARSE GRID DPHIAC: ', DPHIAC
          WRITE(IU06,*) '*                                 *'
          WRITE(IU06,*) '*     THE PROGRAM ABORT           *'
          WRITE(IU06,*) '***********************************'
          CALL ABORT
      ENDIF
C
      IDELO=10*((AMOEAP-AMOWEP)/XDELLO )
      IDLAM=10*((AMOEAP-AMOWEP)/DLAMAC )
c     IDELO=10*((AMOEAP-AMOWEP)/XDELLO + 0.1)
c     IDLAM=10*((AMOEAP-AMOWEP)/DLAMAC + 0.1)
      WRITE(6,*)'IDELO: ',IDELO,' IDLAM: ',IDLAM
      IF (AMODA(IDELO,IDLAM).NE.0) THEN
          WRITE(IU06,*) '***********************************'
          WRITE(IU06,*) '*                                 *'
          WRITE(IU06,*) '*  FATAL ERROR IN SUB. MBOUNF     *'
          WRITE(IU06,*) '*  ==========================     *'
          WRITE(IU06,*) '*                                 *'
          WRITE(IU06,*) '*  THE STEP OF THE LON. OF THE    *'
          WRITE(IU06,*) '*  FINE GRID IS NOT A MULTIPLE    *'
          WRITE(IU06,*) '*  OF THE COURSE GRID             *'
          WRITE(IU06,*) '*                                 *'
          WRITE(IU06,*) '*  FINE GRID   XDELLO: ', XDELLO
          WRITE(IU06,*) '*  COARSE GRID DLAMAC: ', DLAMAC
          WRITE(IU06,*) '*                                 *'
          WRITE(IU06,*) '*     THE PROGRAM ABORT           *'
          WRITE(IU06,*) '***********************************'
          CALL ABORT
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    4. COMPUTED THE SQUARE BOX
C     --------------------------
C
 4000 CONTINUE
      CALL MBOXB (NBOUNF, AMOWEP, AMOSOP, AMOEAP, AMONOP, BLATF, BLNGF)
C
C ----------------------------------------------------------------------
C
C*    5. SEARCH BLOCK NUMBER AND SEA POINT NUMBER.
C        -----------------------------------------
 5000 CONTINUE
      CALL FINDB (NBMAX, NBOUNF, BLATF, BLNGF, IGARF, IJARF)
C
C ----------------------------------------------------------------------
C
C*    6. MAKE INTERPOLATED ARRAYS
C     ----------------------------
C
 6000 CONTINUE
      CALL MINTF(NESTNUM)
C
C ----------------------------------------------------------------------
C
C*    7. PACKED ALL ARRAYS
C     --------------------
C
 7000 CONTINUE
      CALL PACKR (NBOUNF, NBOUNEW, NBMAX, IGARF, BLNGF)
      CALL PACKR (NBOUNF, NBOUNEW, NBMAX, IGARF, BLATF)
      CALL PACKR (NBOUNF, NBOUNEW, NBMAX, IGARF, BFW)
        CALL PACKI (NBOUNF, NBOUNEW, NBMAX, IGARF, IBFL)
      CALL PACKI (NBOUNF, NBOUNEW, NBMAX, IGARF, IBFR)
      CALL PACKI (NBOUNF, NBOUNEW, NBMAX, IGARF, IJARF)
      CALL PACKI (NBOUNF, NBOUNEW, NBMAX, IGARF, IGARF)
      NBOUNF = NBOUNEW
C
C ----------------------------------------------------------------------
C
C*    8. PRINTER PROTOCOL.
C        -----------------
C
 8000 CONTINUE
      WRITE (IU06,'(''1BOUNDARY INPUT POINTS FOR THIS GRID:'')')
      WRITE (IU06,*) '===================================='
      WRITE (IU06,*) '  NUMBER OF BOUNDARY POINTS IS NBOUNF = ', NBOUNF
      WRITE (IU06,*) '        |-----FINE GRID INPUT POINTS-----|',
     1              '-RELATED COURSE GRID INDICES--|'
      WRITE (IU06,*) '      NO.    LAT.   LONG.  BLOCK.  POINT. ',
     +              '   LEFT   RIGHT   WEIGHT '
C
      DO 8001 IO = 1, NBOUNF
         WRITE (IU06,'(4X,I5,2F8.2,4I8,F10.4)')
     +     IO, BLATF(IO), BLNGF(IO), IGARF(IO), IJARF(IO),
     +     IBFL(IO), IBFR(IO), BFW(IO)
 8001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    9. WRITE COMMON FBOUND
C
 9000 CONTINUE
      IF (IFORM.NE.2) THEN
         WRITE(IU10) NBOUNF
         WRITE(IU10) (IGARF(I),I=1,NBOUNF), (IJARF(I),I=1,NBOUNF),
     1                (IBFL(I),I=1,NBOUNF), (IBFR(I),I=1,NBOUNF),
     2                (BFW(I),I=1,NBOUNF)
      ENDIF
      IF (IFORM.NE.1) THEN
         WRITE(IU20,998) NBOUNF
         WRITE(IU20,998) (IGARF(I),I=1,NBOUNF), (IJARF(I),I=1,NBOUNF),
     1                    (IBFL(I),I=1,NBOUNF), (IBFR(I),I=1,NBOUNF)
         WRITE(IU20,999) (BFW(I),I=1,NBOUNF)
      ENDIF
C
      RETURN
      END
      SUBROUTINE MBOXB (NBOUN, AMOWEB, AMOSOB, AMOEAB,
     1                  AMONOB, BLATB, BLNGB)

C ----------------------------------------------------------------------
C
C**** *MBOXB* - MAKE BOX OF FINE GRID IN COARSE GRID.
C
C     R. PORTZ     MPI         15/01/1991
C
C*    PURPOSE.
C     -------
C
C       COMPUTE LATITUDES AND LONGITUDES OF COARSE GRID POINTS
C       AT NEST BOUNDARY.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *MBOXB (NBOUN, AMOWEB, AMOSOB, AMOEAB, AMONOB,
C                      BLATB, BLNGB)*
C          *NBOUN*  - NUMBER OF BOUNDARY POINTS.
C          *AMOWEB* - WESTERN  LONGITUDE OF COARSE GRID.
C          *AMOSOB* - SOUTHERN LATITUDE  OF COARSE GRID.
C          *AMOEAB* - EASTERN  LONGITUDE OF COARSE GRID.
C          *AMONOB* - NORTHERN LATITUDE  OF COARSE GRID.
C          *BLATB*  - LATITUDE  OF BOUNDARY POINTS.
C          *BLNGB*  - LONGITUDE OF BOUNDARY POINTS.
C
C     METHOD.
C     -------
C
C       NONE.
C
C     EXTERNALS.
C     ----------
C
C       *ABORT*     - TERMINATES PROCESSING.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
       INCLUDE 'preprowk.h'
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS FOR PREPROC ONLY.
C
      PARAMETER (NBMAX = (NGX+NGY)*2-4)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
      DIMENSION BLNGB(NBMAX), BLATB(NBMAX)
C
C ----------------------------------------------------------------------
C
C*    1. COMPUTED THE SQUARE BOX
C     --------------------------
C
 1000 CONTINUE
      NLNGB = NINT((AMOEAB - AMOWEB) / XDELLO) + 1
C
      NLATB = (NINT((AMONOB - AMOSOB) / XDELLA) - 1) * 2
C
      NBOUN = (NLNGB * 2) + NLATB
C
C     DIMENSION CHECK: NBMAX > NBOUN
C
      IF (NBMAX .LT. NBOUN) THEN
         WRITE(IU06,*) ' **********************************'
         WRITE(IU06,*) ' *                                *'
         WRITE(IU06,*) ' *   FATAL ERROR IN SUB. MBOX     *'
         WRITE(IU06,*) ' *   ========================     *'
         WRITE(IU06,*) ' *  NUMBER OF BOUNDARY POINTS     *'
         WRITE(IU06,*) ' *  EXCEEDS DIMENSION.            *'
         WRITE(IU06,*) ' *  DIMENSION IS        NBMAX = ', NBMAX
         WRITE(IU06,*) ' *  NUMBER OF POINTS IS NBOUN = ', NBOUN
         WRITE(IU06,*) ' *                                *'
         WRITE(IU06,*) ' **********************************'
         CALL ABORT
      ENDIF
C
C     COMPUTES THE BOUNDARY POINTS FOR THE FIRST AND THE LAST
C     LATITUDE
C
      K = NLATB + NLNGB
      DO 1001 I = 1, NLNGB
         BLATB(I) = AMOSOB
         BLNGB(I) = AMOWEB + REAL(I-1) * XDELLO
         BLATB(K+I) = AMONOB
         BLNGB(K+I) = BLNGB(I)
 1001 CONTINUE
C
C     COMPUTED THE EAST AND THE WEST BOUNDARY POINT FOR
C     EACH LATITUDE
C
      K = 0
      DO 1002 I = 2,NLATB,2
         K = K + 1
         BLATB(NLNGB+I-1) = AMOSOB + REAL(K) * XDELLA
         BLNGB(NLNGB+I-1) = AMOWEB
         BLATB(NLNGB+I)   = BLATB(NLNGB+I-1)
         BLNGB(NLNGB+I)   = AMOEAB
 1002 CONTINUE
C
      RETURN
      END
      SUBROUTINE MCOUT

C ----------------------------------------------------------------------
C
C**** *MCOUT* - ROUTINE TO COMPUTE OUTPUT INDICES (COMMON COUT).
C
C     H.GUNTHER            ECMWF       04/04/1990
C
C*    PURPOSE.
C     -------
C
C       *MCOUT* COMPUTES THE INDICES OF SPECTRA OUTPUT POINTS.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *MCOUT*
C
C     METHOD.
C     -------
C
C       THE LATITUDE AND LOGITUDE ARE CONVERTED TO INDICES.
C
C     EXTERNALS.
C     ----------
C
C       *FINDB*     - FIND BLOCK AND SEA POINT NUMBERS.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C
       INCLUDE 'preprowk.h'
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS OF TOPOGRAPHIE DATA.
C
      PARAMETER (JLONI = 1500 , JLATI = 400, IOUTA = 80)
C
C*    *COMMON* *CINP* USER INPUT: AREAS TO BE CHANGED, AND
C*                    SPECIAL OUTPUT POINTS.
C
      COMMON /CINP/ NOUT, XOUTW(IOUTA), XOUTS(IOUTA), XOUTE(IOUTA),
     1              XOUTN(IOUTA), NOUTD(IOUTA),
     2              OUTLONG(MOUTP), OUTLAT(MOUTP)
C
C*    *COMMON* *COUT*  OUTPUT POINTS INDICES AND FLAGS.
C
      LOGICAL FFLAG(14), FFLAG20, FFLAG21, FFLAG25, FFLAG26,
     1        PFLAG(14), PFLAG20, PFLAG21, PFLAG25, PFLAG26
      COMMON /COUT/ NGOUT, IGAR(MOUTP), IJAR(MOUTP),
     1              NOUTT, IOUTT(MOUTT),
     2              FFLAG, FFLAG20, FFLAG21, FFLAG25, FFLAG26,
     3              PFLAG, PFLAG20, PFLAG21, PFLAG25, PFLAG26
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
C*    1. NO OUTPUT POINTS SPECIFIED.
C        ---------------------------
C
 1000 CONTINUE
      IF (NGOUT.EQ.0) THEN
         WRITE(IU06,'(1H1,'' SPECIAL OUTPUT POINTS FOR SPECTRA:'')')
         WRITE(IU06,*) 'OUTPUT POINTS ARE NOT DEFINED IN USER INPUT'
         RETURN
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    2. SEARCH BLOCK NUMBER AND SEA POINT NUMBER.
C        -----------------------------------------
C
 2000 CONTINUE
      CALL FINDB (NIBLO, NGOUT, OUTLAT, OUTLONG, IGAR, IJAR)
C
C ----------------------------------------------------------------------
C
C*    3. PRINTER PROTOCOL.
C        -----------------
C
 3000 CONTINUE
      WRITE(IU06,'(1H1,'' SPECIAL OUTPUT POINTS FOR SPECTRA:'')')
      WRITE(IU06,'(''    NUMBER OF OUTPUT POINTS IS NGOUT = '',I4)')
     1      NGOUT
      WRITE(IU06,'(4X,''     |-----INPUT-----|-NEAREST POINT-|'',
     1              ''-POINT INDEX--|'')')
      WRITE(IU06,'(4X,''  NO.    LAT.   LONG.    LAT.   LONG.  BLOCK.'',
     1             ''  POINT.'')')
      DO 3001 IO=1,NGOUT
         IF (IJAR(IO).GT.0) THEN
            ALONG = AMOWEP + (IXLG(IJAR(IO),IGAR(IO))-1)*XDELLO
            ALAT  = AMOSOP + (KXLT(IJAR(IO),IGAR(IO))-1)*XDELLA
         ELSE
            ALONG = 9999999
            ALAT  = 9999999
         ENDIF
         WRITE(IU06,'(4X,I5,4F8.2,2I8)')
     1     IO, OUTLAT(IO), OUTLONG(IO), ALAT, ALONG, IGAR(IO), IJAR(IO)
 3001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    4. REMOVE OUTPUT POINTS WHICH ARE NOT IN GRID.
C        -------------------------------------------
C
 4000 CONTINUE
      NG = 0
      DO 4001 IO=1,NGOUT
         IF (NG.GT.0 .AND. IO-NG.GT.0) THEN
            IJAR(IO-NG) = IJAR(IO)
            IGAR(IO-NG) = IGAR(IO)
         ENDIF
         IF (IJAR(IO).EQ.0) NG = NG+1
 4001 CONTINUE
      NGOUT = NGOUT-NG
      IF (NG.GT.0) THEN
         WRITE (IU06,*) ' +++++++++++++++++++++++++++++++++++++++++'
         WRITE (IU06,*) ' +                                       +'
         WRITE (IU06,*) ' +     WARNING ERROR FROM SUB. MCOUT     +'
         WRITE (IU06,*) ' +     =============================     +'
         WRITE (IU06,*) ' +                                       +'
         WRITE (IU06,*) ' + NO SEAPOINT FOUND FOR NG = ',NG
         WRITE (IU06,*) ' + OUTPUT POINT REQUESTS (SEE ABOVE LIST)+'
         WRITE (IU06,*) ' + THESE POINTS WILL NOT BE TAKEN.       +'
         WRITE (IU06,*) ' + NUMBER OF OUTPUT POINTS IS NGOUT = ', NGOUT
         WRITE (IU06,*) ' +                                       +'
         WRITE (IU06,*) ' +++++++++++++++++++++++++++++++++++++++++'
      ENDIF

      RETURN
      END
      SUBROUTINE MFREDIR (ML, KL)

C ----------------------------------------------------------------------
C
C**** *MFREDIR* - ROUTINE TO COMPUTE FREQUENCY DIRECTION CONSTANTS.
C
C     H. GUNTHER      ECMWF          2/4/90.
C
C*    PURPOSE.
C     --------
C
C       INITIATES THE FREQUENCY AND DIRECTION CONSTANTS WHICH ARE
C       SAVED IN COMMON FREDIR.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *MFREDIR (ML, KL)*
C          *ML*  - NUMBER OF FREQUENCIES
C          *KL*  - NUMBER OF DIRECTIONS
C
C     METHOD.
C     -------
C
C       STARTING FROM THE FIRST FREQUENCY THE NEXT  ARE INCREMENTED
C       BY THE FACTOR *CO* (SEE PARAMETER STATEMENT). THE DIRECTIONS
C       ARE EQUALLY DISTRIBUTED OVER THE CIRCLE STARTING WITH ZERO.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C
       INCLUDE 'preprowk.h'
C
C*    *COMMON* *FREDIR* - FREQUENCY AND DIRECTION GRID.
C
      COMMON /FREDIR/ FR(NFRE), DFIM(NFRE), GOM(NFRE), C(NFRE),
     1                DELTH, DELTR, TH(NANG), COSTH(NANG), SINTH(NANG)
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER* OF GLOBAL CONSTANTS.
C
      PARAMETER (G = 9.806, PI = 3.14159265358978, CIRC = 40000000.,
     1           ZPI = 2.*PI, RAD = PI/180., DEG = 180./PI,
     2           R = CIRC/ZPI)
C
C*    *PARAMETER*  SUB. CONSTANTS.
C
      PARAMETER (CO = 1.1)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      CO          REAL      FREQUENCY RATIO.
C
C ----------------------------------------------------------------------
C
C*    1. FREQUENCY DEPENDENT CONSTANTS.
C        ------------------------------
C
 1000 CONTINUE
C
C*    1.1 COMPUTE FREQUENCIES.
C         --------------------
C
      DO 1100 M=2,ML
         FR(M) = CO*FR(M-1)
 1100 CONTINUE
C
C*    1.2 COMPUTE DEEP WATER GROUP VELOCITIES.
C        ------------------------------------
C
      DO 1200 M=1,ML
         GOM(M) = G/(4.*PI*FR(M))
 1200 CONTINUE
C
C*    1.3 COMPUTE PHASE VELOCITY IN DEEP WATER.
C         -------------------------------------
C
      DO 1301 M = 1,ML
         C(M) = G/(ZPI*FR(M))
 1301 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    2. COMPUTATION OF DIRECTIONS, BANDWIDTH, SIN AND COS.
C        --------------------------------------------------
C
 2000 CONTINUE
      IDIR = 1
      DELTH = ZPI/REAL(KL)
      DELTR = DELTH*R
      DO 2001 K=1,KL
c       TH(K) = REAL(K-1)*DELTH
C MAKIS ROTATION OF DIRECTIONS
         TH(K) = REAL(K-1)*DELTH+0.5*DELTH*IDIR
        COSTH(K) = COS(TH(K))
        SINTH(K) = SIN(TH(K))
 2001 CONTINUE
       IF (IDIR.EQ.1) THEN
        WRITE(IU06,'(''THE FIRST WAVE DIRECTION IS SHIFTED FROM THE'')')
        WRITE(IU06,'('' TRUE NORTH (IN DEGREE) '', F6.3)') 0.5*DELTH*DEG
       ENDIF

C
C ----------------------------------------------------------------------
C
C*    3. COMPUTATION FREQUENCY DIRECTION AREAS
C        -------------------------------------
C
 3000 CONTINUE
      CO1 = 0.5*(CO-1.)*DELTH
      DFIM(1)= CO1*FR(1)
      DO 3001 M=2,ML-1
         DFIM(M)=CO1 * (FR(M)+FR(M-1))
 3001 CONTINUE
      DFIM(ML)=CO1*FR(ML-1)
C
C ----------------------------------------------------------------------
C
C*    4. PRINTER PROTOCOL
C         ---------------
C
 4000 CONTINUE
      WRITE (IU06,'(''1FREQUENCY AND DIRECTION GRID'')')
      WRITE (IU06,'(''0NUMBER OF FREQUENCIES IS  ML = '',I3)') ML
      WRITE (IU06,'('' NUMBER OF DIRECTIONS  IS  KL = '',I3)') KL
      WRITE (IU06,'(''0MODEL FREQUENCIES IN HERTZ:'')')
      WRITE (IU06,'(1X,13F10.5)') (FR(M),M=1,ML)
      WRITE (IU06,'(''0MODEL FREQUENCY INTERVALLS TIMES DIRECTION'',
     1              '' INTERVALL IN HERTZ*RADIENS'')')
      WRITE (IU06,'(1X,13F10.5)') (DFIM(M),M=1,ML)
      WRITE (IU06,'(''0MODEL DEEP WATER GROUPVELOCITY IN M/S:'')')
      WRITE (IU06,'(1X,13F10.5)') (GOM(M),M=1,ML)
      WRITE (IU06,'(''0MODEL DEEP WATER PHASEVELOCITY IN M/S:'')')
      WRITE (IU06,'(1X,13F10.5)') (C(M),M=1,ML)
      WRITE (IU06,'(''0MODEL DIRECTIONS IN DEGREE'',
     1              '' (CLOCKWISE FROM NORTH):'')')
      WRITE (IU06,'(1X,13F10.5)') (TH(K)*DEG,K=1,KL)

      RETURN
      END
      SUBROUTINE MGRID (IA1)

C ----------------------------------------------------------------------
C
C**** *MGRID* - ROUTINE TO ARRANGE WAMODEL GRID.
C
C     H.GUNTHER            ECMWF       04/04/1990
C
C*    PURPOSE.
C     -------
C
C       TO ARRANGE WAMODEL GRID FOR A GIVEN AREA AND COMPUTE VARIOUS
C       MODEL CONSTANTS.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *MGRID (IA1)*
C          *IA1*     - TOPOGRAPHIC DATA OF PART
C
C     METHOD.
C     -------
C
C       THE NUMBER OF SEA POINTS PER LATITUDE IS COUNTED AND MODEL
C       BLOCKS OF MAXIMUM LENGTH OF NIBLO ARE CONSTRUCTED.
C
C     EXTERNALS.
C     ----------
C
C       *MBLOCK*    - SUB. TO GENERATE A BLOCK.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C
       INCLUDE 'preprowk.h'
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C ----------------------------------------------------------------------
C
      DIMENSION IA1(NGX,NGY)
C
C ----------------------------------------------------------------------
C
      DIMENSION IPP(NGY)
C
C          *IPP*   INTEGER   NUMBER OF SEA POINTS PER LATITUDE.
C
C ----------------------------------------------------------------------
C
C*    1. COUNT NUMBER OF SEA POINTS PER LATITUDE.
C        ----------------------------------------
C
 1000 CONTINUE
      DO 1001 K=1,NY
         IPP(K) = 0
         DO 1002 I=1,NX
            IF (IA1(I,K).GT.-990) THEN
              IPP(K) = IPP(K) + 1
            ENDIF
 1002    CONTINUE
 1001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    2. MAKE BLOCKS.
C        ------------
C
 2000 CONTINUE
      IL = 0
      KA = 1
      DO 2001 K = 1,NY
         IL = IL + IPP(K)
         IF (IL.GT.NIBLO) THEN
            KE = K-1
            CALL MBLOCK (IA1, KA, KE, IPP)
            KA = KE-1
            IL = IPP(KA)+IPP(KE)+IPP(KE+1)
         ENDIF
 2001 CONTINUE
      CALL MBLOCK (IA1, KA, NY, IPP)

      RETURN
      END
      SUBROUTINE MINTF(NEST)

C ----------------------------------------------------------------------
C
C**** *MINTF* - MAKE INTERPOLATION TABLES FOR BOUNDARY INPUT.
C
C     R. PORTZ     MPI         15/01/1991
C     H. GUNTHER   GKSS/ECMWF  15/01/1991
C
C*    PURPOSE.
C     -------
C
C       GENERATE SPACE INTERPOLATION TABLES USED FOR BOUNDARY
C       VALUE INPUT INTO A FINE GRID MODEL.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *MINT*
C
C     METHOD.
C     -------
C
C       NONE.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C
       INCLUDE 'preprowk.h'
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS FOR PREPROC ONLY.
C
      PARAMETER (NBMAX = (NGX+NGY)*2-4)
C
C*    *COMMON* *CPBOUN* USED FOR THE COURSE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /CPBOUN/ IBOUNC,NBOUNC(NESTMAX) ,
     1                IJARC(NBMAX), IGARC(NBMAX),
     1                DLAMAC, DPHIAC, AMOSOC(NESTMAX), 
     1                AMONOC(NESTMAX), AMOEAC(NESTMAX), AMOWEC(NESTMAX),
     2                BLATC(NBMAX), BLNGC(NBMAX)
C
C*    *COMMON* *FPBOUN* USED FOR THE FINE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /FPBOUN/ IBOUNF, NBOUNF, IJARF(NBMAX), IGARF(NBMAX),
     1                IBFL(NBMAX), IBFR(NBMAX), BFW(NBMAX)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C LINUC IFC COMPILER: ZERO SHOULD BE 0.1E-4 INSTEAD OF 0.1E-10
      PARAMETER (ZERO = 0.1E-4 )
C ----------------------------------------------------------------------
C
C*    1. RATIOS OF GRID INCREMENTS.
C        --------------------------
C
 1000 CONTINUE
      IDELLA = NINT(DPHIAC/XDELLA)
      IDELLO = NINT(DLAMAC/XDELLO)
C
C*    2. SOUTHERN MOST LATITUDE OF FINE GRID.
C        ------------------------------------
C
 2000 CONTINUE
      NI    = IDELLO - 1
      PHI   = AMOSOP
C
C*    2.1 LOOP OVER COARSE GRID POINTS.
C         -----------------------------
C
      DO 2101 I = 1, NX, IDELLO
C
C*    2.2 INTERPOLATION WEIGHT FOR INTERMEDIATE POINTS.
C         ---------------------------------------------
C
         IF (I.NE.NX) THEN
            DO 2201 N = 1, NI
               BFW (I+N) = REAL(N) / REAL(IDELLO)
 2201       CONTINUE
         ENDIF
C
C*    2.3 INDICES OF COARSE GRID OUTPUT POINTS.
C         -------------------------------------
C
         XLAMDA = AMOWEP + REAL(I-1) * XDELLO
         DO 2301 M=1,NBOUNC(NEST)
            IF (ABS(BLATC(M)-PHI).LT.ZERO .AND.
     &          ABS(BLNGC(M)-XLAMDA).LT.ZERO) THEN
               IBFL(I) = M
               IBFR(I) = M
               DO 2302 N = 1, NI
                  IF (I.NE.1) THEN
                     IBFR(I-N) = M
                  ENDIF
                  IF (I.NE.NX) THEN
                     IBFL(I+N) = M
                  ENDIF
 2302          CONTINUE
               GOTO 2101
            ENDIF
 2301    CONTINUE
 2101 CONTINUE
C
C*    3. NORTHERN MOST LATITUDE OF FINE GRID.
C        ------------------------------------
C
 3000 CONTINUE
      PHI = AMONOP
      IS  = NX + 2*(NY-2) + 1
      IE  = 2*(NX+NY-2)
C
C*    3.1 LOOP OVER COARSE GRID POINTS.
C         -----------------------------
C
      DO 3101 I = IS, IE, IDELLO
C
C*    3.2 INTERPOLATION WEIGHT FOR INTERMEDIATE POINTS.
C         ---------------------------------------------
C
         IF (I.NE.IE) THEN
            DO 3201 N = 1, NI
               BFW (I+N) = REAL(N) / REAL(IDELLO)
 3201       CONTINUE
         ENDIF
C
C*    3.3 INDICES OF COARSE GRID OUTPUT POINTS.
C         -------------------------------------
C
         XLAMDA = AMOWEP + (I-IS) * XDELLO
         DO 3301 M=1,NBOUNC(NEST)
            IF (ABS(BLATC(M)-PHI).LT.ZERO .AND.
     &          ABS(BLNGC(M)-XLAMDA).LT.ZERO) THEN
               IBFL(I) = M
               IBFR(I) = M
               DO 3302 N = 1, NI
                  IF (I.NE.IS) THEN
                     IBFR(I-N) = M
                  ENDIF
                  IF (I.NE.IE) THEN
                     IBFL(I+N) = M
                  ENDIF
 3302          CONTINUE
               GOTO 3101
            ENDIF
 3301    CONTINUE
 3101 CONTINUE
C
C*    4. WESTERN MOST LONGITUDE OF FINE GRID.
C        ------------------------------------
C
 4000 CONTINUE
      XLAMDA = AMOWEP
      NI = IDELLA - 1
      NSTEP = 2 * IDELLA
      IE = NX + 2*(NY-2) - 1
      IS = NX + 2*NI + 1
      K = 1
C
C*    4.1 WEIGHTS AND LEFT INDICES FOR FIRST COARSE GRID SECTION.
C        --------------------------------------------------------
C
      DO 4101 N = 1, NI
         IBFL(NX-1+2*N) = IBFL(1)
         BFW (NX-1+2*N) = REAL(N) / REAL(IDELLA)
 4101 CONTINUE
C
C*    4.2 LOOP OVER COARSE GRID POINTS.
C         -----------------------------
C
      DO 4201 I = IS, IE, NSTEP
C
C*    4.3 INTERPOLATION WEIGHT FOR INTERMEDIATE POINTS.
C         ---------------------------------------------
C
         DO 4301 N = 1, NI
            BFW (I+2*N) = REAL(N) / REAL(IDELLA)
 4301    CONTINUE
C
C*    4.4 INDICES OF COARSE GRID OUTPUT POINTS.
C         -------------------------------------
C
         K = K + 1
         PHI = AMOSOP + (K-1) * DPHIAC
         DO 4401 M=1,NBOUNC(NEST)
            IF (ABS(BLNGC(M)-XLAMDA).LT.ZERO .AND.
     &          ABS(BLATC(M)-PHI).LT.ZERO) THEN
               IBFL(I) = M
               IBFR(I) = M
               DO 4402 N = 1, NI
                  IBFL(I+2*N) = M
                  IBFR(I-2*N) = M
 4402          CONTINUE
               GOTO 4201
            ENDIF
 4401    CONTINUE
 4201 CONTINUE
C
C*    4.5 RIGHT INDICES FOR LAST COARSE GRID SECTION.
C         -------------------------------------------
C

C     !!changed 13-feb-97

      K = NX + (2* (NY-2)) + 1  
      IF (IBFR(K) .NE. 0) THEN
         DO 4501 N = 1, NI
            IBFR(K-2*N) = IBFR(K)
 4501    CONTINUE
      ENDIF
C
C*    5. EASTERN MOST LONGITUDE OF FINE GRID.
C        ------------------------------------
C
 5000 CONTINUE
      XLAMDA = AMOEAP
      IS = NX + 2*NI + 2
      IE = NX + 2*(NY-2)
      K = 1
C
C*    5.1 WEIGHTS AND LEFT INDICES FOR FIRST COARSE GRID SECTION.
C        --------------------------------------------------------
C
      DO 5101 N = 1, NI
         IBFL(NX+2*N) = IBFL(NX)
         BFW (NX+2*N) = REAL(N) / REAL(IDELLA)
 5101 CONTINUE
C
C*    5.2 LOOP OVER COARSE GRID POINTS.
C         -----------------------------
C
      DO 5201 I = IS, IE, NSTEP
C
C*    5.3 INTERPOLATION WEIGHT FOR INTERMEDIATE POINTS.
C         ---------------------------------------------
C
         DO 5301 N = 1, NI
            BFW (I+2*N) = REAL(N) / REAL(IDELLA)
 5301    CONTINUE
C
C*    5.4 INDICES OF COARSE GRID OUTPUT POINTS.
C         -------------------------------------
C
         K = K + 1
         PHI = AMOSOP + (K-1) * DPHIAC
         DO 5401 M=1,NBOUNC(NEST)
            IF (ABS(BLNGC(M)-XLAMDA).LT.ZERO .AND.
     &          ABS(BLATC(M)-PHI).LT.ZERO) THEN
               IBFL(I) = M
               IBFR(I) = M
               DO 5402 N = 1, NI
                  IBFL(I+2*N) = M
                  IBFR(I-2*N) = M
 5402          CONTINUE
               GOTO 5201
            ENDIF
 5401    CONTINUE
 5201 CONTINUE
C
C*    5.5 RIGHT INDICES FOR LAST COARSE GRID SECTION.
C         -------------------------------------------
C
      K = 2*(NX + NY - 2)
      IF (IBFR(K) .NE. 0) THEN
         M = NX + 2*NY - 2
         DO 5501 N = 1, NI
            IBFR(M-2*N) = IBFR(K)
 5501    CONTINUE
      ENDIF

      RETURN
      END
      SUBROUTINE MTABS (ML, KL)

C ----------------------------------------------------------------------
C
C**** *MTABS* - ROUTINE TO COMPUTE TABLES USED FOR SHALLOW WATER.
C
C     H.GUNTHER            ECMWF       04/04/1990
C
C*    PURPOSE.
C     -------
C
C       TO COMPUTE TABLES USED FOR SHALLOW WATER.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *MTABS (ML, KL)*
C          *ML*      - NUMBER OF FREQUENCIES.
C          *KL*      - NUMBER OF DIRECTIONS.
C
C     METHOD.
C     -------
C
C       TABLES FOR GROUP VELOCITY, WAVE NUMBER AND OMEGA/SINH(2KD)
C       ARE COMPUTED AT ALL FREQUENCIES AND FOR A DEPTH TABLE
C       OF LENGTH NDEPTH, STARTING AT DEPTHA METERS AND INCREMENTED
C        BY DEPTHD METRES.
C
C     EXTERNALS.
C     ----------
C
C       *AKI*       - FUNCTION TO COMPUTE WAVE NUMBER.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C

       INCLUDE 'preprowk.h'
C
C*    *COMMON* *FREDIR* - FREQUENCY AND DIRECTION GRID.
C
      COMMON /FREDIR/ FR(NFRE), DFIM(NFRE), GOM(NFRE), C(NFRE),
     1                DELTH, DELTR, TH(NANG), COSTH(NANG), SINTH(NANG)
C
C*    *COMMON* *SHALLOW*   SHALLOW WATER TABLES.
C
      PARAMETER (NDEPTH = 63)
C
      COMMON /SHALLOW/ DEPTH(NIBLO, NBLO), DEPTHA, DEPTHD,
     1                 TCGOND(NDEPTH,NFRE), TFAK(NDEPTH,NFRE),
     2                 TSIHKD(NDEPTH,NFRE), INDEP(NIBLO)
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER* OF GLOBAL CONSTANTS.
C
      PARAMETER (G = 9.806, PI = 3.14159265358978, CIRC = 40000000.,
     1           ZPI = 2.*PI, RAD = PI/180., DEG = 180./PI,
     2           R = CIRC/ZPI)
C
c     DEPTHA = 5.
      DEPTHA = 2.
      DEPTHD = 1.1
C
C ----------------------------------------------------------------------
C
C*    1. GROUP VELOCITY AND WAVE NUMBER.
C        -------------------------------
C
 1000 CONTINUE
C
C*    1.1 LOOP OVER FREQUENCIES.
C         ----------------------
C
 1100 CONTINUE
      GH = G/(4.*PI)
      DO 1101 M=1,ML
         OM=ZPI*FR(M)
C
C*    1.1.1 LOOP OVER DEPTH.
C           -----------------
C
 1110 CONTINUE
         DO 1111 JD=1,NDEPTH
            AD=DEPTHA*DEPTHD**(JD-1)
            AK=AKI(OM,AD)
            TFAK(JD,M)=AK
            AKD=AK*AD
            IF(AKD.LE.10.0) THEN
               TCGOND(JD,M) = 0.5*SQRT(G*TANH(AKD)/AK)*
     1                       (1.0+2.0*AKD/SINH(2.*AKD))
               TSIHKD(JD,M) = OM/SINH(2.*AKD)
            ELSE
               TCGOND(JD,M) = GH/FR(M)
               TSIHKD(JD,M) = 0.
            ENDIF
 1111    CONTINUE
 1101 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    2. PRINT TABLES.
C        -------------
C
 2000 CONTINUE
      NAN  = 10
      NSTP = NDEPTH/NAN
      NSTP = MAX(NSTP,1)
      DEPTHE = DEPTHA*DEPTHD**(NDEPTH-1)
      WRITE (IU06,'(1H1, '' SHALLOW WATER TABLES:'',/)')
      WRITE (IU06,'(''  LOGARITHMIC DEPTH FROM: DEPTHA = '',F5.1,
     1  '' TO DEPTHE  = '',F5.1, ''IN STEPS OF DEPTHD = '',F5.1)')
     2    DEPTHA, DEPTHE, DEPTHD
      WRITE (IU06,'(''  PRINTED IN STEPS OF '',I3,'' ENTRIES'',/)') NSTP
      DO 2001 JD=1,NDEPTH,NSTP
         AD=DEPTHA*DEPTHD**(JD-1)
         WRITE (IU06,'(1X,''DEPTH = '',F7.1,'' METRES '')') AD
         WRITE (IU06,'(1X,''GROUP VELOCITY IN METRES/SECOND'')')
         WRITE (IU06,'(1x,13F10.5)') (TCGOND(JD,M),M=1,ML)
         WRITE (IU06,'(1X,''WAVE NUMBER IN 1./METRES'')')
         WRITE (IU06,'(1x,13F10.5)') (TFAK(JD,M),M=1,ML)
         WRITE (IU06,'(1X,''OMEGA/SINH(2KD) IN 1./SECOND'')')
         WRITE (IU06,'(1x,13F10.5)') (TSIHKD(JD,M),M=1,ML)
 2001 CONTINUE

      RETURN
      END
      SUBROUTINE MUBUF (IA1, IG, IU08, IU18, IFORM)

C ----------------------------------------------------------------------
C
C**** *MUBUF* - ROUTINE TO ARRANGE COMMON UBUF FOR ONE BLOCK.
C
C     H.GUNTHER            ECMWF       04/04/1990
C
C*    PURPOSE.
C     -------
C
C       TO ARRANGE NEIGHBOUR GRID POINT INDICES FOR A BLOCK
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *MUBUF (IA1, IG, IU08, IU18, IFORM)*
C          *IA1*     - TOPOGRAPHIC DATA.
C          *IG*      - BLOCK NUMBER.
C          *IU08*    - LOGICAL UNIT FOR OUTPUT OF GRID BLOCKING
C                      COMMON UBUF (UNFORMATED)
C          *IU18*    - LOGICAL UNIT FOR OUTPUT OF GRID BLOCKING
C                      COMMON UBUF (FORMATED)
C          *IFORM*   - OUTPUT FORMAT OPTION = 1 UNFORMATED
C                                           = 2 FORMATED
C                                           OTHERWISE BOTH
C
C     METHOD.
C     -------
C
C       THE INDICES OF THE NEXT POINTS ON LAT. AND LONG. ARE
C       COMPUTED. ZERO INDICATES A LAND POINT IS NEIGHBOUR.
C       THE FINAL COMMON UBUF IS WRITTEN OUT.
C
C     EXTERNALS.
C     ----------
C
C       *OUTUBUF*   - WRITE OUT COMMON UBUF.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C      
       INCLUDE 'preprowk.h'
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *UBUF*  GRID POINT DEPENDENT CONSTANTS
C
      COMMON /UBUF/ KLAT(NIBLO,6), KLON(NIBLO,6)
C
C ----------------------------------------------------------------------
C
      DIMENSION IA1(NGX, NGY)
C
C ----------------------------------------------------------------------
C
C*    1. INITIALISE ARRAYS.
C        ------------------
C
 1000 CONTINUE
      DO 1001 IJ=1,NIBLO
          do 1001 i=1,6
            KLAT(IJ,i) = 0
            KLON(IJ,i) = 0
 1001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    2. COMPUTE INDICES OF NEIGHBOUR SEA POINTS.
C        ----------------------------------------
C
 2000 CONTINUE
C
C*    2.1 LONGITUDE NEIGHBOURS.
C         ---------------------
C
      DO 2100 IP = 1,IJLT(IG)
         I = IXLG(IP,IG)
         K = KXLT(IP,IG)
         IF (I.GT.1) THEN
           IF (IA1(I-1,K).GT.-990) KLON(IP,1) = IP-1
         ELSE
            IF (IPER.EQ.1 .AND. IA1(NX,K).GT.-990) THEN
               KLON(IP,1) = IP
               DO 2101 IH=2,NX
                  IF (IA1(IH,K).GT.-990) KLON(IP,1) = KLON(IP,1)+1
 2101          CONTINUE
            ENDIF
         ENDIF
         IF (I.LT.NX) THEN
           IF (IA1(I+1,K).GT.-990) KLON(IP,2) = IP+1
         ELSE
           IF (IPER.EQ.1 .AND. IA1(1,K).GT.-990) THEN
              KLON(IP,2) = IP
              DO 2102 IH=NX-1,1,-1
                 IF (IA1(IH,K).GT.-990) KLON(IP,2) = KLON(IP,2)-1
 2102         CONTINUE
            ENDIF
         ENDIF
 2100 CONTINUE
C
C*    2.2 LATITUDE NEIGHBOURS.
C         --------------------
C
      DO 2200 IP = 1,IJLT(IG)
         I = IXLG(IP,IG)
         K = KXLT(IP,IG)
         IF (K.GT.1) THEN
            IF (IA1(I,K-1).GT.-990) THEN
               DO 2201 IH = IP,1,-1
                  IF (IXLG(IH,IG).EQ.I .AND.
     1                KXLT(IH,IG).EQ.K-1) GOTO 2202
 2201          CONTINUE
 2202          CONTINUE
               KLAT(IP,1) = IH
            ENDIF
         ENDIF
         IF (K.LT.NY) THEN
            IF (IA1(I,K+1).GT.-990) THEN
               DO 2203 IH = IP,IJLT(IG)
                  IF (IXLG(IH,IG).EQ.I .AND.
     1                KXLT(IH,IG).EQ.K+1) GOTO 2204
 2203          CONTINUE
 2204          CONTINUE
               KLAT(IP,2) = IH
           ENDIF
         ENDIF
 2200 CONTINUE
C
C*    2.3 DIAGONAL NEIGHBOURS.
C         --------------------
C
      DO 2300 IP = 1,IJLT(IG)
         I = IXLG(IP,IG)
          K = KXLT(IP,IG)
          IF (K.GT.1) THEN
            IF (I.GT.1) THEN
              IF (IA1(I-1,K-1).GT.-990) THEN
                DO 2301 IH = IP,1,-1
                   IF (IXLG(IH,IG).EQ.I-1 .AND.
     1                KXLT(IH,IG).EQ.K-1) GOTO 2302
2301          CONTINUE
2302          CONTINUE
                KLAT(IP,3) = IH
              ENDIF
            ELSE
              IF (IPER.EQ.1 .AND. IA1(NX,K-1).GT.-990) THEN
                KLON(IP,3) = IP
                DO 2401 IH=2,NX
                  IF (IA1(IH,K-1).GT.-990) KLON(IP,3) = KLON(IP,3) + 1
2401          CONTINUE
              ENDIF
            ENDIF
            IF (I.LT.NX) THEN
              IF (IA1(I+1,K-1).GT.-990) THEN
                DO 2303 IH = IP,1,-1
                   IF (IXLG(IH,IG).EQ.I+1 .AND.
     1                KXLT(IH,IG).EQ.K-1) GOTO 2304
2303          CONTINUE
2304          CONTINUE
                KLAT(IP,5) = IH
              ENDIF
            ELSE
              IF (IPER.EQ.1 .AND. IA1(NX,K-1).GT.-990) THEN
                KLON(IP,5) = IP
                DO 2402 IH=NX-1,1,-1
                  IF (IA1(IH,K-1).GT.-990) KLON(IP,5) = KLON(IP,5) - 1
2402          CONTINUE
              ENDIF
            ENDIF
          ENDIF
          IF (K.LT.NY) THEN
            IF (I.GT.0) THEN
              IF (IA1(I-1,K+1).GT.-990) THEN
                DO 2305 IH = IP,IJLT(IG)
                   IF (IXLG(IH,IG).EQ.I-1 .AND.
     1                KXLT(IH,IG).EQ.K+1) GOTO 2306
2305          CONTINUE
2306          CONTINUE
                KLAT(IP,4) = IH
              ENDIF
            ELSE
              IF (IPER.EQ.1 .AND. IA1(NX,K+1).GT.-990) THEN
                KLON(IP,4) = IP
                DO 2403 IH=2,NX
                  IF (IA1(IH,K+1).GT.-990) KLON(IP,4) = KLON(IP,4) + 1
2403          CONTINUE
              ENDIF
            ENDIF
            IF (I.LT.NX) THEN
              IF (IA1(I+1,K+1).GT.-990) THEN
                DO 2307 IH = IP,IJLT(IG)
                   IF (IXLG(IH,IG).EQ.I+1 .AND.
     1                KXLT(IH,IG).EQ.K+1) GOTO 2308
2307          CONTINUE
2308          CONTINUE
                KLAT(IP,6) = IH
              ENDIF
            ELSE
              IF (IPER.EQ.1 .AND. IA1(NX,K+1).GT.-990) THEN
                KLON(IP,6) = IP
                DO 2404 IH=NX-1,1,-1
                  IF (IA1(IH,K+1).GT.-990) KLON(IP,6) = KLON(IP,6) + 1
2404          CONTINUE
              ENDIF
            ENDIF
          ENDIF
2300  CONTINUE
C ----------------------------------------------------------------------

C ----------------------------------------------------------------------
C
C*    3. OUTPUT OF COMMON UBUF FOR ONE BLOCK.
C        ------------------------------------
C
 3000 CONTINUE
      CALL OUTUBUF (IU08, IU18, IFORM)
      RETURN
      END
      SUBROUTINE NLWEIGT (ML, KL)

C ----------------------------------------------------------------------
C
C**** *NLWEIGT* - COMPUTATION OF INDEX ARRAYS AND WEIGHTS FOR THE
C                 COMPUTATION OF THE NONLINEAR TRANSFER RATE.
C
C     SUSANNE HASSELMANN JUNE 86.
C
C     H. GUNTHER   ECMWF/GKSS  DECEMBER 90 - CYCLE_4 MODIFICATIONS.
C                                            4 FREQUENCIES ADDED.
C
C*    PURPOSE.
C     --------
C
C       COMPUTATION OF PARAMETERS USED IN DISCRETE INTERACTION
C       PARAMETERIZATION OF NONLINEAR TRANSFER.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *NLWEIGT (ML, KL)*
C          *ML*     INTEGER   NUMBER OF FREQUENCIES.
C          *KL*     INTEGER   NUMBER OF DIRECTIONS.
C
C     METHOD.
C     -------
C
C       NONE.
C
C     EXTERNALS.
C     ----------
C
C       *JAFU*      - FUNCTION FOR COMPUTATION OF ANGULAR INDICES
C                     OF K(F,THET).
C
C     REFERENCE.
C     ----------
C       S. HASSELMANN AND K. HASSELMANN, JPO, 1985 B.
C
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C
       INCLUDE 'preprowk.h'
C
C*    *COMMON* *FREDIR* - FREQUENCY AND DIRECTION GRID.
C
      COMMON /FREDIR/ FR(NFRE), DFIM(NFRE), GOM(NFRE), C(NFRE),
     1                DELTH, DELTR, TH(NANG), COSTH(NANG), SINTH(NANG)
C
C*    *COMMON* *INDNL* - INDICES AND WEIGHTS USED IN THE COMPUTATION
C                        OF THE NONLINEAR TRANSFER RATE.
C
      COMMON /INDNL/ IKP(NFRE+4), IKP1(NFRE+4),
     1               IKM(NFRE+4), IKM1(NFRE+4),
     2               K1W(NANG,2), K2W(NANG,2), K11W(NANG,2),
     3               K21W(NANG,2), AF11(NFRE+4), FKLAP(NFRE+4),
     4               FKLAP1(NFRE+4), FKLAM(NFRE+4), FKLAM1(NFRE+4),
     5               ACL1, ACL2,  CL11, CL21, DAL1, DAL2, FRH(30)
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER* OF GLOBAL CONSTANTS.
C
      PARAMETER (G = 9.806, PI = 3.14159265358978, CIRC = 40000000.,
     1           ZPI = 2.*PI, RAD = PI/180., DEG = 180./PI,
     2           R = CIRC/ZPI)
C
C*    *PARAMETER*  FOR DISCRETE APPROXIMATION OF NONLINEAR TRANSFER
C
      PARAMETER (ALAMD=0.25, CON=3000., DELPHI1=-11.48, DELPHI2=33.56)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *ALAMD*     REAL      LAMBDA
C      *CON*       REAL      WEIGHT FOR DISCRETE APPROXIMATION OF
C                            NONLINEAR TRANSFER
C      *DELPHI1*   REAL
C      *DELPHI2*   REAL
C
C ----------------------------------------------------------------------
C
      PARAMETER (CO = 1.1)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *CO*        REAL      FREQUENCY RATIO.
C
C ----------------------------------------------------------------------
C
      DIMENSION JA1(NANG,2), JA2(NANG,2), FRLON(2*NFRE+2)
C
C ----------------------------------------------------------------------
C
C*    1. COMPUTATION FOR ANGULAR GRID.
C        -----------------------------
C
 1000 CONTINUE
C
      DELTHA = DELTH*DEG
      CL1 = DELPHI1/DELTHA
      CL2 = DELPHI2/DELTHA
C
C*    1.1 COMPUTATION OF INDICES OF ANGULAR CELL.
C         ---------------------------------------
C
      KLP1 = KL+1
      IC = 1
      DO 1001 KH=1,2
         KLH = KL
         IF (KH.EQ.2) KLH=KLP1
         DO 1002 K=1,KLH
            KS = K
            IF (KH.GT.1) KS=KLP1-K+1
            IF (KS.GT.KL) GO TO 1002
            CH = IC*CL1
            JA1(KS,KH) = JAFU(CH,K,KLP1)
            CH = IC*CL2
            JA2(KS,KH) = JAFU(CH,K,KLP1)
 1002    CONTINUE
         IC = -1
 1001 CONTINUE
C
C*    1.2 COMPUTATION OF ANGULAR WEIGHTS.
C         -------------------------------
C
      ICL1 = CL1
      CL1  = CL1-ICL1
      ICL2 = CL2
      CL2  = CL2-ICL2
      ACL1 = ABS(CL1)
      ACL2 = ABS(CL2)
      CL11 = 1.-ACL1
      CL21 = 1.-ACL2
      AL11 = (1.+ALAMD)**4
      AL12 = (1.-ALAMD)**4
      DAL1 = 1./AL11
      DAL2 = 1./AL12
C
C*    1.3 COMPUTATION OF ANGULAR INDICES.
C         -------------------------------
C
      ISG = 1
      DO 1301 KH=1,2
         CL1H = ISG*CL1
         CL2H = ISG*CL2
         DO 1302 K=1,KL
            KS = K
            IF (KH.EQ.2) KS = KL-K+2
            IF(K.EQ.1) KS = 1
            K1 = JA1(K,KH)
            K1W(KS,KH) = K1
            IF (CL1H.LT.0.) THEN
               K11 = K1-1
               IF (K11.LT.1) K11 = KL
            ELSE
              K11 = K1+1
              IF (K11.GT.KL) K11 = 1
            ENDIF
            K11W(KS,KH) = K11
            K2 = JA2(K,KH)
            K2W(KS,KH) = K2
            IF (CL2H.LT.0) THEN
               K21 = K2-1
               IF(K21.LT.1) K21 = KL
            ELSE
               K21 = K2+1
               IF (K21.GT.KL) K21 = 1
            ENDIF
            K21W(KS,KH) = K21
 1302    CONTINUE
         ISG = -1
 1301 CONTINUE
C
C*    2. COMPUTATION FOR FREQUENCY GRID.
C        -------------------------------
C
 2000 CONTINUE
C
      DO 2001 M=1,ML
         FRLON(M) = FR(M)
 2001 CONTINUE
      DO 2002 M=ML+1,2*ML+2
         FRLON(M) = CO*FRLON(M-1)
 2002 CONTINUE
      F1P1 = ALOG10(CO)
      DO 2003 M=1,ML+4
         FRG = FRLON(M)
         AF11(M) = CON * FRG**11
         FLP = FRG*(1.+ALAMD)
         FLM = FRG*(1.-ALAMD)
         IKN = IFIX(ALOG10(1.+ALAMD)/F1P1+.000001)
         IKN = M+IKN
         IKP(M) = IKN
         FKP = FRLON(IKP(M))
         IKP1(M) = IKP(M)+1
         FKLAP(M) = (FLP-FKP)/(FRLON(IKP1(M))-FKP)
         FKLAP1(M) = 1.-FKLAP(M)
         IF (FRLON(1).GE.FLM) THEN
            IKM(M) = 1
            IKM1(M) = 1
            FKLAM(M) = 0.
            FKLAM1(M) = 0.
         ELSE
            IKN = IFIX(ALOG10(1.-ALAMD)/F1P1+.0000001)
            IKN = M+IKN-1
            IF (IKN.LT.1) IKN = 1
            IKM(M) = IKN
            FKM = FRLON(IKM(M))
            IKM1(M) = IKM(M)+1
            FKLAM(M) = (FLM-FKM)/(FRLON(IKM1(M))-FKM)
            FKLAM1(M) = 1.-FKLAM(M)
         ENDIF
 2003 CONTINUE
C
C*    3. COMPUTE TAIL FREQUENCY RATIOS.
C        ------------------------------
C
 3000 CONTINUE
      IE = MIN(30,ML+3)
      DO 3001 I=1,IE
         M = ML+I-1
         FRH(I) = (FRLON(ML)/FRLON(M))**5
 3001 CONTINUE
C
C*    4. PRINTER PROTOCOL.
C        -----------------
C
 4000 CONTINUE
      WRITE(IU06,'(1H1,'' NON LINEAR INTERACTION PARAMETERS:'')')
      WRITE(IU06,'(1H0,'' COMMON INDNL: CONSTANTS'')')
      WRITE(IU06,'(1X,''    ACL1       ACL2   '',
     1             ''    CL11       CL21   '',
     2             ''    DAL1       DAL2'')')
      WRITE(IU06,'(1X,6F11.8)') ACL1, ACL2, CL11, CL21, DAL1, DAL2

      WRITE(IU06,'(1H0,'' COMMON INDNL: FREQUENCY ARRAYS'')')
      WRITE(IU06,'(1X,'' M   IKP IKP1  IKM IKM1'',
     1          ''   FKLAP       FKLAP1 '',
     2          ''   FKLAM       FKLAM1     AF11'')')
      DO 4001 M=1,ML+4
         WRITE(IU06,'(1X,I2,4I5,4F11.8,E11.3)')
     1      M, IKP(M), IKP1(M), IKM(M), IKM1(M),
     2      FKLAP(M), FKLAP1(M), FKLAM(M), FKLAM1(M), AF11(M)
 4001 CONTINUE

      WRITE(IU06,'(1H0,'' COMMON INDNL: ANGULAR ARRAYS'')')
      WRITE(IU06,'(1X,''  |--------KH = 1----------|'',
     1              ''|--------KH = 2----------|'')')
      WRITE(IU06,'(1X,'' K   K1W   K2W  K11W  K21W'',
     1              ''   K1W   K2W  K11W  K21W'')')
      DO 4002 K=1,KL
      WRITE(IU06,'(1X,I2,8I6)') K,(K1W(K,KH), K2W(K,KH), K11W(K,KH),
     2              K21W(K,KH),KH=1,2)
 4002 CONTINUE
      WRITE(IU06,'(1H0,'' COMMON INDNL: TAIL ARRAY FRH'')')
      WRITE(IU06,'(1X,8F10.7)') (FRH(M),M=1,30)

      RETURN
      END
      SUBROUTINE OUTCOM (IU07, IU17, IFORM, IREFRA, ML, KL)

C ----------------------------------------------------------------------
C
C**** *OUTCOM* - ROUTINE TO WRITE COMMON TO DISK
C
C     H.GUNTHER            ECMWF       04/04/1990
C
C*    PURPOSE.
C     -------
C
C       TO WRITE OUT THE COMPUTED COMMON BLOCKS
C       (COMMON UBUF IS WRITTEN IN OUTUBUF)
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *OUTCOM (IU07, IU17, IFORM, IREFRA, ML, KL)*
C          *IU07*   - LOGICAL UNIT FOR  UNFORMATED WRITE.
C          *IU17*   - LOGICAL UNIT FOR    FORMATED WRITE.
C          *IFORM*   - FORMAT OPTION  = 1  UNFORMATED WRITE.
C                                     = 2  FORMATED WRITE.
C                                     OTHERWISE BOTH.
C          *IREFRA*  - REFRACTION OPTION.
C          *ML*      - NUMBER OF FREQUENCIES.
C          *KL*      - NUMBER OF DIRECTIONS.
C
C     METHOD.
C     -------
C
C       COMMON BLOCKS COUPLE, CURRENT, FREDIR, INDNL, GRIDPAR, MAP,
C       COUT, TABLE, AND SHALLOW ARE WRITTEN TO UNIT.
C       ALL FREQUENCY AND DIRECTION DEPENDENT ARRAYS
C       ARE WRITTEN FROM 1 TO THE USED NUMBER OF FREQUENCIES (ML),
C       AND THE USED NUMBER OF DIRECTIONS (KL). OTHER ARRAYS ARE
C       WRITTEN ACCORDING TO THEIR DIMENSIONS.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C
       INCLUDE 'preprowk.h'
C
C*    *COMMON* *COUPL* - PARAMETERS FOR COUPLING.
C
      COMMON /COUPL/ BETAMAX, ZALP, ALPHA, XKAPPA, XNLEV
C
C*    *COMMON* *CURRENT* - CURRENT FIELD.
C
      COMMON /CURRENT/ U(0:NIBLC,NBLC), V(0:NIBLC,NBLC)
C
C*    *COMMON* *FREDIR* - FREQUENCY AND DIRECTION GRID.
C
      COMMON /FREDIR/ FR(NFRE), DFIM(NFRE), GOM(NFRE), C(NFRE),
     1                DELTH, DELTR, TH(NANG), COSTH(NANG), SINTH(NANG)
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*    *COMMON* *INDNL* - INDICES AND WEIGHTS USED IN THE COMPUTATION
C                        OF THE NONLINEAR TRANSFER RATE.
C
      COMMON /INDNL/ IKP(NFRE+4), IKP1(NFRE+4),
     1               IKM(NFRE+4), IKM1(NFRE+4),
     2               K1W(NANG,2), K2W(NANG,2), K11W(NANG,2),
     3               K21W(NANG,2), AF11(NFRE+4), FKLAP(NFRE+4),
     4               FKLAP1(NFRE+4), FKLAM(NFRE+4), FKLAM1(NFRE+4),
     5               ACL1, ACL2,  CL11, CL21, DAL1, DAL2, FRH(30)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *COUT*  OUTPUT POINTS INDICES AND FLAGS.
C
      LOGICAL FFLAG(14), FFLAG20, FFLAG21, FFLAG25, FFLAG26,
     1        PFLAG(14), PFLAG20, PFLAG21, PFLAG25, PFLAG26
      COMMON /COUT/ NGOUT, IGAR(MOUTP), IJAR(MOUTP),
     1              NOUTT, IOUTT(MOUTT),
     2              FFLAG, FFLAG20, FFLAG21, FFLAG25, FFLAG26,
     3              PFLAG, PFLAG20, PFLAG21, PFLAG25, PFLAG26
C
C*    *COMMON* *SHALLOW*   SHALLOW WATER TABLES.
C
      PARAMETER (NDEPTH = 63)
C
      COMMON /SHALLOW/ DEPTH(NIBLO, NBLO), DEPTHA, DEPTHD,
     1                 TCGOND(NDEPTH,NFRE), TFAK(NDEPTH,NFRE),
     2                 TSIHKD(NDEPTH,NFRE), INDEP(NIBLO)
C
C*    *COMMON* *TABLE* - TABLE FOR TOTAL STRESS AND HIGH FREQ STRESS.
C
      PARAMETER (ITAUMAX=100, JUMAX=100, IUSTAR=100, IALPHA=100)
C
      COMMON /TABLE/ TAUT(0:ITAUMAX,0:JUMAX), DELTAUW, DELU,
     1               TAUHFT(0:IUSTAR,0:IALPHA), DELUST, DELALP
C
C ----------------------------------------------------------------------
C
  998 FORMAT(10I8)
  999 FORMAT(5E16.7)
C
C ----------------------------------------------------------------------
C
C*    1. WRITE COMMON FREDIR.
C        --------------------
C
 1000 CONTINUE
      IF (IFORM.NE.2) THEN
         WRITE (IU07) (FR(M),M=1,ML), (DFIM(M),M=1,ML),
     1                (GOM(M),M=1,ML), (C(M),M=1,ML),
     2                DELTH, DELTR, (TH(K),K=1,KL),
     3                (COSTH(K),K=1,KL), (SINTH(K),K=1,KL)
      ENDIF
      IF (IFORM.NE.1) THEN
         WRITE (IU17,999) (FR(M),M=1,ML), (DFIM(M),M=1,ML),
     1                    (GOM(M),M=1,ML), (C(M),M=1,ML),
     2                    DELTH, DELTR, (TH(K),K=1,KL),
     3                    (COSTH(K),K=1,KL), (SINTH(K),K=1,KL)
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    2. WRITE COMMON GRIDPAR.
C        ---------------------
C
 2000 CONTINUE
      IF (IFORM.NE.2) THEN
         WRITE (IU07) DELPHI, DELLAM,
     1                (SINPH(L),L=1,NY), (COSPH(L),L=1,NY),
     2                IGL, IJS, IJL2, IJLS, IJL, IJLT
      ENDIF
      IF (IFORM.NE.1) THEN
         WRITE (IU17,999) DELPHI, DELLAM,
     1                    (SINPH(L),L=1,NY), (COSPH(L),L=1,NY)
         WRITE (IU17,998) IGL, IJS, IJL2, IJLS, IJL, IJLT
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    3. WRITE COMMON MAP.
C        -----------------
C
 3000 CONTINUE
      IF (IFORM.NE.2) THEN
         WRITE (IU07) IXLG, KXLT, NX, NY, IPER,
     1                AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
      ENDIF
      IF (IFORM.NE.1) THEN
         WRITE (IU17,998) IXLG, KXLT, NX, NY, IPER
         WRITE (IU17,999) AMOWEP, AMOSOP, AMOEAP, AMONOP,
     1                    XDELLA, XDELLO
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    4. WRITE COMMON INDNL.
C        -------------------
C
 4000 CONTINUE
      IF (IFORM.NE.2) THEN
         WRITE (IU07) (IKP(M),M=1,ML+4), (IKP1(M),M=1,ML+4),
     1                (IKM(M),M=1,ML+4), (IKM1(M),M=1,ML+4),
     2                ((K1W(K,L),K=1,KL),L=1,2),
     3                ((K2W(K,L),K=1,KL),L=1,2),
     4                ((K11W(K,L),K=1,KL),L=1,2),
     5                ((K21W(K,L),K=1,KL),L=1,2),
     6                (AF11(M),M=1,ML+4), (FKLAP(M),M=1,ML+4),
     7                (FKLAP1(M),M=1,ML+4), (FKLAM(M),M=1,ML+4),
     8                (FKLAM1(M),M=1,ML+4),
     9                ACL1, ACL2,  CL11, CL21, DAL1, DAL2, FRH
      ENDIF
      IF (IFORM.NE.1) THEN
         WRITE (IU17,998) (IKP(M),M=1,ML+4), (IKP1(M),M=1,ML+4),
     1                    (IKM(M),M=1,ML+4), (IKM1(M),M=1,ML+4),
     2                    ((K1W(K,L),K=1,KL),L=1,2),
     3                    ((K2W(K,L),K=1,KL),L=1,2),
     4                    ((K11W(K,L),K=1,KL),L=1,2),
     5                    ((K21W(K,L),K=1,KL),L=1,2)
         WRITE (IU17,999) (AF11(M),M=1,ML+4),   (FKLAP(M),M=1,ML+4),
     1                    (FKLAP1(M),M=1,ML+4), (FKLAM(M),M=1,ML+4),
     2                    (FKLAM1(M),M=1,ML+4),
     3                    ACL1, ACL2,  CL11, CL21, DAL1, DAL2, FRH
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    5. WRITE COMMON COUPLE.
C        --------------------
C
 5000 CONTINUE
      IF (IFORM.NE.2) THEN
         WRITE (IU07) BETAMAX, ZALP, ALPHA, XKAPPA, XNLEV
      ENDIF
      IF (IFORM.NE.1) THEN
         WRITE (IU17,999) BETAMAX, ZALP, ALPHA, XKAPPA, XNLEV
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    6. WRITE COMMON TABLE.
C        -------------------
C
 6000 CONTINUE
      IF (IFORM.NE.2) THEN
         WRITE (IU07) TAUT, DELTAUW, DELU, TAUHFT, DELUST, DELALP
      ENDIF
      IF (IFORM.NE.1) THEN
         WRITE (IU17,999) TAUT, DELTAUW, DELU, TAUHFT, DELUST, DELALP
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    7. WRITE COMMON COUT.
C        ------------------
C
 7000 CONTINUE
      IF (IFORM.NE.2) THEN
         WRITE (IU07)  NGOUT, IGAR, IJAR
      ENDIF
      IF (IFORM.NE.1) THEN
         WRITE (IU17,998)  NGOUT, IGAR, IJAR
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    8. WRITE COMMON SHALLOW.
C        ---------------------
C
 8000 CONTINUE
      IF (IFORM.NE.2) THEN
         WRITE (IU07) DEPTH, DEPTHA, DEPTHD,
     1                ((TCGOND(L,M),L=1,NDEPTH),M=1,ML),
     2                ((TFAK(L,M),L=1,NDEPTH),M=1,ML),
     3                ((TSIHKD(L,M),L=1,NDEPTH),M=1,ML)
      ENDIF
      IF (IFORM.NE.1) THEN
         WRITE (IU17,999) DEPTH, DEPTHA, DEPTHD,
     1                    ((TCGOND(L,M),L=1,NDEPTH),M=1,ML),
     2                    ((TFAK(L,M),L=1,NDEPTH),M=1,ML),
     3                    ((TSIHKD(L,M),L=1,NDEPTH),M=1,ML)
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    9. WRITE COMMON CURRENT.
C        ---------------------
C
 9000 CONTINUE
      IF (IREFRA.EQ.2) THEN
         IF (IFORM.NE.2) WRITE (IU07) U, V
         IF (IFORM.NE.1) WRITE (IU17,999) U, V
      ENDIF

      RETURN
      END
      SUBROUTINE OUTPP (IDATE, IUOUT, TITL, CONST, ARRAY)

C ---------------------------------------------------------------
C
C**** *OUTPP* - FORMATED OUTPUT OF AN ARRAY.
C
C     H. GUNTHER       ECMWF    NOVEMBER 1989
C
C*    PURPOSE.
C     --------
C
C       FORMATED OUTPUT OF AN ARRAY.
C
C**   INTERFACE.
C     ---------
C
C       *CALL* *OUTPP (IDATE, IUOUT, TITL, CONST, ARRAY)*
C          *IDATE*    INTEGER   DATE (YYMMDDHHMM).
C          *IUOUT*    INTEGER   OUTPUT UNIT.
C          *TITL*     CHARACTER HEADER TO BE PRINTED.
C          *CONST*    REAL      SCALING FACTOR.
C          *ARRAY*    REAL      ARRAY TO BE PRINTED.
C
C     METHOD.
C     -------
C
C       A TWO DIMENSIONAL ARRAY IS PRINTED WITH A MAXIMUM OF
C       30 COLUMNS PER PAGE.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C
       INCLUDE 'preprowk.h'
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C

      CHARACTER TITL*100
      DIMENSION IARRAY(NGX,NGY),ARRAY(NGX,NGY),ILON(NGX),YLAT(NGY)
C
C ----------------------------------------------------------------------
C
C
C*    1. INITIALIZATION
C     -----------------
C
      DLAMA = (AMOEAP-AMOWEP)/FLOAT(NX-1)
      DO 110 I=1,NX
         ILON(I)=NINT(AMOWEP + (I-1)*DLAMA)
 110  CONTINUE

      DPHIA = (AMOSOP-AMONOP)/FLOAT(NY-1)
      DO 120 J=1,NY
         YLAT(J)=AMONOP + (J-1)*DPHIA
 120  CONTINUE

      NPTS=30
      NPAGE=(NX+NPTS-1)/NPTS

      DO 100 J=1,NY
      DO 100 I=1,NX
         IARRAY(I,J) = NINT(CONST*ARRAY(I,J))
 100  CONTINUE

      ISTART=-NPTS+1
      IEND=ISTART+NPTS-1

      DO 200 NP=1,NPAGE
         WRITE (IUOUT,300) IDATE,TITL,NP
         ISTART=ISTART+NPTS
         IEND= MIN(IEND+NPTS,NX)
         WRITE (IUOUT,302) (I,I=ISTART,IEND)
         WRITE (IUOUT,303) (ILON(I),I=ISTART,IEND)
         WRITE (IUOUT,304)
         DO 220 J=1,NY
            WRITE (IUOUT,305) J,YLAT(J),(IARRAY(I,J),I=ISTART,IEND)
 220     CONTINUE
 200  CONTINUE

 300  FORMAT(1H1,6X,I10.10,2X,A100,5X,'PAGE ',I2,/)
 302  FORMAT(7X,'I=',30I4)
 303  FORMAT(5X,'LON=',30I4)
 304  FORMAT('   J LAT',/)
 305  FORMAT(1X,I2,F5.1,1X,30I4)

      RETURN
      END
      SUBROUTINE OUTUBUF (IU08, IU18, IFORM)

C ----------------------------------------------------------------------
C
C**** *OUTUBUF* - ROUTINE TO WRITE COMMON UBUF TO DISK.
C
C     H.GUNTHER            ECMWF       04/04/1990
C
C*    PURPOSE.
C     -------
C
C       TO WRITE OUT THE COMPUTED COMMON UBUF.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *OUTUBUF (IU08, IU18, IFORM)*
C         *IU08*   - LOGICAL UNIT FOR  UNFORMATED WRITE
C         *IU18*   - LOGICAL UNIT FOR    FORMATED WRITE
C         *IFORM*  - FORMAT OPTION  = 1  UNFORMATED WRITE
C                                   = 2  FORMATED WRITE
C                                   OTHERWISE BOTH
C     METHOD.
C     -------
C
C       FORMATED AND OR UNFORMATED WRITE TO UNITS.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C

       INCLUDE 'preprowk.h'
C
C*    *COMMON* *UBUF*  GRID POINT DEPENDENT CONSTANTS
C
      COMMON /UBUF/ KLAT(NIBLO,6), KLON(NIBLO,6)
C
C ----------------------------------------------------------------------
C
  998 FORMAT(10I8)
  999 FORMAT(5E16.7)
C
C ----------------------------------------------------------------------
C
C*    1. WRITE COMMON UBUF UNFORMATED.
C        -----------------------------
C
 1000 CONTINUE
      IF (IFORM.NE.2) WRITE (IU08) KLAT, KLON
C
C ----------------------------------------------------------------------
C
C*    2. WRITE COMMON UBUF FORMATED.
C        ---------------------------
C
 2000 CONTINUE
      IF (IFORM.NE.1) WRITE (IU18,998) KLAT, KLON
      RETURN
      END
      SUBROUTINE PACKI (NIN, NOUT, NDIM, IFLAG, IPACK)

C ----------------------------------------------------------------------
C
C**** *PACKI* - PACKS A INTEGER ARRAY.
C
C     R. PORTZ     MPI         15/01/1991
C
C*    PURPOSE.
C     --------
C
C       TO REMOVE FLAGGED POINTS FROM AN INTEGER ARRAY.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *PACKI (NIN, NOUT, NDIM, IFLAG, IPACK)*
C          *NIN*   -  NUMBER OP POINTS IN ARRAYS BEFORE PACKING.
C          *NOUT*  -  NUMBER OF POINTS IN ARRAYES AFTER PACKING.
C          *NDIM*  -  DIMENSION OF ARRAYS.
C          *IFLAG* -  FLAG ARRAY.
C          *IPACK* -  ARRAY TO BE PACKED / PACKED ARRAY AT OUTPUT.
C
C     METHOD.
C     -------
C
C       NONE.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
      DIMENSION IFLAG(NDIM), IPACK(NDIM)
C
C ----------------------------------------------------------------------
C
C
C*    1. LOOP OVER POINTS.
C        -----------------
C
 1000 CONTINUE
      K = 0
      DO 1001 I = 1, NIN
         IF (IFLAG(I).EQ.0) THEN
            K = K + 1
         ELSE
            IPACK(I-K) = IPACK(I)
         ENDIF
 1001 CONTINUE
C
C*    2. NUMBER OF POINTS LEFT.
C        ----------------------
C
      NOUT = NIN - K

      RETURN
      END
      SUBROUTINE PACKR (NIN, NOUT, NDIM, IFLAG, PACK)

C ----------------------------------------------------------------------
C
C**** *PACKR* - PACKS A REAL ARRAY.
C
C     R. PORTZ     MPI         15/01/1991
C
C*    PURPOSE.
C     -------
C
C       TO REMOVE FLAGGED POINTS FROM AN REAL ARRAY.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *PACKR (NIN, NOUT, NDIM, IFLAG, PACK)*
C          *NIN*   -  NUMBER OP POINTS IN ARRAYS BEFORE PACKING.
C          *NOUT*  -  NUMBER OF POINTS IN ARRAYES AFTER PACKING.
C          *NDIM*  -  DIMENSION OF ARRAYS.
C          *IFLAG* -  FLAG ARRAY.
C          *PACK*  -  ARRAY TO BE PACKED / PACKED ARRAY AT OUTPUT.
C
C     METHOD.
C     -------
C
C       NONE.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
      DIMENSION IFLAG(NDIM), PACK(NDIM)
C
C ----------------------------------------------------------------------
C
C
C*    1. LOOP OVER POINTS.
C        -----------------
C
 1000 CONTINUE
      K = 0
      DO 1001 I = 1, NIN
         IF (IFLAG(I).EQ.0) THEN
            K = K + 1
	 ELSE
	    PACK(I-K) = PACK(I)
	 ENDIF
 1001 CONTINUE
C
C*    2. NUMBER OF POINTS LEFT.
C        ----------------------
C
      NOUT = NIN - K

      RETURN
      END
C ----------------------------------------------------------------------
C ###MAIN###  ###MAIN###  ###MAIN###  ###MAIN###
      PROGRAM PREPROC
C ###MAIN###  ###MAIN###  ###MAIN###  ###MAIN###
C ----------------------------------------------------------------------
C ----------------------------------------------------------------------
C
C**** *PROGRAM PREPROC* - PREPARE DATA (BUT NOT WINDS) FOR INPUT
C                         TO WAM WAVE MODELS.
C
C     SUSANNE HASSELMANN  MPI     JUNE 1986.
C
C     ANNEGRET SPEIDEL    MPI  OCTOBER 1988. MODFIED FOR CYCLE_2.
C
C     K. HUBBERT          POL     JUNE 1989  DEPTH AND CURRENT
C                                            REFRACTION.
C
C     H. GUNTHER   ECMWF/GKSS    APRIL 1990  LAND POINTS ARE REMOVED
C                                            FROM BLOCKS AND THE CODE
C                                            HAS BEEN RESTRUCTURED.
C
C     R. PORTZ     MPI         JANUARY 1991  NESTED GRID OPTION.
C
C     H. GUNTHER   ECMWF/GKSS    APRIL 1991  CYCLE_4 MODIFICATIONS.
C                                            MULTI-PART REMOVED.
C                                            NEW SOURCE FUNCTIONS.
C                                            LOG. DEPTH TABLE.
C
C*    PURPOSE.
C     --------
C
C       TO ARRANGE A GRID FOR THE WAM WAVE MODEL AND COMPUTE
C       ALL FIXED MODEL PARAMETERS WHICH ARE STORED IN DIFFERENT
C       COMMON BLOCKS.
C
C     METHOD.
C     -------
C
C       A REPRESENTATIVE TOPOGRAPHIC DATA SET ON LAT-LONG
C       COORDINATES CONTAINING THE MODEL SQUARE BOX REGION IS
C       READ IN.THE MODEL REGION IS EXTRACTED AND INTERPOLATED
C       ONTO GIVEN LAT-LONG GRID INCREMENTS (SEE SUB TOPOAR).
C       THE PROGRAM CHECKS FOR A PERIODIC LATITUDE GRID. IF THE
C       GRID IS NOT PERIODIC A CLOSED BASIN IS ASSUMED.
C       THE PROGRAM DOES NOT DISTINGUISH BETWEEN DEEP AND SHALLOW
C       WATER.
C
C       -BLOCK STRUCTURE :
C        GRID POINTS ARE COLLECTED INTO A 1-DIMENSIONAL ARRAY,
C        BLOCKS OF MAXIMALLY NIBLO ELEMENTS,  GRID POINTS
C        (ONLY SEAPOINTS) ARE COUNTED ALONG LINES OF LATITUDES
C        FROM WEST TO EAST WORKING FROM SOUTH TO NORTH.
C        BLOCKS OVERLAP OVER TWO LATITUDE LINES,TO COMPUTE NORTH
C        -SOUTH ADVECTION TERMS.
C
C       -NESTED GRIDS: THE GRID GENERATED CAN BE A
C         - COARSE GRID WHICH MEANS OUTPUT OF SPECTRA
C                       FOR A FOLLOW UP FINE GRID RUN.
C         - FINE   GRID WHICH MEANS INPUT OF SPECTRA
C                       FROM  AN EARLIER COARSE GRID RUN.
C         - COARSE AND FINE GRID
C
C       - REFRACTION: CONTROLLED BY THE REFRACTION OPTION
C         A CURRENT FIELD IS READ, INTERPOLATED TO THE MODEL
C         GRID AND STORED IN THE GRID OUTPUT FILE.
C
C       - PARAMETERS FOR ARRAY DIMENSIONS: THE PRORAM CHECKS
C         ALL DIMENSIONS INTERNALLY. ONLY THE BLOCK LENGTH
C         (NIBLO) IS USED FOR THE SET UP OF THE GRID, ALL
C         THE OTHER PARAMETERS HAVE TO BE LARGE ENOUGH TO
C         GET A SUCCESFULL RUN OF THE JOB. AT THE END OF
C         THE OUTPUT PROTOCOLL A LIST IS PRINTED FOR THE
C         OPTIMAL SETTINGS OF THE DIMENSION.
C
C**   INTERFACE.
C     ----------
C
C       *PROGRAM* *PREPROC*
C
C       *IU01*   - LOGICAL UNIT FOR INPUT OF TOPOGRAPHIC DATA.
C                  (SEE SUB TOPOAR).
C       *IU02*   - LOGICAL UNIT FOR INPUT OF CURRENTS.
C                  (SEE SUB READCUR).
C       *IU03*   - LOGICAL UNIT FOR INPUT OF COARSE GRID
C                  BOUNDARY ORGANISATION (COMMON CBOUND).
C                  IF THIS IS A FINE GRID PREPROC.
C                  FORMATED IF IFORM = 2 OTHERWISE UNFORMATED.
C                  (SEE SUB MBOUNF).
C       *IU05*   - LOGICAL UNIT FOR USER INPUT. (SEE SUB UIPREP).
C       *IU06*   - LOGICAL UNIT FOR PRINTER OUTPUT UNIT
C       *IU07*   - LOGICAL UNIT FOR OUTPUT OF GRID ORGANISATION
C                  AND COMPUTED CONSTANTS. (UNFORMATED)
C                  (SEE SUB OUTCOM).
C       *IU08*   - LOGICAL UNIT FOR OUTPUT OF COMMON UBUF.
C                  (UNFORMATED) (SEE SUB OUTUBUF).
C       *IU09*   - LOGICAL UNIT FOR UNFORMATED OUTPUT OF COARSE
C                  GRID BOUNDARY ORGANISATION (COMMON CBOUND),
C                  IF THIS IS A COARSE GRID PREPROC.
C                  (SEE SUB MBOUNC).
C       *IU10*   - LOGICAl UNIT FOR UNFORMATED OUTPUT OF FINE
C                  GRID BOUNDARY ORGANISATION (COMMON CBOUND).
C                  IF THIS IS A FINE GRID PREPROC.
C                  (SEE SUB MBOUNF).
C       *IU17*   - SAME AS IU07 BUT FORMATED.
C       *IU18*   - SAME AS IU08 BUT FORMATED.
C       *IU19*   - SAME AS IU09 BUT FORMATED.
C       *IU20*   - SAME AS IU10 BUT FORMATED.
C
C       ALL UNITS ARE DEFINE IN SECTION 1. OF THIS PROGRAM.
C
C       COMMON BLOCKS COUPLE, CURRENT, FREDIR, INDNL, GRIDPAR, MAP,
C       COUT, TABLE, AND SHALLOW ARE WRITTEN TO UNIT IU07 AND/OR IU17.
C       ALL FREQUENCY AND DIRECTION DEPENDENT ARRAYS ARE WRITTEN FROM
C       1 TO THE USED NUMBER OF FREQUENCIES AND THE USED NUMBER OF
C       DIRECTIONS.
C       OTHER ARRAYS ARE WRITTEN ACCORDING TO THEIR DIMENSIONS.
C
C     EXTERNALS.
C     ----------
C
C       *ABORT*     - TERMINATES PROCESSING.
C       *ADJUST*    - CORRECTS LONGITUDE INPUT.
C       *AKI*       - COMPUTES WAVE NUMBER.
C       *CHECK*     - CHECKS CONSISTENCY OF BLOCK OVERLAPS.
C       *FINDB*     - FIND BLOCK AND GRID POINT NUMBERS.
C       *JAFU*      - ANGULAR INDEX OF NON LINEAR INTERACTION
C       *LOCINT*    - INTERPOLATE TO BLOCKS.
C       *MBLOCK*    - PREPARES ONE BLOCK
C       *MBOUNC*    - MAKE COARSE GRID BOUNDARY.
C       *MBOUNF*    - MAKE FINE   GRID BOUNDARY.
C       *MBOXB*     - MAKE BOX FOR FINE GRID IN COARSE GRID.
C       *MCOUT*     - PREPARES OUTPUT COMMON COUT
C       *MFREDIR*   - COMPUTES FREQUENCY/DIRECTION COMMON FREDIR
C       *MGRID*     - ARRANGES GRID FOR MODEL.
C       *MINTF*     - MAKE INTERPOLATION TABLES FOR BOUNDARY INPUT.
C       *MTABS*     - COMPUTES TABLES USED FOR SHALLOW WATER
C       *MUBUF*     - COMPUTES COMMON UBUF.
C       *NLWEIGT*   - COMPUTES NON LINEAR WEIGHTS IN COMMON INDNL
C       *OUTCOM*    - OUTPUT OF COMPUTED COMMONS
C       *OUTPP*     - OUTPUT OF GRID.
C       *OUTUBUF*   - OUTPUT OF BLOCK COMMON UBUF
C       *PACKI*     - PACKS AN INTEGER ARRAY.
C       *PACKR*     - PACKS A REAL ARRAY.
C       *READCUR*   - READ A CURRENT FIELD.
C       *STRESS*    - STRESS TABLE.
C       *TAUHF*     - HIGH FREQUENCY STRESS TABLE.
C       *TOPOAR*    - PREPARE TOPOGRAPHY FOR GRID.
C       *UIPREP*    - READS USER INPUT
C       *WAMCUR*    - PREPARE CURRENT FIELD.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C    The DFPORT modul for ABORT funtion in Microsoft FORTRAN 13AUG98 Isaac  
c     USE DFPORT
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C

       INCLUDE 'preprowk.h'
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *NANG*      INTEGER   NUMBER OF ANGLES.
C      *NFRE*      INTEGER   NUMBER OF FREQUENCIES.
C      *NGX*       INTEGER   NUMBER OF LONGITUDES IN GRID.
C      *NGY*       INTEGER   NUMBER OF LATITUDES IN GRID.
C      *NBLO*      INTEGER   NUMBER OF BLOCKS.
C      *NIBLO*     INTEGER   NUMBER OF POINTS IN BLOCK.
C      *NOVER*     INTEGER   MAXIMUM NUUMBER POINTS IN FIRST LATITUDE
C                            OF BLOCKS.
C      *MOUTP*     INTEGER   MAXIMUM NUMBER OF OUTPUT POINTS.
C      *MOUTT*     INTEGER   MAXIMUM NUMBER OF OUTPUT TIMES.
C
C      *NMAXC*     INTEGER   NUMBER OF BOUNDARY OUTPUT POINTS, IF
C                            THIS IS A COARSE GRID; ELSE = 1.
C      *NMAXF*     INTEGER   NUMBER OF BOUNDARY POINTS, IF THIS IS
C                            A FINE GRID RUN; ELSE = 1.
C      *NBINP*     INTEGER   NUMBER OF BOUNDARY INPUT POINTS FROM A
C                            PREVIOUS COARSE GRID RUN, IF THIS IS A
C                            A FINE GRID RUN; ELSE = 1.
C      *NIBL1*     INTEGER   = NIBLO IF MULTI BLOCK VERSION.
C                            =     1 IF ONE BLOCK VERSION.
C      *NIBLD*     INTEGER   = NIBLO IF DEPTH OR CURRENT REFRACTION.
C                            = 1     ELSE.
C      *NBLD*      INTEGER   = NIBO  IF DEPTH OR CURRENT REFRACTION.
C                            = 1     ELSE.
C      *NIBLC*     INTEGER   = NIBLO IF CURRENT REFRACTION.
C                            = 1     ELSE.
C      *NBLC*      INTEGER   = NIBO  IF CURRENT REFRACTION.
C                            = 1     ELSE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS FOR PREPROC ONLY.
C
      PARAMETER (NBMAX = (NGX+NGY)*2-4)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *NBMAX*     INTEGER    MAXIUMUM NUMBER OF BOUNDARY POINTS.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS OF TOPOGRAPHIE DATA.
C
      PARAMETER (JLONI = 1500 , JLATI = 400, IOUTA = 80)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *JLONI*     INTEGER    NUMBER OF LONGITUDES IN TOPAGRAPHIC GRID.
C      *JLATI*     INTEGER    NUMBER OF LATITUDES IN TOPAGRAPHIC GRID.
C      *IOUTA*     INTEGER    NUNBER OF AREAS TO BE SUPPRESSED.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS FOR CURRENT INPUT.
C
      PARAMETER (NCC =  316, NRC =  319)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *NCC*       INTEGER    NUMBER OF LONGITUDES IN CURRENT GRID.
C      *NRC*       INTEGER    NUMBER OF LATITUDES IN CURRENT GRID.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *CPBOUN* USED FOR THE COURSE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /CPBOUN/ IBOUNC, NBOUNC(NESTMAX), 
     1                IJARC(NBMAX), IGARC(NBMAX),
     1                DLAMAC, DPHIAC, AMOSOC(NESTMAX), 
     1                AMONOC(NESTMAX), AMOEAC(NESTMAX), AMOWEC(NESTMAX),
     2                BLATC(NBMAX), BLNGC(NBMAX)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *IBOUNC*    REAL      FLAG FOR THE COURSE GRID
C                            = 1; THE RUN INCLUDEDS BOUNDARY POINTS.
C                            ELSE; NO BOUNDARY POINTS.
C      *NBOUNC*    INTEGER   NUMBER OF BOUNDARY POINTS.
C      *IGARC*     INTEGER   INDEX OF BLOCK FOR A BOUNDARY POINT.
C      *IJCAR*     INTEGER   INDEX IN A BLOCK FOR A BOUNDARY POINT.
C      *DLAMAC*    REAL      LONGITUDE INCREMENT OF COARSE GRID (DEG).
C      *DPHIAC*    REAL      LATITUDE INCREMENT OF COARSE GRID (DEG).
C      *AMOWEC*    REAL      MOST EASTERN LONGITUDE FOR THE FINE GRID.
C      *AMOSOC*    REAL      MOST SOUTHERN LONGITUDE FOR THE FINE GRID.
C      *AMOEAC*    REAL      MOST WESTERN LONGITUDE FOR THE FINE GRID.
C      *AMONOC*    REAL      MOST NORTHERN LONGITUDE FOR THE FINE GRID.
C      *BLATC*     REAL      LATITUDE OF COARSE GRID BOUNDARY POINTS.
C      *BLNGC*     REAL      LONGITUDE OF COARSE GRID BOUNDARY POINTS.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *CINP* USER INPUT: AREAS TO BE CHANGED, AND
C*                    SPECIAL OUTPUT POINTS.
C
      COMMON /CINP/ NOUT, XOUTW(IOUTA), XOUTS(IOUTA), XOUTE(IOUTA),
     1              XOUTN(IOUTA), NOUTD(IOUTA),
     2              OUTLONG(MOUTP), OUTLAT(MOUTP)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *NOUT*      INTEGER   NUMBER OF AREAS TO BE ADJUSTED.
C      *XOUTW*     REAL      WESTERN-MOST LONG OF AREA TO BE CHANGED.
C      *XOUTE*     REAL      EASTERN-MOST LONG OF AREA TO BE CHANGED.
C      *XOUTS*     REAL      SOUTHERN-MOST LAT OF AREA TO BE CHANGED.
C      *XOUTN*     REAL      NORTHERN-MOST LAT OF AREA TO BE CHANGED.
C      *NOUTD*     INTEGER   DEPTH IN AREA IN METRES -999 FOR LAND.
C      *OUTLONG*   REAL      LONGITUDE OF OUTPUT POINTS.
C      *OUTLAT*    REAL      LATITUDE OF  OUTPUT POINTS.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *COUPL* - PARAMETERS FOR COUPLING.
C
      COMMON /COUPL/ BETAMAX, ZALP, ALPHA, XKAPPA, XNLEV
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *BETAMAX*   REAL      PARAMETER FOR WIND INPUT.
C      *ZALP*      REAL      SHIFTS GROWTH CURVE.
C      *ALPHA*     REAL      CHARNOCK CONSTANT.
C      *XKAPPA*    REAL      VON KARMAN CONSTANT.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *COUT*  OUTPUT POINTS INDICES AND FLAGS.
C
      LOGICAL FFLAG(14), FFLAG20, FFLAG21, FFLAG25, FFLAG26,
     1        PFLAG(14), PFLAG20, PFLAG21, PFLAG25, PFLAG26
      COMMON /COUT/ NGOUT, IGAR(MOUTP), IJAR(MOUTP),
     1              NOUTT, IOUTT(MOUTT),
     2              FFLAG, FFLAG20, FFLAG21, FFLAG25, FFLAG26,
     3              PFLAG, PFLAG20, PFLAG21, PFLAG25, PFLAG26
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *NGOUT*     INTEGER   NUMBER OF OUTPUT POINTS.
C      *IGAR*      INTEGER   BLOCK NUMBER OF OUTPUT POINTS.
C      *IJAR*      INTEGER   GRIDPOINT NUMBER OF OUTPUT POINT.
C      *NOUTT*     INTEGER   NUMBER OF OUTPUT TIMES.
C      *IOUTT*     INTEGER   OUTPUT TIMES.
C      *FFLAG*     LOGICAL   FILE  OUTPUT FLAG FOR EACH OUTPUT TYPE.
C      *FFLAG20*   LOGICAL   .TRUE. IF OUTPUT IS WRITTEN TO UNIT IU20.
C      *FFLAG21*   LOGICAL   .TRUE. IF OUTPUT IS WRITTEN TO UNIT IU21.
C      *FFLAG25*   LOGICAL   .TRUE. IF OUTPUT IS WRITTEN TO UNIT IU25.
C      *FFLAG26*   LOGICAL   .TRUE. IF OUTPUT IS WRITTEN TO UNIT IU26.
C      *PFLAG*     LOGICAL   PRINT OUTPUT FLAG FOR EACH OUTPUT TYPE.
C      *PFLAG20*   LOGICAL   .TRUE. IF PRINT OUTPUT OF FIELDS.
C      *PFLAG21*   LOGICAL   .TRUE. IF PRINT OUTPUT OF SWELL FIELDS.
C      *PFLAG25*   LOGICAL   .TRUE. IF PRINT OUTPUT OF SPECTRA.
C      *PFLAG26*   LOGICAL   .TRUE. IF PRINT OUTPUT OF SWELL SPECTRA.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *CURGRD* - INPUT CURRENT GRID SPECFICATIONS.
C
      COMMON /CURGRD/ DUCLO, DUCLA, UCLO, UCLH, UCLW, UCLE,
     1                KRCI, KCCI, IPCUR
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *DUCLO*     REAL      STEPSIZE BETWEEN LONGITUDES IN DEG.
C      *DUCLA*     REAL      STEPSIZE BETWEEN LATITUDES  IN DEG.
C      *UCLO*      REAL      MOST SOUTHERN LATITUDE.
C      *UCLH*      REAL      MOST NORTHERN LATITUDE.
C      *UCLW*      REAL      LEFT MOST LONGITUDE.
C      *UCLE*      REAL      RIGHT MOST LONGITUDE.
C      *KCCI*      INTEGER   NUMBER OF COLUMNES IN WIND INPUT (USED).
C      *KRCI*      INTEGER   NUMBER OF ROWS     IN WIND INPUT (USED).
C      *IPCUR*     INTEGER   INDICATOR PERIODICAL(GLOBAL) GRID OR NOT
C                            0 = NON-PERIODICAL;  1 = PERIODICAL
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *CURRENT* - CURRENT FIELD.
C
      COMMON /CURRENT/ U(0:NIBLC,NBLC), V(0:NIBLC,NBLC)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -----     --------
C      *U*         REAL      U - COMPONENT OF CURRENT (M/S).
C      *V*         REAL      V - COMPONENT OF CURRENT (M/S).
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *FPBOUN* USED FOR THE FINE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /FPBOUN/ IBOUNF, NBOUNF, IJARF(NBMAX), IGARF(NBMAX),
     1                IBFL(NBMAX), IBFR(NBMAX), BFW(NBMAX)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *IBOUNF*    REAL      FLAG FOR THE FINE GRID
C                            = 1; THE RUN INCLUDEDS BOUNDARY POINTS.
C                            ELSE; NO BOUNDARY POINTS.
C      *NBOUNF*    INTEGER   NUMBER OF FINE GRID BOUNDARY POINTS.
C      *IGARF*     INTEGER   BLOCK INDEX FOR A FINE GRID BOUNDARY POINT.
C      *IJARF*     INTEGER   POINT INDEX FOR A FINE GRID BOUNDARY POINT.
C      *IBFL*      INTEGER   INDEX OF LEFT COARSE GRID OUTPUT POINT.
C      *IBFR*      INTEGER   INDEX OF RIGHT COARSE GRID OUTPUT POINT.
C      *BFW*       INTEGER   SPACE INTERPOLATION WEIGHT.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *FREDIR* - FREQUENCY AND DIRECTION GRID.
C
      COMMON /FREDIR/ FR(NFRE), DFIM(NFRE), GOM(NFRE), C(NFRE),
     1                DELTH, DELTR, TH(NANG), COSTH(NANG), SINTH(NANG)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *FR*        REAL      FREQUENCIES IN HERTZ.
C      *DFIM*      REAL      FREQUENCY INTERVAL*DIRECTION INTERVAL.
C      *GOM*       REAL      DEEP WATER GROUP VELOCITIES (M/S).
C      *C*         REAL      DEEP WATER PHASE VELOCITIES (M/S).
C      *DELTH*     REAL      ANGULAR INCREMENT OF SPECTRUM (RADIANS).
C      *DELTR*     REAL      DELTH TIMES RADIUS OF EARTH (METRES).
C      *TH*        REAL      DIRECTIONS IN RADIANS.
C      *COSTH*     REAL      COS OF DIRECTION.
C      *SINTH*     REAL      SIN OF DIRECTION.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *DELPHI*    REAL      GRID INCREMENT FOR LATITUDE (METRES).
C      *DELLAM*    REAL      GRID INCREMENT FOR LONGITUDE AT EQUATOR
C                            IN METRES.
C      *SINPH*     REAL      SIN OF LATITUDE.
C      *COSPH*     REAL      COS OF LATITUDE.
C      *IGL*       INTEGER   NO OF BLOCKS.
C      *IJS*       INTEGER   INDEX OF FIRST POINT OF SECOND LAT.
C      *IJS*       INTEGER   INDEX OF FIRST POINT OF SECOND LAT.
C      *IJL2*      INTEGER   INDEX OF LAST POINT OF SECOND LAT.
C      *IJLS*      INTEGER   INDEX OF FIRST POINT OF LAT BEFORE LAST.
C      *IJL*       INTEGER   INDEX OF LAST POINT OF LAT BEFORE LAST.
C      *IJLT*      INTEGER   TOTAL NUMBER OF GRIDPOINTS IN A BLOCK.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *INDNL* - INDICES AND WEIGHTS USED IN THE COMPUTATION
C                        OF THE NONLINEAR TRANSFER RATE.
C
      COMMON /INDNL/ IKP(NFRE+4), IKP1(NFRE+4),
     1               IKM(NFRE+4), IKM1(NFRE+4),
     2               K1W(NANG,2), K2W(NANG,2), K11W(NANG,2),
     3               K21W(NANG,2), AF11(NFRE+4), FKLAP(NFRE+4),
     4               FKLAP1(NFRE+4), FKLAM(NFRE+4), FKLAM1(NFRE+4),
     5               ACL1, ACL2,  CL11, CL21, DAL1, DAL2, FRH(30)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   -------
C      *IKP*       INTEGER   FREQUENCY INDEX ARRAY FOR STORING ENERGY
C                            TRANSFER INCREMENTS INTO BINS, WAVE NO. 3.
C      *IKP1*      INTEGER   IKP+1.
C      *IKM*       INTEGER   FREQUENCY INDEX ARRAY FOR STORING ENERGY
C                            TRANSFER INCREMENTS INTO BINS, WAVE NO. 4.
C      *IKM1*      INTEGER   IKM+1
C      *K1W*       INTEGER   ANGULAR INDEX ARRAY FOR STORING ENERGY
C                            TRANSFER INCREMENTS INTO BINS, WAVE NO. 3.
C      *K11W*      INTEGER   K1W(.,1)-1, K1W(.,2)+1.
C      *K2W*       INTEGER   ANGULAR INDEX ARRAY FOR STORING ENERGY
C                            TRANSFER INCREMENTS INTO BINS, WAVE NO. 4.
C      *K21W*      INTEGER   K2W(.,1)+1, K2W(.,2)-1.
C      *AF11*      REAL      WEIGHTS FOR DISCRETE APPROXIMATION OF NONL
C                            TRANSFER (AT PRESENT ONE TERM ONLY SET TO
C                            3000). MULTIPLIED BY FREQUENCIES **11.
C      *FKLAP*     REAL      WEIGHT IN FREQUENCY GRID FOR INTERPOLATION,
C                            WAVE NO. 3 ("1+LAMBDA" TERM).
C      *FKLAP1*    REAL      1-FKLAP.
C      *FKLAM*     REAL      WEIGHT IN FREQUENCY GRID FOR INTERPOLATION,
C                            WAVE NO. 4 ("1-LAMBDA" TERM).
C      *ACL1*      REAL      WEIGHT IN ANGULAR GRID FOR INTERPOLATION,
C                            WAVE NO. 3 ("1+LAMBDA" TERM).
C      *ACL2*      REAL      WEIGHT IN ANGULAR GRID FOR INTERPOLATION,
C                            WAVE NO. 4 ("1-LAMBDA" TERM).
C      *CL11*      REAL      1.-ACL1.
C      *CL21*      REAL      1.-ACL2.
C      *DAL1*      REAL      1./ACL1.
C      *DAL2*      REAL      1./ACL2.
C      *FRH*       REAL      TAIL FREQUENCY RATION **5
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *IXLG*      INTEGER   LONG. GRID INDEX.
C      *KXLT*      INTEGER   LAT. GRID INDEX.
C      *NX*        INTEGER   NUMBER OF LONGITUDES IN GRID.
C      *NY*        INTEGER   NUMBER OF LATITUDES  IN GRID.
C      *IPER*      INTEGER   = 1 IF GRID IS PERIODIC.
C      *AMOWEP*    REAL      MOST WESTERN LONGITUDE IN GRID (DEGREE).
C      *AMOSOP*    REAL      MOST SOUTHERN LATITUDE IN GRID (DEGREE).
C      *AMOEAP*    REAL      MOST EASTERN LONGITUDE IN GRID (DEGREE).
C      *AMONOP*    REAL      MOST NORTHERN LATITUDE IN GRID (DEGREE).
C      *XDELLA*    REAL      GRID INCREMENT FOR LATITUDE (DEGREE).
C      *XDELLO*    REAL      GRID INCREMENT FOR LONGITUDE (DEGREE).
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *SHALLOW*   SHALLOW WATER TABLES.
C
      PARAMETER (NDEPTH = 63)
C
      COMMON /SHALLOW/ DEPTH(NIBLO, NBLO), DEPTHA, DEPTHD,
     1                 TCGOND(NDEPTH,NFRE), TFAK(NDEPTH,NFRE),
     2                 TSIHKD(NDEPTH,NFRE), INDEP(NIBLO)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *NDEPTH*    INTEGER   LENGTH OF SHALLOW WATER TABLES.
C      *DEPTH*     REAL      WATER DEPTH IN METRES.
C      *DEPTHA*    REAL      MINIMUM DEPTH FOR TABLES (METRES).
C      *DEPTHD*    REAL      DEPTH INCREMENT (METRES).
C      *TCGOND*    REAL      SHALLOW WATER GROUP VELOCITY TABLE.
C      *TFAK*      REAL      WAVE NUMBER TABLE.
C      *TSIHKD*    REAL      TABLE FOR OMEGA/SINH(2KD).
C      *INDEP*     INTEGER   DEPTH INDEX FOR A BLOCK.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *TABLE* - TABLE FOR TOTAL STRESS AND HIGH FREQ STRESS.
C
      PARAMETER (ITAUMAX=100, JUMAX=100, IUSTAR=100, IALPHA=100)
C
      COMMON /TABLE/ TAUT(0:ITAUMAX,0:JUMAX), DELTAUW, DELU,
     1               TAUHFT(0:IUSTAR,0:IALPHA), DELUST, DELALP
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *ITAUMAX*   INTEGER   TABLE DIMENSION.
C      *JUMAX*     INTEGER   TABLE DIMENSION.
C      *IUSTAR*    INTEGER   TABLE DIMENSION.
C      *IALPHA*    INTEGER   TABLE DIMENSION.
C      *TAUT*      REAL      STRESS TABLE.
C      *DELTAUW*   REAL      WAVE STRESS INCREMENT.
C      *DELU*      REAL      WIND INCREMENT.
C      *TAUHFT*    REAL      HIGH FREQUENCY STRESS TABLE.
C      *DELUST*    REAL      USTAR INCREMENT.
C      *DELALP*    REAL      ALPHA INCREMENT.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *IU06*      INTEGER   UNIT FOR PRINTER OUTPUT.
C      *ITEST*     INTEGER   TEST OUTPUT LEVEL:
C                             .LE. 0  NO OUTPUT
C                             .GE. I  OUTPUT TO SUB. LEVEL I
C      *ITESTB*    INTEGER   MAX BLOCK NUMBER FOR OUTPUT IN BLOCK LOOPS
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *UBUF*  GRID POINT DEPENDENT CONSTANTS
C
      COMMON /UBUF/ KLAT(NIBLO,6), KLON(NIBLO,6)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *KLAT*      REAL      INDEX OF GRIDPOINT SOUTH AND NORTH
C                            LANDPOINTS ARE MARKED BY ZERO.
C      *KLON*      REAL      INDEX OF GRIDPOINT WEST AND EAST
C                            LANDPOINTS ARE MARKED BY ZERO.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER* OF GLOBAL CONSTANTS.
C
      PARAMETER (G = 9.806, PI = 3.14159265358978, CIRC = 40000000.,
     1           ZPI = 2.*PI, RAD = PI/180., DEG = 180./PI,
     2           R = CIRC/ZPI)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *G*         REAL      ACCELLERATION OF GRAVITY.
C      *PI*        REAL      PI.
C      *CIRC*      REAL      EARTH CIRCUMFERENCE (METRES).
C      *RAD*       REAL      PI / 180.
C      *DEG*       REAL      180. / PI.
C      *ZPI*       REAL      2. * PI.
C      *R*         REAL      EARTH RADIUS        (METRES).
C
C ----------------------------------------------------------------------
C
      DIMENSION IA1(NGX, NGY)
C
C          *IA1*   INTEGER  TOPOGRAPHIC DATA IN MODEL GRID.
C
C ----------------------------------------------------------------------
C
C*    1. INITIALISATION OF INPUT/OUTPUT UNITS.
C        -------------------------------------
C
      IU01  = 1
      IU02  = 2
      IU03  = 3
      IU05  = 95
      IU06  = 6
      IU07  = 7
      IU08  = 8
      IU09  = 9
      IU10  = 10
      IU17  = 17
      IU18  = 18
      IU19  = 19
      IU20  = 20
C ---------------------------------------------------------------------
C*    1.1 OPEN INPUT FILES  1
C         ----------------------------------
      CALL OP_FILES1 (IU01, IU02, IU05, IU06)
C
C*    2. USER INPUT AND LINEPRINTER PROTOCOL.
C        ------------------------------------
C
2000  CONTINUE
      CALL UIPREP (IU05, IFORM, IREFRA, ML, KL)
C
C*    2.1 OPEN INPUT FILES  2
C         ----------------------
      CALL OP_FILES2 (IU03, IU06, IU07, IU08, IU09
     1                    , IU10, IU16, IU17, IU18, IU19, IU20
     2                    ,IBOUNC,IBOUNF, IFORM)
C
C ----------------------------------------------------------------------
C
C*    3. INITIALISE TOTAL NUMBER OF BLOCKS,
C*       AND GRID INCREMENTS IN RADIENS AND METRES.
C        ------------------------------------------
C
 3000 CONTINUE
      IGL=0
      DELPHI =  XDELLA*CIRC/360.
      DELLAM =  XDELLO*CIRC/360.
      DO 3001 K=1,NY
	 XLAT = (AMOSOP + REAL(K-1)*XDELLA)*RAD
	 SINPH(K) = SIN(XLAT)
	 COSPH(K) = COS(XLAT)
 3001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    4. COMPUTE GRID INDEPENDENT COMMON BLOCKS.
C        ---------------------------------------
C
 4000 CONTINUE
C
C*    4.1 COMMON FREDIR (FREQUENCY/DIRECTION CONST).
C         ------------------------------------------
C
 4100 CONTINUE
      CALL MFREDIR (ML, KL)
C
C*    4.2 COMMON INDNL (WEIGHT OF NON-LINEAR INTERACTION).
C         ------------------------------------------------
C
 4200 CONTINUE
      CALL NLWEIGT (ML, KL)
C
C*    4.3 COMMON SHALLOW (SHALLOW WATER TABLES).
C         --------------------------------------
C
      CALL MTABS (ML, KL)
C
C*    4.4 COMMON COUPLE.
C         --------------
C
      BETAMAX = 1.20
      ZALP    = 0.0110
      ALPHA   = 0.0100
      XKAPPA  = 0.41
      XNLEV   = 10.0
C
C*    4.4 COMMON TABLE (STRESS TABLES).
C         -----------------------------
C
      CALL STRESS
      CALL TAUHF (FR(ML))
C
C ----------------------------------------------------------------------
C
C*    5. GENERATE OUTPUT GRID INFORMATION.
C        ---------------------------------
C
 5000 CONTINUE
C
C*    5.1 READ IN TOPOGRAPHY AND ARRANGE ON REQUESTED MODEL AREA OF
C*        REQUESTED RESOLUTION.
C         ---------------------------------------------------------
C
 5100 CONTINUE
      CALL TOPOAR (IU01, IA1)
C
C*    5.2 COMPUTATION OF BLOCKS.
C         ----------------------
C
 5200 CONTINUE
      CALL MGRID (IA1)
      IF (ITEST.GT.0) WRITE (IU06,*) ' SUB MGRID DONE'
C
C*    5.3 COMPUTE OUTPUT POINT INDICES (COMMON COUT).
C         -------------------------------------------
C
 5300 CONTINUE
      CALL MCOUT
      IF (ITEST.GT.0) WRITE (IU06,*) ' SUB MCOUT DONE'
C
C ----------------------------------------------------------------------
C
C*    6. COMPUTE NEST INFORMATION.
C        -------------------------
C
 6000 CONTINUE
C
C*    6.1 COMPUTE FINE GRID NEST INFORMATION (COMMON FBOUND).
C         ---------------------------------------------------
C
 6100 CONTINUE
      IF (IBOUNF.EQ.1) THEN
	 CALL MBOUNF (IU03, IU10, IU20, IFORM, IINPC)
	 IF (ITEST.GT.0) WRITE (IU06,*) ' SUB MBOUNF DONE'
      ELSE
	 IINPC  = 0
	 NBOUNF = 0
      ENDIF
C
C*    6.2 COMPUTE COARSE GRID NEST INFORMATION (COMMON CBOUND).
C         -----------------------------------------------------
C
 6200 CONTINUE
      IF (IBOUNC.EQ.1) THEN
	 CALL MBOUNC (IU09, IU19, IFORM)
	 IF (ITEST.GT.0) WRITE (IU06,*) ' SUB MBOUNC DONE'
      ELSE
         DO NEST = 1,NESTS
	 NBOUNC(NEST) = 0
         END DO
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    7. GENERATE CURRENT FIELD.
C        -----------------------
C
 7000 CONTINUE
      IF (IREFRA.EQ.2) THEN
	 CALL WAMCUR (IU02)
	 IF (ITEST.GT.0) WRITE (IU06,*) ' SUB WAMCUR DONE'
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    8. GENERATE AND WRITE COMMON UBUF.
C        -------------------------------
C
 8000 CONTINUE
      DO 8001 IG=1,IGL
	 CALL MUBUF (IA1, IG, IU08, IU18, IFORM)
	 IF (ITEST.GT.0) THEN
	    IF (IG.LE.ITESTB) WRITE (IU06,*)
     1        ' SUB MUBUF DONE FOR BLOCK ',IG
	 ENDIF
 8001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    9. OUTPUT OF COMMON BLOCKS.
C        ------------------------
C
 9000 CONTINUE
      CALL OUTCOM (IU07, IU17, IFORM, IREFRA, ML, KL)
      IF (ITEST.GT.0) WRITE (IU06,*) ' SUB OUTCOM DONE'
C
C ----------------------------------------------------------------------
C
C*    10. CONSISTENCY CHECK OF COMPUTED BLOCK PARAMETERS AND
C*        OUTPUT OF NECESSARY DIMENSIONS.
C         --------------------------------------------------
C
 9100 CONTINUE
      CALL CHECK (IREFRA, ML, KL, IINPC)

      STOP
      END
C ----------------------------------------------------------------------
C ###END MAIN###  ###END MAIN###  ###END MAIN###
C ----------------------------------------------------------------------
      SUBROUTINE READCUR (IU02, IDTCR, UCUR, VCUR, NCC, NRC)

C ----------------------------------------------------------------------
C
C**** *READCUR* - ROUTINE TO READ A CURRENT FIELD.
C
C     SUSANNE HASSELMANN        JUNE     1990.
C     H. GUNTHER    ECMWF/GKSS  DECEMBER 1990  MODIFIED FOR CYCLE_4.
C
C*    PURPOSE.
C     --------
C       INPUT OF A CURRENT FIELD.
C
C**   INTERFACE.
C     ----------
C       *CALL* *READCUR (IU02, IDTCR, UCUR, VCUR, NCC, NRC)*
C          *IU02*   - INPUT UNIT FOR CURRENTS.
C          *IDTCR*  - DATE/TIME OF THE DATA READ.
C          *UCUR*   - HORIZONTAL CURRENT COMPONENT.
C          *VCUR*   - VERTICAL CURRENT COMPONENT.
C          *NCC*    - NUMBER OF COLUMNS IN INPUT ARRAYS (DIMENSION).
C          *NRC*    - NUMBER OF ROWS    IN INPUT ARRAYS (DIMENSION).
C
C     METHOD.
C     -------
C
C       FORMATED READ; CURRENT GRID IS LAT / LONG GRID.
C
C     EXTERNALS.
C     ----------
C
C       *ABORT*     - TERMINATES PROCESSING.
C       *ADJUST*    - CORRECTS LONGITUDE INPUT.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *CURGRD* - INPUT CURRENT GRID SPECFICATIONS.
C
      COMMON /CURGRD/ DUCLO, DUCLA, UCLO, UCLH, UCLW, UCLE,
     1                KRCI, KCCI, IPCUR
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
      DIMENSION UCUR(NCC,NRC), VCUR(NCC,NRC)
C
C ----------------------------------------------------------------------
C
C*    1. READ CURRENT FILE HEADER.
C        -------------------------
C
 1000 CONTINUE

C
      READ (IU02, '(6F10.5,1x,I3,1x,I3)',END=3001,ERR=3001)
     1    UCLO, UCLH, UCLW, UCLE, DUCLO, DUCLA, KRCI, KCCI
      IF (ITEST.GT.0) THEN
	 WRITE (IU06,*) '  '
	 WRITE (IU06,*) ' SUB. READCUR: FILE HEADER READ'
	 WRITE (IU06,*) ' GRID SPECIFICATION ARE:'
	 WRITE (IU06,*) ' NUMBER OF COLUMNS IN GRID KCCI = ', KCCI
	 WRITE (IU06,*) ' NUMBER OF ROWS    IN GRID KRCI = ', KRCI
         WRITE (IU06,*) ' SOUTHERN MOST LATITUDE    UCLO = ', UCLO
         WRITE (IU06,*) ' NORTHERN MOST LATITUDE    UCLH = ', UCLH
         WRITE (IU06,*) ' WESTERN MOST LONGITUDE    UCLW = ', UCLW
         WRITE (IU06,*) ' EASTERN MOST LONGITUDE    UCLE = ', UCLE
         WRITE (IU06,*) ' LATITUDE  STEP IS        DUCLA = ', DUCLA
         WRITE (IU06,*) ' LONGITUDE STEP IS        DUCLO = ', DUCLO
      ENDIF
C
C*    1.2  CHECK DIMENSIONS
C     ----------------------
C
      IF (KCCI.GT.NCC .OR. KRCI.GT.NRC) THEN
         WRITE (IU06,*) ' *****************************************'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *       FATAL ERROR IN SUB. READCUR     *'
         WRITE (IU06,*) ' *       ===========================     *'
         WRITE (IU06,*) ' * DIMENSION OF INPUT ARRAYS ARE TO SMALL*'
         WRITE (IU06,*) ' * DIMENSION OF COLUMNS IS  NCC = ', NCC
         WRITE (IU06,*) ' * DIMENSION REQUESTED  IS KCCI = ', KCCI
         WRITE (IU06,*) ' * DIMENSION OF ROWS    IS  NRC = ', NRC
         WRITE (IU06,*) ' * DIMENSION REQUESTED  IS KRCI = ', KRCI
         WRITE (IU06,*) ' * CHANGE PARAMETER STATEMENT            *'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *   PROGRAM ABORTS  PROGRAM ABORTS      *'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *****************************************'
	 CALL ABORT
      ENDIF
      IF (KRCI.LT.2 .OR. KCCI.LT.2) THEN
         WRITE (IU06,*) ' *****************************************'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *     FATAL ERROR IN SUB. READCUR       *'
         WRITE (IU06,*) ' *     ===========================       *'
         WRITE (IU06,*) ' * LESS THAN 2 LATITUDES OR LONGITUDES   *'
         WRITE (IU06,*) ' * IN CURRENT INPUT.                     *'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *   PROGRAM ABORTS  PROGRAM ABORTS      *'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *****************************************'
         CALL ABORT
      ENDIF

      CALL ADJUST (UCLW, UCLE)
      IPCUR=0
      IF (AMODA(UCLE+DUCLO-UCLW+720.,360.).LT.0.0000001) IPCUR=1
C
C ----------------------------------------------------------------------
C
C*    2. READ CURRENT FIELD.
C        -------------------
C
 2000 CONTINUE
      IDTCR = 0
      DO 2001 J=1,KRCI
         READ(IU02,'(8E9.3)',END=3002,ERR=3002) (UCUR(I,J),I=1,KCCI)
 2001 CONTINUE

      DO 2002 J=1,KRCI
         READ(IU02,'(8E9.3)',END=3003,ERR=3003) (VCUR(I,J),I=1,KCCI)
 2002 CONTINUE
C
      RETURN
C
C ----------------------------------------------------------------------
C
C*    3. ERROR HANDLING.
C        ---------------
C
 3001 CONTINUE
         WRITE (IU06,*) ' *****************************************'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *      FATAL ERROR IN SUB. READCUR      *'
         WRITE (IU06,*) ' *      ===========================      *'
         WRITE (IU06,*) ' * READ ERROR OR EOF ON CURRENT FILE.    *'
         WRITE (IU06,*) ' * FILE HEADER EXPECTED                  *'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *   PROGRAM ABORTS  PROGRAM ABORTS      *'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *****************************************'
         CALL ABORT
 3002 CONTINUE
         WRITE (IU06,*) ' *****************************************'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *      FATAL ERROR IN SUB. READCUR      *'
         WRITE (IU06,*) ' *      ===========================      *'
         WRITE (IU06,*) ' * READ ERROR OR EOF ON CURRENT FILE.    *'
	 WRITE (IU06,*) ' * U - COMPONETS EXPECTED                *'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *   PROGRAM ABORTS  PROGRAM ABORTS      *'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *****************************************'
         CALL ABORT
 3003 CONTINUE
         WRITE (IU06,*) ' *****************************************'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *      FATAL ERROR IN SUB. READCUR      *'
         WRITE (IU06,*) ' *      ===========================      *'
         WRITE (IU06,*) ' * READ ERROR OR EOF ON CURRENT FILE.    *'
         WRITE (IU06,*) ' * V - COMPONETS EXPECTED                *'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *   PROGRAM ABORTS  PROGRAM ABORTS      *'
         WRITE (IU06,*) ' *                                       *'
         WRITE (IU06,*) ' *****************************************'
         CALL ABORT

      END
      SUBROUTINE STRESS

C ----------------------------------------------------------------------
C
C**** *STRESS* - COMPUTATION OF TOTAL STRESS.
C
C     P.A.E.M. JANSSEN    KNMI      AUGUST    1990
C
C*    PURPOSE.
C     ---------
C
C       TO GENERATE STRESS TABLE TAU(TAUW,U10).
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *STRESS*
C
C     METHOD.
C     -------
C
C       A STEADY STATE WIND PROFILE IS ASSUMED.
C       THE WIND STRESS IS COMPUTED USING THE ROUGHNESSLENGTH
C
C                  Z1=Z0/SQRT(1-TAUW/TAU)
C
C       WHERE Z0 IS THE CHARNOCK RELATION , TAUW IS THE WAVE-
C       INDUCED STRESS AND TAU IS THE TOTAL STRESS.
C       WE SEARCH FOR STEADY-STATE SOLUTIONS FOR WHICH TAUW/TAU < 1.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990.
C
C ----------------------------------------------------------------------
C
C*    *COMMON* *COUPL* - PARAMETERS FOR COUPLING.
C
      COMMON /COUPL/ BETAMAX, ZALP, ALPHA, XKAPPA, XNLEV
C
C*    *COMMON* *TABLE* - TABLE FOR TOTAL STRESS AND HIGH FREQ STRESS.
C
      PARAMETER (ITAUMAX=100, JUMAX=100, IUSTAR=100, IALPHA=100)
C
      COMMON /TABLE/ TAUT(0:ITAUMAX,0:JUMAX), DELTAUW, DELU,
     1               TAUHFT(0:IUSTAR,0:IALPHA), DELUST, DELALP
C
C ----------------------------------------------------------------------
C
      PARAMETER (XM=0.50, XNU=0.00001, G=9.806, NITER=10, EPS1=0.00001)
C
C*     VARIABLE.   TYPE.     PURPOSE.
C      ---------   -------   --------
C      *XM*        REAL      POWER OF TAUW/TAU IN ROUGHNESS LENGTH.
C      *XNU*       REAL      KINEMATIC VISCOSITY OF AIR.
C      *G*         REAL      ACCELERATION OF GRAVITY.
C      *NITER*     INTEGER   NUMBER OF ITERATIONS TO OBTAIN TOTAL STRESS
C      *EPS1*      REAL      SMALL NUMBER TO MAKE SURE THAT A SOLUTION
C                            IS OBTAINED IN ITERATION WITH TAU>TAUW.
C
C ----------------------------------------------------------------------
C
C*    1.DETERMINE TOTAL STRESS.
C       -----------------------
C
C*    1.1 INITIALISE CONSTANTS.
C         ---------------------
C
      UMAX    = 50.
      TAUWMAX = 5.
      DELU    = UMAX/FLOAT(JUMAX)
      DELTAUW = TAUWMAX/FLOAT(ITAUMAX)
C
C*    1.2 DETERMINE STRESS.
C         -----------------
C
      DO 1000 I=0,ITAUMAX
         DO 1100 J=0,JUMAX
            ZTAUW   = FLOAT(I)*DELTAUW
            UTOP    = FLOAT(J)*DELU
            CDRAG   = 0.0012875
            WCD     = SQRT(CDRAG)
            USTOLD  = UTOP*WCD
            TAUOLD  = MAX(USTOLD**2, ZTAUW+EPS1)
C
            DO 1200 ITER=1,NITER
               X      = ZTAUW/TAUOLD
               UST    = SQRT(TAUOLD)
C              Z0     = ALPHA*UST**2/(G)/(1.-X)**XM
C              ZNU    = 0.1*XNU/UST
C              Z0     = MAX(ZNU,Z0)
              Z0     = ALPHA*TAUOLD/(G)/(1.-X)**XM

               F      = UST-XKAPPA*UTOP/(ALOG(XNLEV/Z0))
               DELF   = 1.-XKAPPA*UTOP/(ALOG(XNLEV/Z0))**2*2./UST*
     *                  (1.-(XM+1)*X)/(1.-X)
	       UST    = UST-F/DELF
               TAUOLD =  MAX(UST**2., ZTAUW+EPS1)
 1200       CONTINUE
            TAUT(I,J)  = TAUOLD
 1100    CONTINUE
C
C*    END DO LOOP OVER INDICES OF TAU-TABLE
C
 1000 CONTINUE

      RETURN
      END
      SUBROUTINE TAUHF (FRMAX)

C ----------------------------------------------------------------------
C
C**** *TAUHF* - COMPUTATION OF HIGH-FREQUENCY STRESS.
C
C     PETER A.E.M. JANSSEN    KNMI      OCTOBER 90
C
C*    PURPOSE.
C     ---------
C
C       COMPUTE HIGH-FREQUENCY WAVE STRESS
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *TAUHF (FRMAX)*
C          *FRMAX - LAST MODEL FREQUENCY FR(ML).
C
C     METHOD.
C     -------
C
C       SEE REFERENCE FOR WAVE STRESS CALCULATION.
C
C     EXTERNALS.
C     ----------
C
C       NONE.
C
C     REFERENCE.
C     ----------
C
C       FOR QUASILINEAR EFFECT SEE PETER A.E.M. JANSSEN,1990.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C

       INCLUDE 'preprowk.h'
C
C*    *COMMON* *COUPL* - PARAMETERS FOR COUPLING.
C
      COMMON /COUPL/ BETAMAX, ZALP, ALPHA, XKAPPA, XNLEV
C
C*    *COMMON* *TABLE* - TABLE FOR TOTAL STRESS AND HIGH FREQ STRESS.
C
      PARAMETER (ITAUMAX=100, JUMAX=100, IUSTAR=100, IALPHA=100)
C
      COMMON /TABLE/ TAUT(0:ITAUMAX,0:JUMAX), DELTAUW, DELU,
     1               TAUHFT(0:IUSTAR,0:IALPHA), DELUST, DELALP
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER* OF GLOBAL CONSTANTS.
C
      PARAMETER (G = 9.806, PI = 3.14159265358978, CIRC = 40000000.,
     1           ZPI = 2.*PI, RAD = PI/180., DEG = 180./PI,
     2           R = CIRC/ZPI)
C
      PARAMETER (JTOT = 50)
C
C ----------------------------------------------------------------------
C
C*    1. PRELIMINARY CALCULATIONS.
C        -------------------------
C
       USTARM = 5.
       ALPHAM = 10.*ALPHA
       DELUST = USTARM/FLOAT(IUSTAR)
       DELALP = ALPHAM/FLOAT(IALPHA)
C
       CONST1 = BETAMAX/XKAPPA**2
       OMEGAC = ZPI*FRMAX
C
       DO 1100 L=0,IALPHA
          DO 1200 K=0,IUSTAR
             TAUHFT(K,L) = 0.
 1200     CONTINUE
 1100 CONTINUE
C
C*    2. CALCULATE HIGH-FREQUENCY CONTRIBUTION TO STRESS.
C        ------------------------------------------------
C
      X0 = 0.05
      DO 2100 L=0,IALPHA
         DO 2200 K=0,IUSTAR
            UST      = MAX(FLOAT(K)*DELUST,0.000001)
            Z0       = UST**2*(ALPHA+FLOAT(L)*DELALP)/G
            OMEGACC  = MAX(OMEGAC,X0*G/UST)
            YC       = OMEGACC*SQRT(Z0/G)
            DELY     = MAX((1.-YC)/FLOAT(JTOT),0.)
            DO 2300 J=1,JTOT
               Y        = YC+FLOAT(J-1)*DELY
               OMEGA    = Y*SQRT(G/Z0)
               CM       = G/OMEGA
               ZX       = UST/CM +ZALP
               ZARG     = MIN(XKAPPA/ZX,20.)
               ZMU      = MIN(G*Z0/CM**2*EXP(ZARG),1.)
C
               ZLOG         = MIN(ALOG(ZMU),0.)
               ZBETA        = CONST1*ZMU*ZLOG**4
               TAUHFT(K,L)  = TAUHFT(K,L)+ZBETA/Y*DELY
 2300       CONTINUE
 2200    CONTINUE
 2100 CONTINUE

      RETURN
      END
      SUBROUTINE TOPOAR (IU01, IA2)

C ----------------------------------------------------------------------
C
C**** *TOPOAR* - ARRANGE SUBGRID TOPOGRAPHY.
C
C     S. HASSELMANN     MPIFM           1/6/86.
C
C     MODIFIED BY       H. GUNTHER      1/4/90  -  REARANGEMENT OF CODE.
C
C*    PURPOSE.
C     --------
C
C       TO READ IN TOPOGRAPHY ON INPUT GRID AND CONVERT TO OUTPUT GRID.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *TOPOAR (IU01, IA2)*
C          *IU01*  -  LOGICAL INPUT UNIT OF TOPOGRAPHIC DATA.
C          *IA2*   -  TOPOGRAPHIC DATA IN OUTPUT GRID.
C
C     METHOD.
C     -------
C
C       THE TOPOGRAPHY MUST BE ON A REGULAR LATITUDE-LONGITUDE
C       GRID ARRANGED FROM SOUTH TO NORTH, AND FROM WEST TO EAST.
C       IT IS ASSUMED THAT NEGATIVE VALUES ARE SEA DEPTHS (WHICH
C       ARE CONVERTED TO POSITIVE) AND THAT POSITIVE VALUES ARE
C       LAND ELEVATIONS (WHICH ARE CONVERTED TO -999 IDENTIFIERS).
C
C       THE TOPOGRAPHIC DATA IS READ IN ON THE INPUT GRID AND IT
C       IS STORED ONLY FOR THOSE LATITUDES WITHIN THE REQUESTED
C       GRID. THEN THE TOPOGRAPHIC DATA IS FURTHER RESTRICTED
C       TO LIE WITHIN THE SUBGRID LONGITUDES. IT IS THEN PUT ON
C       THE REQUESTED SUBGRID LAT-LONG RESOLUTION, ALWAYS USING
C       THE NEAREST POINT.
C       FINALLY THE SUBGRID TOPOGRAPHY MAY BE MANUALLY ADJUSTED BY
C       MEANS OF THE CARD INPUT AND A PRINTER OUTPUT IS DONE.
C
C     EXTERNALS.
C     ----------
C
C       *ABORT*     - TERMINATES PROCESSING.
C       *ADJUST*    - CORRECTS LONGITUDE INPUT.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C
       INCLUDE 'preprowk.h'
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS OF TOPOGRAPHIE DATA.
C
      PARAMETER (JLONI = 1500 , JLATI = 400, IOUTA = 80)
C
C*    *COMMON* *CINP* USER INPUT: AREAS TO BE CHANGED, AND
C*                    SPECIAL OUTPUT POINTS.
C
      COMMON /CINP/ NOUT, XOUTW(IOUTA), XOUTS(IOUTA), XOUTE(IOUTA),
     1              XOUTN(IOUTA), NOUTD(IOUTA),
     2              OUTLONG(MOUTP), OUTLAT(MOUTP)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
      DIMENSION IA2(NGX, NGY)
      CHARACTER*1 AX(JLONI), AXX(NGX)
      DIMENSION IA2H(JLONI), IA1(JLONI,JLATI)
C
C ----------------------------------------------------------------------
C
C*    1. READING THE TOPOGRAPHY OF THE INPUT GRID AND STORING THOSE
C*       LATITUDES WITHIN THE OUTPUT SUBGRID AREA.
C        -----------------------------------------
C
C       MLON - NUMBER OF TOPOGRAPHIC POINTS PER GRID LATITUDE.
C       KMAX - NUMBER OF RECORDS OF INPUT GRID PER LATITUDE.
C       XLAT - LATITUDE OF CURRENT GRID DATA.
C       NLAT - NUMBER OF GRID LATITUDES STORED.
C       XLAG - LATITUDE OF FIRST GRID LATITUDE STORED.
C
 1000 CONTINUE
      REWIND (UNIT=IU01)
      READ (IU01,'(8F10.5)') XDELA, XDELO, XLAS, XLAN, XLOW, XLOE
      CALL ADJUST (XLOW, XLOE)

      XDELA = XDELLA
      XDELO = XDELLO
      WRITE (IU06,'(1H1,'' INPUT GRID''/)')
      WRITE (IU06,'(3X,''RESOLUTION LAT-LON '',2F8.3)') XDELA, XDELO
      WRITE (IU06,'(3X,'' SOUTHERN LAT '','' NORTHERN LAT '',
     1                 '' WESTERN LONG '','' EASTERN LONG'',
     2                 /,2X,4F14.3)') XLAS, XLAN, XLOW, XLOE

      MLON = NINT((XLOE-XLOW)/XDELO+1.0)
      IF(MLON.GT.JLONI) THEN
         WRITE (IU06,*) ' *********************************************'
         WRITE (IU06,*) ' *                                           *'
         WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. TOPOAR          *'
         WRITE (IU06,*) ' *      ===========================          *'
         WRITE (IU06,*) ' *                                           *'
         WRITE (IU06,*) ' * NUMBER OF LONGITUDES IN INPUT GRID EXCEEDS*'
         WRITE (IU06,*) ' * DIMENSION                                 *'
         WRITE (IU06,*) ' * DIMENSION IS        JLONI = ', JLONI
         WRITE (IU06,*) ' * NUMBER FROM INPUT IS MLON = ', MLON
         WRITE (IU06,*) ' *                                           *'
         WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                   *'
         WRITE (IU06,*) ' *********************************************'
         CALL ABORT
      ENDIF
      KMAX=(MLON+11)/12
C
      XLAT=XLAS-XDELA
      NLAT=0
1005  CONTINUE
         NLAT=NLAT+1
         IF (NLAT.GT.JLATI) THEN
            WRITE (IU06,*) ' ******************************************'
            WRITE (IU06,*) ' *                                        *'
            WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. TOPOAR       *'
            WRITE (IU06,*) ' *      ===========================       *'
            WRITE (IU06,*) ' *                                        *'
            WRITE (IU06,*) ' * NUMBER OF LATITUDES IN INPUT GRID      *'
            WRITE (IU06,*) ' * EXCEEDS DIMENSION                      *'
            WRITE (IU06,*) ' * DIMENSION IS           JLATI = ', JLATI
            WRITE (IU06,*) ' * LAST LATITUDE READ IS  XLAT  = ', XLAT
            WRITE (IU06,*) ' *                                        *'
            WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                *'
            WRITE (IU06,*) ' ******************************************'
            CALL ABORT
         ENDIF
1010     CONTINUE
            XLAT=XLAT+XDELA
            DO 1015 K=1,KMAX
               N1 = 12*(K-1)+1
               N2 = MIN(12*K,MLON)
               READ (IU01, '(12(I5,A1))', END=1017)
     1              (IA1(IAA,NLAT),AX(IAA),IAA=N1,N2)
 1015       CONTINUE
C
         IF (XLAT+0.5*XDELA.LE.AMOSOP) GO TO 1010
         IF(NLAT.EQ.1) XLAGC=XLAT
         DO 1016 I=1,MLON
             IF (AX(I).EQ.'E'.AND.IA1(I,NLAT).LT.0)
     1                        IA1(I,NLAT)=-IA1(I,NLAT)
             IF (AX(I).EQ.'D'.AND.IA1(I,NLAT).GT.0)
     1                        IA1(I,NLAT)=-IA1(I,NLAT)
             IF (AX(I).EQ.'E'.AND.IA1(I,NLAT).EQ.0) IA1(I,NLAT)=1
             IF (AX(I).EQ.'D'.AND.IA1(I,NLAT).EQ.0) IA1(I,NLAT)=-1
 1016    CONTINUE
         IF(XLAT+0.5*XDELA.GT.AMONOP) GO TO 1020
      GO TO 1005
1017  CONTINUE
         NLAT=NLAT-1
         WRITE (IU06,*) ' +++++++++++++++++++++++++++++++++++++++++++++'
         WRITE (IU06,*) ' +                                           +'
         WRITE (IU06,*) ' +     WARNING ERROR IN SUB. TOPOAR          +'
         WRITE (IU06,*) ' +     ============================          +'
         WRITE (IU06,*) ' +                                           +'
         WRITE (IU06,*) ' + END OF FILE ON INPUT GRID  UNIT :', IU01
         WRITE (IU06,*) ' + NORTH GRID BOUNDARY CHANGED TO XLAT = ',XLAT
         WRITE (IU06,*) ' +                                           +'
         WRITE (IU06,*) ' +++++++++++++++++++++++++++++++++++++++++++++'
1020  CONTINUE
C
C ----------------------------------------------------------------------
C
C*    2. STORING TOPOGRAPHIC DATA AT LONGITUDES WITHIN SUBGRID AREA.
C        ----------------------------------------------------------
C
C       ILW      -  INDEX OF NEAREST GRID LONGITUDE EQUIVALENT TO
C                     WESTERN SUBGRID BOUNDARY.
C       NLON     -  NUMBER OF GRID LONGITUDES WITHIN SUBGRID AREA.
C       IH,IH1   -  GRID LONGITUDE NUMBER.
C
 2000 CONTINUE

      XLW= AMODA(AMOWEP-XLOW+720.,360.)
      ILW= NINT(XLW/XDELO-0.0001)
      NLON=NINT((AMOEAP-AMOWEP)/XDELO+1.0)
      DO 2030 J=1,NLAT
         IH=ILW
         DO 2010 I=1,NLON
            IH=IH+1
            IF(IH.LE.0) IH=IH+MLON
            IF(IH.GT.MLON) IH=IH-MLON
            IA2H(I) =IA1(IH,J)
 2010    CONTINUE
         DO 2020 I=1,NLON
            IA1(I,J)=IA2H(I)
 2020    CONTINUE
 2030 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    3. PUT ON XDELLO BY XDELLA SUBGRID.
C        --------------------------------
C
C     XLA  - LATITUDE OF OUTPUT GRID.
C     XLAG - LATITUDE OF INPUT GRID.
C     XLO  - LONGITUDE OF OUTPUT GRID.
C     XLOG - LONGITUDE OF INPUT GRID.
C
 3000 CONTINUE
      XLA=AMOSOP
      NJ=0

C  LOOP THROUGH LATITUDES

      DO 3070 J=1,NLAT
        XLAG=XLAGC + REAL(J-1)*XDELA
 3010   CONTINUE
        IF(XLA.LT.XLAG-0.5*XDELA.OR.XLA.GE.XLAG+0.5*XDELA) THEN
         GO TO 3070
        END IF
        NJ=NJ+1
        IF(NJ.GT.NGY) THEN
            WRITE (IU06,*) ' ******************************************'
            WRITE (IU06,*) ' *                                        *'
            WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. TOPOAR       *'
            WRITE (IU06,*) ' *      ===========================       *'
            WRITE (IU06,*) ' *                                        *'
            WRITE (IU06,*) ' * NUMBER OF LATITUDES IN OUTPUT GRID     *'
            WRITE (IU06,*) ' * EXCEEDS DIMENSION.                     *'
            WRITE (IU06,*) ' * DIMENSION IS            NGY = ', NGY
            WRITE (IU06,*) ' * LAST LATITUDE USED IS   XLA = ', XLA
            WRITE (IU06,*) ' *                                        *'
            WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED                *'
            WRITE (IU06,*) ' ******************************************'
            CALL ABORT
         ENDIF

C  LOOP THROUGH LONGITUDES

        NL=0
        XLOH = XLOW + (REAL(ILW)-1.5000)*XDELO+720.
        XLO=AMOWEP
        IF(XLO .LT.0.) XLO =XLO +360.
        DO 3060 I=1,NLON
          XLO = AMODA(XLO+720.,360.)
          XLOG = AMODA(XLOH + REAL(I)*XDELO,360.)
 3030     CONTINUE
          IF (XLO.LE.XLOG) XLO  = XLO  + 360.
          IF (XLO.LE.XLOG+XDELO) THEN
             NL=NL+1
             IF (NL.GT.NGX) THEN
                WRITE (IU06,*) ' **************************************'
                WRITE (IU06,*) ' *                                    *'
                WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. TOPOAR   *'
                WRITE (IU06,*) ' *      ===========================   *'
                WRITE (IU06,*) ' *                                    *'
                WRITE (IU06,*) ' * NUMBER OF LONG. IN OUTPUT GRID     *'
                WRITE (IU06,*) ' * EXCEEDS DIMENSION.                 *'
                WRITE (IU06,*) ' * DIMENSION IS            NGX = ', NGX
                WRITE (IU06,*) ' * LAST LONGITUDE READ IS  XLO = ', XLO
                WRITE (IU06,*) ' *                                    *'
                WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED            *'
                WRITE (IU06,*) ' **************************************'
                CALL ABORT
             ENDIF
             IA2(NL,NJ)=IA1(I,J)
             XLO = AMOWEP + REAL(NL)*XDELLO
             IF (XLO.LE.AMOEAP) THEN
                XLO = AMODA(XLO+720.,360.)
                GOTO 3030
             ENDIF
          ENDIF
 3060   CONTINUE
        XLA=AMOSOP + REAL(NJ)*XDELLA
        IF(XLA.GT.AMONOP+1.E-5) THEN
          GOTO 3080
        ELSE
          GOTO 3010
        ENDIF
 3070 CONTINUE
 3080 CONTINUE
      IF (NJ.NE.NY .OR. NL.NE.NX) THEN
          PRINT *,XLA,AMOSOP,NJ,XDELLA,AMONOP

          WRITE (IU06,*) ' *****************************************'
          WRITE (IU06,*) ' *                                       *'
          WRITE (IU06,*) ' *      FATAL  ERROR IN SUB. TOPOAR      *'
          WRITE (IU06,*) ' *      ===========================      *'
          WRITE (IU06,*) ' *                                       *'
          WRITE (IU06,*) ' * NUMBER OF LONGITUDES OR LATITUDES IN  *'
          WRITE (IU06,*) ' * IS NOT EQUAL TO EXPECTED NUMBER       *'
          WRITE (IU06,*) ' * LATITUDES  FOUND      NJ = ', NJ
          WRITE (IU06,*) ' * LATITUDES  EXPECTED   NY = ', NY
          WRITE (IU06,*) ' * LONGITUDES FOUND      NL = ', NL
          WRITE (IU06,*) ' * LONGITUDES EXPECTED   NX = ', NX
          WRITE (IU06,*) ' *                                       *'
          WRITE (IU06,*) ' * PROGRAM WILL BE ABORTED               *'
          WRITE (IU06,*) ' *****************************************'
          CALL ABORT
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    4. CONVERT INPUT DEPTH TO MODEL DEPTH
C*       POSITIVE SEA DEPTH IN METRES (-999  FOR LAND).
C        ----------------------------------------------
C
 4000 CONTINUE
      DO 4001 J=1,NY
      DO 4001 I=1,NX
         IF (IA2(I,J).LE.0) THEN
           IA2(I,J) = -IA2(I,J)
         ELSE
           IA2(I,J) = -999
         ENDIF
 4001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    5. MANUAL ADJUSTMENT OF TOPOGRAPHY.
C        --------------------------------
C
 5000 CONTINUE
      IF (NOUT.NE.0) THEN
         XLAT=AMOSOP-XDELLA
         DO 5001 J=1,NY
            XLAT=XLAT+XDELLA
            XLON=AMOWEP-XDELLO
            IF (XLON.LT.0.) XLON=360.+XLON
            DO 5002 I=1,NX
               XLON=XLON+XDELLO
               IF (XLON.GE.360.) XLON=XLON-360.
               DO 5003 JH = 1,NOUT
                  IF (XLON.LT.XOUTW(JH)) XLON=XLON+360.
                  IF (XLON.GT.XOUTE(JH)) XLON=XLON-360.
                  IF (XLON.GE.XOUTW(JH) .AND. XLAT.GE.XOUTS(JH) .AND.
     1                XLON.LE.XOUTE(JH) .AND. XLAT.LE.XOUTN(JH))
     2               IA2(I,J) = NOUTD(JH)
 5003          CONTINUE
 5002       CONTINUE
 5001    CONTINUE
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    7. AID TO USERS - SIMPLE PLOT OF GRID.
C        ------------------------------------
C
 7000 CONTINUE
      WRITE (IU06,'(''0NUMBER OF LATITUDES IS        NY = '',I5)') NY
      WRITE (IU06,'('' MOST SOUTHERN LATITUDE IS AMOSOP = '',F5.1)')
     1           AMOSOP
      WRITE (IU06,'('' MOST NORTHERN LATITUDE IS AMONOP = '',F5.1)')
     1           AMONOP
      WRITE (IU06,'('' LATITUDE INCREMENT IS     XDELLA = '',F5.1)')
     1           XDELLA
      WRITE (IU06,'(''0NUMBER OF LONGITUDES IS       NX = '',I5)') NX
      WRITE (IU06,'('' MOST WESTERN LONGITUDE IS AMOWEP = '',F5.1)')
     1           AMOWEP
      WRITE (IU06,'('' MOST EASTERN LONGITUDE IS AMOEAP = '',F5.1)')
     1           AMOEAP
      WRITE (IU06,'('' LONGITUDE INCREMENT IS    XDELLO = '',F5.1)')
     1           XDELLO


      ILEN = 120
      IPAGE = (NX+ILEN-1)/ILEN
      IF (IPAGE.GT.1) THEN
         LAST = (NX-ILEN*(IPAGE-1)+IPAGE-2)/(IPAGE-1)
         IF (LAST.LE.10) THEN
            ILEN = ILEN + 10
            IPAGE = (NX+ILEN-1)/ILEN
         ENDIF
      ENDIF
      DO 7003 L=1,IPAGE
         IA = (L-1)*ILEN
         IE = MIN(IA+ILEN,NX)
         IA = IA+1
         WRITE (IU06,'(''0UNBLOCKED GRID               N'',
     1                40X,''PAGE'',I2)') L
         WRITE (IU06,'(''   L = LAND               W -   - E'')')
         WRITE (IU06,'(''   S = SEA                    S'',/)')
         WRITE (IU06,'(2X,130I1)') (AMODA(I,10),I=IA,IE)
         DO 7001 JH =NY,1,-1
            DO 7002 I=IA,IE
               IF (IA2(I,JH).EQ.-999) AXX(I)='L'
               IF (IA2(I,JH).NE.-999) AXX(I)='S'
 7002       CONTINUE
            WRITE (IU06,'(1X,I1,130A1)') AMODA(JH,10),(AXX(I),I=IA,IE)
 7001    CONTINUE
         WRITE (IU06,'(2X,130I1)') (AMODA(I,10),I=IA,IE)
 7003 CONTINUE

      RETURN
      END
      SUBROUTINE UIPREP (IU05, IFORM, IREFRA, ML, KL)

C ----------------------------------------------------------------------
C
C**** *UIPREP* - ROUTINE TO READ USER INPUT FOR PREPROC.
C
C     H.GUNTHER            ECMWF       04/04/1990
C
C*    PURPOSE.
C     -------
C
C       TO READ USER INPUT OF PROGRAM PREPROC AND CHECKS CONSISTENCY.
C
C**   INTERFACE.
C     ----------
C
C       *CALL* *UIPREP (IU05, IFORM, IREFRA, ML, KL, NX, NY)*
C          *IU05*    - LOGICAL INPUT UNIT.
C          *IFORM*   - OUTPUT FORMAT OPTION = 1 UNFORMATED
C                                           = 2 FORMATED
C                                           OTHERWISE BOTH
C          *IREFRA*  - REFRACTION OPTION = 2 CURRENT PROCESSING.
C                                        OTHERWISE NOTHING.
C          *ML*      - NUMBER OF FREQUENCIES.
C          *KL*      - NUMBER OF DIRECTIONS.
C
C     METHOD.
C     -------
C
C       FORMATED READ FROM LOGICAL UNIT IU05. A PRINTER PROTOCOL
C       IS DONE AND THE DATA ARE CHECKED FOR CONSISTENCY.
C
C     EXTERNALS.
C     ----------
C
C       *ABORT*     - TERMINATES PROCESSING.
C       *ADJUST*    - CORRECTS LONGITUDE INPUT.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
C

       INCLUDE 'preprowk.h'
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS FOR PREPROC ONLY.
C
      PARAMETER (NBMAX = (NGX+NGY)*2-4)
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS OF TOPOGRAPHIE DATA.
C
      PARAMETER (JLONI = 1500 , JLATI = 400, IOUTA = 80)
C
C*    *COMMON* *CPBOUN* USED FOR THE COURSE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /CPBOUN/ IBOUNC, NBOUNC(NESTMAX), 
     1                IJARC(NBMAX), IGARC(NBMAX),
     1                DLAMAC, DPHIAC, AMOSOC(NESTMAX), 
     1                AMONOC(NESTMAX), AMOEAC(NESTMAX), AMOWEC(NESTMAX),
     2                BLATC(NBMAX), BLNGC(NBMAX)
C
C*    *COMMON* *CINP* USER INPUT: AREAS TO BE CHANGED, AND
C*                    SPECIAL OUTPUT POINTS.
C
      COMMON /CINP/ NOUT, XOUTW(IOUTA), XOUTS(IOUTA), XOUTE(IOUTA),
     1              XOUTN(IOUTA), NOUTD(IOUTA),
     2              OUTLONG(MOUTP), OUTLAT(MOUTP)
C
C*    *COMMON* *COUT*  OUTPUT POINTS INDICES AND FLAGS.
C
      LOGICAL FFLAG(14), FFLAG20, FFLAG21, FFLAG25, FFLAG26,
     1        PFLAG(14), PFLAG20, PFLAG21, PFLAG25, PFLAG26
      COMMON /COUT/ NGOUT, IGAR(MOUTP), IJAR(MOUTP),
     1              NOUTT, IOUTT(MOUTT),
     2              FFLAG, FFLAG20, FFLAG21, FFLAG25, FFLAG26,
     3              PFLAG, PFLAG20, PFLAG21, PFLAG25, PFLAG26
C
C*    *COMMON* *FPBOUN* USED FOR THE FINE GRID
C                       ORGANIZATION THE BOUNDARY POINTS.
C
      COMMON /FPBOUN/ IBOUNF, NBOUNF, IJARF(NBMAX), IGARF(NBMAX),
     1                IBFL(NBMAX), IBFR(NBMAX), BFW(NBMAX)
C
C*    *COMMON* *FREDIR* - FREQUENCY AND DIRECTION GRID.
C
      COMMON /FREDIR/ FR(NFRE), DFIM(NFRE), GOM(NFRE), C(NFRE),
     1                DELTH, DELTR, TH(NANG), COSTH(NANG), SINTH(NANG)
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
      CHARACTER LINE*80
C
C ----------------------------------------------------------------------
C
C*    0. READ HEADER AND PRINT.
C        ----------------------
C
  100 CONTINUE
      READ (IU05,'(A80)') LINE
      IF (LINE(1:1).EQ.'C') GOTO 100
      WRITE (IU06,'(1H1,'' PROGRAM PREPROC:'',//,'' USER INPUT:'')')
      WRITE (IU06,'(1H0,A70)') LINE(1:70)
C
C*    1. FREQUENCY AND DIRECTION GRID DEFINITIONS.
C        -----------------------------------------
C
 1000 CONTINUE
C
C*    1.1 READ INPUT AND PRINT.
C
      READ (IU05,'(A80)') LINE
      IF (LINE(1:1).EQ.'C') GOTO 1000
      READ (LINE,'(1X,I5,1X,I5,1X,F10.8)') ML, KL, FR(1)

      WRITE (IU06,'(/1X,''FREQUENCY / DIRECTION GRID''/)')
      WRITE (IU06,'(''   NUMBER OF FREQUENCIES IS ML = '',I3)') ML
      WRITE (IU06,'(''   MINIMUM FREQUENCY IS  FR(1) = '',F10.6)') FR(1)
      WRITE (IU06,'(''   NUMBER OF DIRECTIONS  IS KL = '',I3)') KL
C
C*    1.2 CHECK DIMENSION.
C
      IF (ML.GT.NFRE .OR. KL.GT.NANG) THEN
         WRITE (IU06,*) '**********************************************'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '*       FATAL ERROR IN SUB. UIPREP           *'
         WRITE (IU06,*) '*       ==========================           *'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '*  NUMBER OF FREQUENCIES OR DIRECTIONS       *'
         WRITE (IU06,*) '*  EXCEEDS DIMENSION.                        *'
         WRITE (IU06,*) '*  NUMBER OF FREQUENCIES IS      ML = ', ML
         WRITE (IU06,*) '*  DIMENSION FOR FREQUENIES IS NFRE = ', NFRE
         WRITE (IU06,*) '*  NUMBER OF DIRECTIONS  IS      KL = ', KL
         WRITE (IU06,*) '*  DIMENSION FOR DIRECTIONS IS NANG = ', NANG
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '**********************************************'
         CALL ABORT
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    2. OUTPUT GRID DEFINIONS.
C        ----------------------
C
 2000 CONTINUE
C
C*    2.1 READ INPUT AND PRINT.
C
      READ (IU05,'(A80)') LINE
      IF (LINE(1:1).EQ.'C') GOTO 2000

      READ (LINE,'(6(1X,F10.3))') XDELLA, XDELLO, AMOSOP, AMONOP,
     1                            AMOWEP, AMOEAP

c --- MAKIS 08/12/99
c     AMOEAP = 27.8333333
c     CALL ADJUST (AMOWEP, AMOEAP)

c -------------------------------------
      IPER = 0
      IF (AMODA(AMOEAP-AMOWEP+XDELLO+720., 360.).EQ.0.) IPER = 1

      WRITE (IU06,'(/1X,''OUTPUT GRID''/)')
      WRITE (IU06,'(3X,''RESOLUTION LAT-LON '',2F8.3)') XDELLA, XDELLO
      WRITE (IU06,'(3X,'' SOUTHERN LAT '','' NORTHERN LAT '',
     1  '' WESTERN LONG '','' EASTERN LONG'',
     2  /,2X,4F14.3)') AMOSOP, AMONOP, AMOWEP, AMOEAP
      IF (IPER.EQ.1) WRITE (IU06,*) '   THE GRID IS EAST-WEST PERIODIC'
C
C*    2.2 CHECK DIMENSION.
C
      NX = NINT((AMOEAP-AMOWEP)/XDELLO) + 1
      NY = NINT((AMONOP-AMOSOP)/XDELLA) + 1
      IF (NX.GT.NGX .OR. NY.GT.NGY) THEN
         WRITE (IU06,*) '**********************************************'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '*       FATAL ERROR IN SUB. UIPREP           *'
         WRITE (IU06,*) '*       ==========================           *'
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '*  NUMBER OF GRID POINTS IN OUTPUT GRID      *'
         WRITE (IU06,*) '*  EXCEEDS DIMENSION.                        *'
         WRITE (IU06,*) '*  NUMBER OF LONGITUDES IS       NX = ', NX
         WRITE (IU06,*) '*  DIMENSION FOR LONGITUDES IS  NGX = ', NGX
         WRITE (IU06,*) '*  NUMBER OF LATITUDES IS        NY = ', NY
         WRITE (IU06,*) '*  DIMENSION FOR LONGITUDES IS  NGY = ', NGY
         WRITE (IU06,*) '*                                            *'
         WRITE (IU06,*) '**********************************************'
         CALL ABORT
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    3. OUTPUT GRID CORRECTIONS.
C        ------------------------
C
         NOUT = 0
 3000    CONTINUE
         READ (IU05,'(A80)') LINE
         IF (LINE(1:1).EQ.'C') GOTO 3000
         IF (LINE(2:4).NE.'END') THEN
            NOUT=NOUT+1
            IF (NOUT.GT.IOUTA) THEN
               WRITE (IU06,*) '++++++++++++++++++++++++++++++++++++++++'
               WRITE (IU06,*) '+                                      +'
               WRITE (IU06,*) '+     WARINING ERROR IN SUB. UIPREP    +'
               WRITE (IU06,*) '+     =============================    +'
               WRITE (IU06,*) '+                                      +'
               WRITE (IU06,*) '+  NUMBER OF AREAS TO BE CORRECTED     +'
               WRITE (IU06,*) '+  EXCEEDS  DIMENSION   IOUTA = ', IOUTA
               WRITE (IU06,*) '+  THE FIRST IOUTA AREAS ARE ONLY USED.+'
               WRITE (IU06,*) '+                                      +'
               WRITE (IU06,*) '++++++++++++++++++++++++++++++++++++++++'
               NOUT = NOUT - 1
            ELSE
               READ (LINE,'(4(1X,F10.3),1X,I10)')
     1                                   XOUTS(NOUT), XOUTN(NOUT),
     2                                   XOUTW(NOUT), XOUTE(NOUT),
     3                                   NOUTD(NOUT)
               CALL ADJUST (XOUTW(NOUT), XOUTE(NOUT))
            ENDIF
            GOTO 3000
         ENDIF
         IF (NOUT.GT.0) THEN
            WRITE (IU06,'(/4X,'' AREAS TO BE CORRECTED IN OUTPUT GRID'',
     1                 /,4X,''  NO.   SOUTHERN LAT '',
     2                 '' NORTHERN LAT '','' WESTERN LONG '',
     3                 '' EASTERN LONG '','' DEPTH'')')
            DO 3002 I=1,NOUT
               WRITE (IU06,'(4X,I5,1X,4F14.3,I7 )') I, XOUTS(I),
     1               XOUTN(I), XOUTW(I), XOUTE(I), NOUTD(I)
 3002       CONTINUE
         ENDIF
C
C ----------------------------------------------------------------------
C
C*    4. OUTPUT POINTS.
C        --------------
C
      NGOUT = 0
 4000 CONTINUE
      READ (IU05,'(A80)') LINE
      IF (LINE(1:1).EQ.'C') GOTO 4000
      IF (LINE(2:4).NE.'END') THEN
         NGOUT = NGOUT + 1
         IF (NGOUT.GT.MOUTP) THEN
            WRITE (IU06,*) '+++++++++++++++++++++++++++++++++++++++++++'
            WRITE (IU06,*) '+                                         +'
            WRITE (IU06,*) '+     WARINING ERROR IN SUB. UIPREP       +'
            WRITE (IU06,*) '+     =============================       +'
            WRITE (IU06,*) '+                                         +'
            WRITE (IU06,*) '+  NUMBER OF OUTPUT POINTS EXCEEDS        +'
            WRITE (IU06,*) '+  EXCEEDS  DIMENSION      MOUTP = ', MOUTP
            WRITE (IU06,*) '+  THE FIRST MOUTP POINTS ARE ONLY USED.  +'
            WRITE (IU06,*) '+                                         +'
            WRITE (IU06,*) '+++++++++++++++++++++++++++++++++++++++++++'
            NGOUT = NGOUT - 1
         ELSE
            READ (LINE,'(2(1X,F10.3))') OUTLAT(NGOUT),OUTLONG(NGOUT)
         ENDIF
         GOTO 4000
      ENDIF
      IF (NGOUT.GT.0) THEN
         WRITE (IU06,'(''0OUTPUT POINTS FOR SPECTRA AS DEFINED'',
     1              '' BY USER INPUT'',/,
     2               3X,''  NO.    LAT.   LONG.'')')
         DO 4001 I=1,NGOUT
            WRITE (IU06,'(3X,I5,2F8.2)') I,OUTLAT(I),OUTLONG(I)
 4001    CONTINUE
      ENDIF
C
C ----------------------------------------------------------------------
C
C*    5. MODEL OPTIONS.
C        --------------
C
 5000 CONTINUE
      READ (IU05,'(A80)') LINE
      IF (LINE(1:1).EQ.'C') GOTO 5000
      READ (LINE,'(1X,I6,3I8)') IFORM, IREFRA, ITEST, ITESTB

      WRITE (IU06,'(''0OUTPUT OPTION IS       IFORM ='',I3,
     1         '' (1: UNFORM.; 2: FORM.; 3: BOTH)'')') IFORM
      WRITE (IU06,'('' REFRACTION OPTION IS  IREFRA ='',I3,
     1         '' (2: CURRENTS; OTHERWISE: NOTHING)'')') IREFRA
      WRITE (IU06,'('' TEST OUTPUT OPTION IS  ITEST ='',I3,
     1         '' (0: NO; >0: UP TO LEVEL ITEST)'')') ITEST
      WRITE (IU06,'('' BLOCK TEST OPTION IS  ITESTB ='',I3,
     1         '' (0: NO; >0: UP TO BLOCK ITESTB)'')') ITESTB
C
C ----------------------------------------------------------------------
C
C*    6. NESTED GRID INFORMATION.
C        ------------------------
C
         DO NEST = 1,NESTS
 6000 CONTINUE
      READ (IU05,'(A80)') LINE
      IF (LINE(1:1).EQ.'C') GOTO 6000
      IF (NEST.EQ.1) READ (LINE,'(1X,2I7)') IBOUNC, IBOUNF
      IF (NEST.GT.1) READ (LINE,'(1X,2I7)') IBNC, IBNF
      IF (IBOUNC .EQ. 1) THEN
         READ (LINE,'(14X,3F11.3,F15.3)') 
     1       AMOSOC(NEST), AMONOC(NEST), AMOWEC(NEST), AMOEAC(NEST)
      ENDIF
         END DO
C
      IF (IBOUNC .EQ. 1) THEN
C*    6.1 COARSE GRID OPTION.
C         -------------------
C
      WRITE (IU06,'(''0COARSE GRID OPTION IS IBOUNC = '',I3)') IBOUNC
c     IF (IBOUNC .EQ. 1) THEN
c        DO NEST = 1,NESTS
c        READ (LINE,'(14X,3F11.3,F15.3)') 
c    1       AMOSOC(NEST), AMONOC(NEST), AMOWEC(NEST), AMOEAC(NEST)
c        print *,'MAKIS:',NEST, AMOSOC(NEST), AMONOC(NEST), 
c    1   AMOWEC(NEST), AMOEAC(NEST)
c        END DO

c ----- MAKIS 08/12/99  was taken out !!!
c        CALL ADJUST (AMOWEC, AMOEAC)
         WRITE (IU06,*) '   THIS IS A COARSE GRID RUN  INFORMATION',
     1                  ' FOR A FOLLOW UP FINE GRID WILL BE GENERATED'
         DO NEST = 1,NESTS
         WRITE (IU06,*) 'NUMBER OF NEST:',NEST
         WRITE (IU06,'(/4X,'' NEST AREA IN COARSE GIRD IS'',
     1               /,4X,''  SOUTHERN LAT  NORTHERN LAT '',
     2                    '' WESTERN LONG  EASTERN LONG '')')
         WRITE (IU06,'(4X,4F14.3)') 
     1       AMOSOC(NEST), AMONOC(NEST), AMOWEC(NEST), AMOEAC(NEST)
         END DO
C
C*    6.1.1 ARE ALL CORNER POINTS OF THE NEST GRID POINTS?
C           ----------------------------------------------
C
c ----- MAKIS 08/12/99  were taken out !!!
         DO 6666 NEST = 1,NESTS
c        WEST = AMODA(AMOWEC - AMOWEP + 720., 360.)
c        EAST = AMODA(AMOEAC - AMOWEP + 720., 360.)
         WEST = (AMOWEC(NEST) - AMOWEP )
         EAST = (AMOEAC(NEST) - AMOWEP )
         GOTO 666
         IF ((AMODA(WEST, XDELLO) .NE. 0) .OR.
     1       (ABS(AMODA(EAST, XDELLO)) .GT. 1.E-5) .OR.
     2       (AMODA(AMOSOC(NEST) - AMOSOP, XDELLA) .NE. 0) .OR.
     3       (AMODA(AMONOC(NEST) - AMONOP, XDELLA) .NE. 0)) THEN

            WRITE (IU06,*) '++++++++++++++++++++++++++++++++++++++++++'
            WRITE (IU06,*) '+                                        +'
            WRITE (IU06,*) '+    WARNING ERROR IN SUB. UIPREP        +'
            WRITE (IU06,*) '+    ============================        +'
            WRITE (IU06,*) '+ ERROR IN NEST SPECIFICATIONS.          +'
            WRITE (IU06,*) '+ ONE OR MORE CORNER POINTS ARE NOT      +'
            WRITE (IU06,*) '+ COARSE GRID POINTS.                    +'
            WRITE (IU06,*) '+ NEST INFORMATION WILL NOT BE GENERATED +'
            WRITE (IU06,*) '+                                        +'
            WRITE (IU06,*) '++++++++++++++++++++++++++++++++++++++++++'
            IBOUNC = 0
         ENDIF
  666    CONTINUE
C
C*    6.1.2 INCLUDES THE COURSE GRID THE NEST GRID?
C           ---------------------------------------
C
         IF ((IPER.NE.1) .AND.
     1       (AMOWEP.GT.AMOWEC(NEST).OR. AMOEAC(NEST).GT.AMOEAP) .AND.
     2       (AMOWEP.GT.AMOWEC(NEST)+360.
     2            .OR. AMOEAC(NEST)+360..GT.AMOEAP) .AND.
     3       (AMOWEP.GT.AMOWEC(NEST)-360.
     3            .OR. AMOEAC(NEST)-360..GT.AMOEAP) ) THEN
            WRITE (IU06,*) '++++++++++++++++++++++++++++++++++++++++++'
            WRITE (IU06,*) ' NEST NUMBER:',NEST
            WRITE (IU06,*) '+                                        +'
            WRITE (IU06,*) '+     WARNING ERROR IN SUB. UIPREP       +'
            WRITE (IU06,*) '+     ============================       +'
            WRITE (IU06,*) '+ ERROR IN NEST SPECIFICATIONS.          +'
            WRITE (IU06,*) '+ WEST OR EAST BOUNDARY IS NOT IN COARSE +'
            WRITE (IU06,*) '+ GRID AREA.                             +'
            WRITE (IU06,*) '+                                        +'
            WRITE (IU06,*) '+     AMOWEC AND/OR AMOEAC ARE WRONG     +'
            WRITE (IU06,*) '+                                        +'
            WRITE (IU06,*) '+ NEST INFORMATION WILL NOT BE GENERATED +'
            WRITE (IU06,*) '+                                        +'
            WRITE (IU06,*) '++++++++++++++++++++++++++++++++++++++++++'
            IBOUNC = 0
         ENDIF
         IF (AMOSOP .GT. AMOSOC(NEST) .OR. AMONOC(NEST) .GT. AMONOP
     1                   .OR.
     1       AMOSOC(NEST) .GE. AMONOC(NEST)) THEN
            WRITE (IU06,*) '++++++++++++++++++++++++++++++++++++++++++'
            WRITE (IU06,*) ' NEST NUMBER:',NEST
            WRITE (IU06,*) '+                                        +'
            WRITE (IU06,*) '+     WARNING ERROR IN SUB. UIPREP       +'
            WRITE (IU06,*) '+     ============================       +'
            WRITE (IU06,*) '+ ERROR IN NEST SPECIFICATIONS.          +'
            WRITE (IU06,*) '+ NORTH OR SOUTH BOUNDARY IS NOT IN      +'
            WRITE (IU06,*) '+ COARSE GRID AREA, OR SOUTH IS GE NORTH +'
            WRITE (IU06,*) '+                                        +'
            WRITE (IU06,*) '+     AMOSOC AND/OR AMONOC ARE WRONG     +'
            WRITE (IU06,*) '+                                        +'
            WRITE (IU06,*) '+ NEST INFORMATION WILL NOT BE GENERATED +'
            WRITE (IU06,*) '+                                        +'
            WRITE (IU06,*) '++++++++++++++++++++++++++++++++++++++++++'
            IBOUNC = 0
         ENDIF
 6666   CONTINUE
      END IF
      IF (IBOUNC.NE.1) THEN
         WRITE (IU06,*) '   A NEST IS NOT INCLUDED IN THIS GRID'
      ENDIF
C
C*    6.2 FINE GRID OPTION.
C         -----------------
C
      WRITE (IU06,'(''0FINE GRID OPTION IS   IBOUNF = '',I3)') IBOUNF
      IF (IBOUNF .EQ. 1) THEN
         WRITE (IU06,*) '   THIS IS A FINE GRID RUN, INPUT FROM',
     1                  ' A COARSE GRID IS EXPECTED'
      ELSE
         WRITE (IU06,*) '   BOUNDARY VALUES FROM A COARSE GRID',
     1                  ' ARE NOT EXPECTED'
      ENDIF

      WRITE (IU06,'(''0END OF USER INPUT PROTOCOL'')')
C
      RETURN
      END
      SUBROUTINE WAMCUR (IUCUR)

C ----------------------------------------------------------------------
C
C**** *WAMCUR* - ROUTINE PROCESS A CURRENT FIELD.
C
C     SUSANNE HASSELMANN        JUNE     1990.
C     H. GUNTHER    ECMWF/GKSS  DECEMBER 1990  MODIFIED FOR CYCLE_4.
C
C*    PURPOSE.
C     --------
C
C       INPUT AND INTERPOLATION TO BLOCKED CURRENT ARRAYS.
C
C**   INTERFACE.
C     ----------
C
C      *CALL* *WAMCUR (IUCUR)*
C          *IUCUR*  - INPUT UNIT FOR CURRENTS.
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS FOR CURRENT INPUT.
C
      PARAMETER (NCC =  316, NRC = 319)
C
C
C     METHOD.
C     -------
C
C       LINEAR INTERPOLATION.
C
C     EXTERNALS.
C     ----------
C
C       *LOCINT*    - INTERPOLATE TO BLOCKS.
C       *READCUR*   - READ A CURRENT FIELD.
C
C     REFERENCE.
C     ----------
C
C       NONE.
C
C ----------------------------------------------------------------------
C
C*    *PARAMETER*  FOR ARRAY DIMENSIONS.
       INCLUDE 'preprowk.h'
C
C*    *COMMON* *CURRENT* - CURRENT FIELD.
C
      COMMON /CURRENT/ U(0:NIBLC,NBLC), V(0:NIBLC,NBLC)
C
C*    *COMMON* *CURGRD* - INPUT CURRENT GRID SPECFICATIONS.
C
      COMMON /CURGRD/ DUCLO, DUCLA, UCLO, UCLH, UCLW, UCLE,
     1                KRCI, KCCI, IPCUR
C
C*    *COMMON* *GRIDPAR*  GENERAL GRID INFORMATION.
C
      COMMON /GRIDPAR/ DELPHI, DELLAM, SINPH(NGY), COSPH(NGY),
     1                 IGL, IJS(NBLO), IJL2(NBLO), IJLS(NBLO),
     2                 IJL(NBLO), IJLT(NBLO)
C
C*    *COMMON* *MAP*  LON/LAT INDEX OF EACH SEA POINT.
C
      COMMON /MAP/ IXLG(NIBLO,NBLO), KXLT(NIBLO,NBLO), NX, NY, IPER,
     1             AMOWEP, AMOSOP, AMOEAP, AMONOP, XDELLA, XDELLO
C
C*    *COMMON* *TESTO* - PRINTER OUTPUT UNIT AND TEST FLAGS.
C
      COMMON /TESTO/ IU06, ITEST, ITESTB
C
C ----------------------------------------------------------------------
C
      DIMENSION UCUR(NCC,NRC), VCUR(NCC,NRC)
C
C ----------------------------------------------------------------------
C
C*    1. READ CURRENT FILE.
C        ------------------
C
 1000 CONTINUE
      CALL READCUR (IUCUR, IDTCR, UCUR, VCUR, NCC, NRC)
C
C ----------------------------------------------------------------------
C
C*    2. INTERPOLATION OF INPUT CURRENT ON MODEL GRID.
C        ---------------------------------------------
C
 2000 CONTINUE
C
C*    2.1 CHECK THE DIMENSION OF CURRENTS FIELDS
C         --------------------------------------
C
      IF (NIBLC.LT.NIBLO .OR. NBLC.LT.NBLO) THEN
         WRITE(6,*)'*******************************'
         WRITE(6,*)'*                             *'
         WRITE(6,*)'*    F A T A L  ERROR         *'
         WRITE(6,*)'*    ================         *'
         WRITE(6,*)'*                             *'
         WRITE(6,*)'*  NIBLC AND NBLC IS TO SMALL *'
         WRITE(6,*)'*                             *'
         WRITE(6,*)'*  SET NIBLC = NIBLO          *'
         WRITE(6,*)'*  SET NLBC  = NBLC           *'
         WRITE(6,*)'*                             *'
         WRITE(6,*)'*******************************'
         CALL ABORT
      END IF
C
      IJA =1
      DO 2001 IG=1,IGL
         CALL LOCINT (IG, IJA, IJLT(IG), NCC, NRC, KCCI, KRCI, IPCUR,
     1          DUCLO, DUCLA, UCLW, UCLO, UCUR, VCUR, U(1,IG), V(1,IG))
 2001 CONTINUE
C
C ----------------------------------------------------------------------
C
C*    3. TEST OUTPUT OF WAVE MODEL BLOCKS
C        ---------------------------------
C
 3000 CONTINUE
      IF (ITEST.GE.3) THEN
          WRITE (IU06,*) ' '
	  WRITE (IU06,*) '      SUB. WAMCUR..',
     1                   ' CURRENTS CONVERTED TO BLOCKS'
	  WRITE (IU06,*) ' '
	  DO 3001 IG = 1,ITESTB
	     IJA = IJS(IG)
	     IJE = IJS(IG)+4
	     WRITE (IU06,*) ' BLOCK= ',IG
	     WRITE (IU06,*) ' '
	     WRITE (IU06,*) ' U(IJS - IJS+4): ',(U(I,IG),I=IJA,IJE)
	     WRITE (IU06,*) ' V(IJS - IJS+4): ',(V(I,IG),I=IJA,IJE)
 3001    CONTINUE
      ENDIF

      RETURN
      END
C***********************************************************************
          function amoda(x1,x2)
	  amoda = x1-int(x1/x2)*x2
	  return
	  end
