#include "w3macros.h" !/ ------------------------------------------------------------------- / PROGRAM W3GSPL !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 18-Nov-2013 | !/ +-----------------------------------+ !/ !/ 24-Sep-2012 : Origination. ( version 4.10 ) !/ 16-Jan-2013 : Add output of mask file (no halo). ( version 4.10 ) !/ 19-Jan-2013 : Tweaking the template file. ( version 4.10 ) !/ 24-Jan-2013 : Set up for minimum of 2 grids. ( version 4.10 ) !/ Add XOFF to grid origin in X. !/ Fix IDCLSE for partial grids. !/ Add FRFLAG option to disable side-by-side !/ running of grids in ww3_multi. !/ 29-Jan-2013 : Add error code on stop. ( version 4.10 ) !/ 31-Jan-2013 : Add routine GRLOST. ( version 4.10 ) !/ 01-Feb-2013 : Speed up GRSEPA. ( version 4.10 ) !/ Add dynamic trim range in GRTRIM. !/ Speed up GRFILL. !/ Add small grid merge (GRFSML) early in loop. !/ 04-Feb-2013 : Testing on zero grid size added. ( version 4.10 ) !/ Corner point in halo for GR1GRD. !/ 04-Mar-2013 : Adding GrADS output. ( version 4.10 ) !/ 05-Aug-2013 : Add UQ/UNO for distances. ( version 4.12 ) !/ 18-Nov-2013 : Add user-defined halo extension. ( version 4.14 ) !/ !/ Copyright 2012-2013 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights !/ reserved. WAVEWATCH III is a trademark of the NWS. !/ No unauthorized use without permission. !/ ! 1. Purpose : ! ! Take an existing grid and create from this the grid data for a set ! of overlapping grids to be used in the ww3_multi code for hybid ! paralellization. ! ! 2. Method : ! ! See Section 8. ! ! 3. Parameters : ! ! Local parameters. ! ---------------------------------------------------------------- ! NDSI Int. Input unit number ("ww3_prep.inp"). ! NDSO Int. Output unit number. ! NDSE Int. Error unit number. ! NDST Int. Test output unit number. ! NDSM Int. Unit number for mod_def file. ! NG Int. Number of grids to be generated. ! NITMAX Int. Maximum number of iterations on grid ref. ! STARG Real std target in percent. ! GLOBAL Log. Closure flag. ! SEA L.A. Sea point map. ! ---------------------------------------------------------------- ! ! 4. Subroutines used : ! ! Name Type Module Description ! ---------------------------------------------------------------- ! W3NMOD Subr. W3GDATMD Set number of model. ! W3SETG Subr. Id. Point to selected model. ! W3NDAT Subr. W3WDATMD Set number of model for wave data. ! W3SETW Subr. Id. Point to selected model for wave data. ! W3NOUT Subr. W3ODATMD Set number of model for output. ! W3SETO Subr. Id. Point to selected model for output. ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. ! STRACE Subr. Id. Subroutine tracing. ! NEXTLN Subr. Id. Get next line from input filw ! EXTCDE Subr. Id. Abort program as graceful as possible. ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. ! ! GRINFO Subr. Internal Compile info on all grids. ! GRTRIM Subr. Internal Trim edges of grids. ! GRFILL Subr. Internal Fill unassigned space in grid. ! GRLOST Subr. Internal Assign "lost points". ! GRSQRG Subr. Internal Attempt to square-up grid. ! GRSNGL Subr. Internal Remove grid points that stick out. ! GRSEPA Subr. Internal Remove separated grid pieces. ! GRFSML Subr. Internal Deal with fixed minimum size. ! GRFLRG Subr. Internal Deal with fixed maximum size. ! GR1GRD Subr. Internal Extract single grid from map. ! ---------------------------------------------------------------- ! ! 5. Called by : ! ! None, stand-alone program. ! ! 6. Error messages : ! ! 7. Remarks : ! ! 8. Structure : ! ! ---------------------------------------------------- ! 1.a Number of models. ! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) ! b I-O setup. ! c Print heading(s). ! 2. Read model definition file. ( W3IOGR ) ! 3. Read options from file. ! 4. Generate first-guess map of sub-grids ! a Set up array ! b First cut with regular grid set up ! 1 Set up 'checkerboard' ! 2 Fill checkerboard ! 3 Remove smallest grids as necessary ! 4 Store first guess in MSPLIT ! 5. Refine map of sub-grids (no halo). ! a Set up loop. ( GRINFO ) ! b Remove small grids. ( GRFSML ) ! c Trim edges of grids ( GRTRIM ) ! ( GRFILL, GRLOST ) ! d Attempt to square-up grid ( GRINFO ) ! ( GRSQRG ) ! ( GRFILL, GRLOST ) ! e Remove mid-sea points sticking out of grid ! ( GRSNGL ) ! f Remove detached grid parts. ( GRSEPA ) ! g Recompute stats ( GRINFO ) ! h Optional GrADS output. ! i Test convergence ! Check if stuck on min or max. ( GRFSML ) ! ( GRFLRG ) ! j Test output ! 6. Output info for all sub grids. ! a Set up loop. ( GRINFO ) ! b Extract grid including halo. ( GR1GRD ) ! 7. End of program. ! ---------------------------------------------------- ! ! 9. Switches : ! ! !/PRn Select propgation scheme. ! ! !/O16 Generate GrADS output of grid partitioning. ! ! !/S Enable subroutine tracing. ! !/T Enable test output (main). ! !/T1 Enable test output (GRINFO). ! !/T2 Enable test output (GRFILL). ! !/T3 Enable test output (GRSNGL). ! !/T4 Enable test output (GRSEPA). ! !/T5 Enable test output (GRFSML). ! !/T6 Enable test output (GRFLRG). ! !/T7 Enable test output (GR1GRD). ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / USE CONSTANTS !/ ! USE W3GDATMD, ONLY: W3NMOD, W3SETG USE W3ADATMD, ONLY: W3NAUX, W3SETA USE W3ODATMD, ONLY: W3NOUT, W3SETO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE USE W3ARRYMD, ONLY : OUTA2I, OUTA2R !/S USE W3SERVMD, ONLY : STRACE USE W3IOGRMD, ONLY: W3IOGR !/ USE W3GDATMD USE W3ODATMD, ONLY: NDSE, NDST, NDSO, FNMPRE ! IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: NDSI, NDSM, NDSTRC, NTRACE, J, IERR, & NG, IX, IY, NGB, NGX, NGY, IG, IGG, & IGX, IGY, IGY0, IGYN, IGX0, IGXN, & MINGRD, MINNR, MINNXT, MINNNR, & NITMAX, IIT, INGMIN, INGMAX, & INGMNC, INGMXC, INGLAG, JJ, & NSTDLG, MSTDLG = 5, NSEAT, J1, J2, & J3, J4, J5, IDFM1, IDFM2, IDFM3, & IDLA1, IDLA2, IDLA3, VSC3, NHEXT !/S INTEGER, SAVE :: IENT = 0 !/O16 INTEGER :: NDSG = 35, NTGRDS = 0 INTEGER, ALLOCATABLE :: MSPLIT(:,:), MTEMP(:,:), INGRD(:) REAL :: RATIO1, XMEAN, STARG, STDMIN, & ZBDUM, ZBMIN, VSC1, VSC2, FRACL, FRACH LOGICAL :: GLOBAL, OK, DONE, FRFLAG LOGICAL, ALLOCATABLE :: ISNEXT(:), SEA(:,:) CHARACTER(LEN=1) :: COMSTR CHARACTER(LEN=3) :: G0ID CHARACTER(LEN=4) :: IDGRID, IDCLSE, PTCLSE CHARACTER(LEN=6) :: NRFMT CHARACTER(LEN=11) :: FEXT, AEXT CHARACTER(LEN=16) :: RFORM1, RFORM2, RFORM3 CHARACTER(LEN=20) :: FNAME, INAME ! TYPE STATS_GRID LOGICAL :: STRADLE, INSTAT INTEGER :: NPTS, NYL, NYH, NXL, NXH END TYPE STATS_GRID ! TYPE STATS_MEAN INTEGER :: NMIN, NMAX REAL :: RSTD END TYPE STATS_MEAN ! TYPE PART_GRID INTEGER :: NX, NY, NSEA INTEGER, POINTER :: MASK(:,:) REAL :: X0, Y0, SX, SY REAL, POINTER :: ZBIN(:,:), OBSX(:,:), OBSY(:,:) LOGICAL :: GLOBAL END TYPE PART_GRID ! TYPE(STATS_GRID), POINTER :: GSTATS(:), GSTOLD(:) TYPE(STATS_MEAN) :: MSTATS , MSTOLD TYPE(PART_GRID), POINTER :: PGRID(:) !/ !/ ------------------------------------------------------------------- / !/ ! 1.a Set number of models ! CALL W3NMOD ( 1, 6, 6 ) CALL W3SETG ( 1, 6, 6 ) CALL W3NAUX ( 6, 6 ) CALL W3SETA ( 1, 6, 6 ) CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) ! ! 1.b IO set-up. ! NDSI = 10 NDSO = 6 NDSE = 6 NDST = 6 NDSM = 11 ! NDSTRC = 6 NTRACE = 100 CALL ITRACE ( NDSTRC, NTRACE ) ! !/O16 OPEN ( NDSG, FILE='./ww3.ww3_gspl', FORM='UNFORMATTED') ! ! 1.c Print header ! WRITE (NDSO,900) !/S CALL STRACE (IENT, 'W3GSPL') ! J = LEN_TRIM(FNMPRE) OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_gspl.inp',STATUS='OLD', & ERR=800,IOSTAT=IERR) REWIND (NDSI) READ (NDSI,'(A)',END=801,ERR=802,IOSTAT=IERR) COMSTR IF (COMSTR.EQ.' ') COMSTR = '$' WRITE (NDSO,901) COMSTR ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 2. Read model definition file. ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) FEXT ! CALL W3IOGR ( 'READ', NDSM, 1, FEXT ) CLOSE (NDSM) ! WRITE (NDSO,902) FEXT, GNAME ! SELECT CASE (GTYPE) CASE (RLGTYPE) WRITE ( NDSO,903) 'rectilinear' IDGRID = 'RECT' CASE (CLGTYPE) WRITE ( NDSO,903) 'curvictilinear' IDGRID = 'CURV' CASE (UNGTYPE) WRITE ( NDSO,903) 'unstructured' IDGRID = 'UNST' GOTO 820 CASE DEFAULT WRITE ( NDSO,903) 'not recognized' GOTO 821 END SELECT ! SELECT CASE (ICLOSE) CASE (ICLOSE_NONE) WRITE ( NDSO,904) 'none' IDCLSE = 'NONE' GLOBAL = .FALSE. CASE (ICLOSE_SMPL) WRITE ( NDSO,904) 'global (simple)' IDCLSE = 'SMPL' GLOBAL = .TRUE. CASE (ICLOSE_TRPL) WRITE ( NDSO,904) 'global (tripolar)' IDCLSE = 'TRPL' GLOBAL = .TRUE. GOTO 822 CASE DEFAULT WRITE ( NDSO,904) 'not recognized' GOTO 823 END SELECT ! WRITE (NDSO,905) NX, NY, NSEA IF ( NSEA .EQ. 0 ) GOTO 824 ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 3. Read options from input file. ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NG, NITMAX, STARG, NHEXT NG = MAX ( 2, NG ) NITMAX = MAX ( 1, NITMAX ) STARG = MAX ( 0. , STARG ) NHEXT = MAX ( 0, NHEXT ) WRITE (NDSO,930) NG, NITMAX, STARG, NHEXT ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDLA1, IDFM1, & VSC1, RFORM1 IF (IDLA1.LT.1 .OR. IDLA1.GT.4) IDLA1 = 1 IF (IDFM1.LT.1 .OR. IDFM1.GT.3) IDFM1 = 1 IF ( ABS(VSC1) .LT. 1.E-15 ) VSC1 = 1. WRITE (NDSO,931) IDLA1, IDFM1, VSC1, RFORM1 ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDLA2, IDFM2, & VSC2, RFORM2 IF (IDLA2.LT.1 .OR. IDLA2.GT.4) IDLA2 = 1 IF (IDFM2.LT.1 .OR. IDFM2.GT.3) IDFM2 = 1 IF ( ABS(VSC2) .LT. 1.E-15 ) VSC2 = 1. IF ( TRFLAG .EQ. 0 ) THEN WRITE (NDSO,932) ELSE WRITE (NDSO,933) IDLA2, IDFM2, VSC2, RFORM2 END IF ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) IDLA3, IDFM3, & VSC3, RFORM3 IF (IDLA3.LT.1 .OR. IDLA3.GT.4) IDLA3 = 1 IF (IDFM3.LT.1 .OR. IDFM3.GT.3) IDFM3 = 1 IF ( VSC3 .EQ. 0 ) VSC3 = 1 WRITE (NDSO,934) IDLA3, IDFM3, VSC3, RFORM3 ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) FRACL, FRACH, FRFLAG FRACL = MAX ( 0. , FRACL ) FRACH = MIN ( 1. , FRACH ) WRITE (NDSO,935) FRACL, FRACH IF ( FRACL .GT. FRACH ) GOTO 830 IF ( .NOT. FRFLAG ) WRITE (NDSO,936) ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 4. Generate map of sub-grids (no halo) ! 4.a Set up array ! ALLOCATE ( MSPLIT(NY,NX) , MTEMP(NY,NX), SEA(NY,NX) ) ! DO IY=1, NY DO IX=1, NX IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN MSPLIT(IY,IX) = 0 SEA (IY,IX) = .FALSE. ELSE MSPLIT(IY,IX) = -1 SEA (IY,IX) = .TRUE. END IF END DO END DO ! ! 4.b First cut with regular grid set up ! 4.b.1 Set up 'checkerboard' ! RATIO1 = REAL(NX) / REAL(NY) ! NGX = 1 NGY = 1 ! DO IF ( NGX*NGY .GE. NG ) EXIT IF ( REAL(NGX)/REAL(NGY) .GT. RATIO1 ) THEN NGY = NGY + 1 ELSE NGX = NGX + 1 END IF END DO ! IF ( NGX .GT. NGY ) THEN IF ( (NGY-1)*NGX .GE. NG ) NGY = NGY - 1 IF ( (NGX-1)*NGY .GE. NG ) NGX = NGX - 1 ELSE IF ( (NGY-1)*NGX .GE. NG ) NGY = NGY - 1 IF ( (NGX-1)*NGY .GE. NG ) NGX = NGX - 1 END IF ! !/T WRITE (NDST,9040) NGX, NGY ! ! 4.b.2 Fill checkerboard ! J = 0 DO ! MTEMP = MSPLIT IG = 1 IGYN = 0 J = J + 1 ALLOCATE ( INGRD(NGX*NGY) ) INGRD = 0 ! !/T WRITE (NDST,9041) J ! DO IGY=1, NGY ! IGY0 = IGYN + 1 IF ( IGY .EQ. NGY ) THEN IGYN = NY ELSE IGYN = NINT ( REAL(NY*IGY) / REAL(NGY) ) END IF IGXN = 0 ! DO IGX=1, NGX ! IGX0 = IGXN + 1 IF ( IGX .EQ. NGX ) THEN IGXN = NX ELSE IGXN = NINT ( REAL(NX*IGX) / REAL(NGX) ) END IF ! DO IX=IGX0, IGXN DO IY=IGY0, IGYN IF ( MTEMP(IY,IX) .EQ. -1 ) THEN MTEMP(IY,IX) = IG INGRD(IG) = INGRD(IG) + 1 END IF END DO END DO ! IF ( INGRD(IG) .GT. 0 ) THEN !/T WRITE (NDST,9042) IG, IGX0, IGXN, IGY0, IGYN, & !/T INGRD(IG), 'OK' IG = IG + 1 !/T ELSE !/T WRITE (NDST,9042) IG, IGX0, IGXN, IGY0, IGYN, & !/T INGRD(IG), 'EMPTY (SKIPPED)' END IF ! END DO ! END DO ! IG = IG - 1 IF ( IG .LT. NG ) THEN IF ( NGX .LT. NGY ) THEN NGY = NGY + 1 ELSE NGX = NGX + 1 END IF DEALLOCATE ( INGRD ) !/T WRITE (NDST,9040) NGX, NGY ELSE EXIT END IF ! END DO ! MINGRD = 0 DO J=1, IG MINGRD = MINGRD + INGRD(J) END DO IF ( MINGRD .NE. NSEA ) GOTO 825 ! !/T WRITE (NDST,9043) IG, NG ! ! 4.b.3 Merge smallest grids as necessary ! IGG = IG ! DO ! IF ( IGG .EQ. NG ) EXIT ! MINGRD = NSEA MINNR = 0 DO J=1, IG IF ( INGRD(J) .LT. MINGRD ) THEN MINGRD = INGRD(J) MINNR = J END IF END DO INGRD(MINNR) = NSEA + 1 ! !/T WRITE (NDST,9044) MINGRD, MINNR ! ALLOCATE ( ISNEXT(0:IG) ) ISNEXT = .FALSE. ! DO IY=1, NY-1 DO IX=1, NX-1 IF ( ( MTEMP(IY ,IX ) - MINNR ) * & ( MTEMP(IY+1,IX ) - MINNR ) * & ( MTEMP(IY ,IX+1) - MINNR ) * & ( MTEMP(IY+1,IX+1) - MINNR ) .EQ. 0 ) THEN ISNEXT(MTEMP(IY ,IX )) = .TRUE. ISNEXT(MTEMP(IY+1,IX )) = .TRUE. ISNEXT(MTEMP(IY ,IX+1)) = .TRUE. ISNEXT(MTEMP(IY+1,IX+1)) = .TRUE. END IF END DO END DO ! IF ( GLOBAL ) THEN DO IY=1, NY-1 IF ( ( MTEMP(IY ,NX) - MINNR ) * & ( MTEMP(IY+1,NX) - MINNR ) * & ( MTEMP(IY , 1) - MINNR ) * & ( MTEMP(IY+1, 1) - MINNR ) .EQ. 0 ) THEN ISNEXT(MTEMP(IY ,NX)) = .TRUE. ISNEXT(MTEMP(IY+1,NX)) = .TRUE. ISNEXT(MTEMP(IY , 1)) = .TRUE. ISNEXT(MTEMP(IY+1, 1)) = .TRUE. END IF END DO END IF ! MINNXT = NSEA MINNNR = 0 DO J=1, IG IF ( ISNEXT(J) .AND. ( INGRD(J) .LT. MINNXT ) ) THEN MINNXT = INGRD(J) MINNNR = J END IF END DO ! !/T WRITE (NDST,9045) MINNXT, MINNNR ! IF ( MINNNR .GT. 0 ) THEN DO IY=1, NY DO IX=1, NX IF ( MTEMP(IY,IX) .EQ. MINNR ) THEN MTEMP(IY,IX) = MINNNR INGRD(MINNNR) = INGRD(MINNNR) + 1 END IF END DO END DO IGG = IGG - 1 !/T WRITE (NDST,9046) MINNR, MINNNR !/T DO J=1, IG !/T WRITE (NDST,9047) J, INGRD(J) !/T END DO !/T ELSE !/T WRITE (NDST,9048) MINNR END IF ! DEALLOCATE ( ISNEXT) !/T WRITE (NDST,9043) IGG, NG ! END DO ! !/T WRITE (NDST,9049) NG ! DO J=1, IG IF ( INGRD(J) .GT. NSEA ) INGRD(J) = 0 !/T WRITE (NDSO,9047) J, INGRD(J) END DO ! ! 4.b.4 Store first guess in MSPLT ! IGG = 0 DO J=1, IG IF ( INGRD(J) .NE. 0 ) THEN IGG = IGG + 1 DO IY=1, NY DO IX=1, NX IF ( MTEMP(IY,IX) .EQ. J ) MSPLIT(IY,IX) = IGG END DO END DO END IF END DO ! ! 5.b.5 Optional GrADS output ! !/O16 WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) !/O16 NTGRDS = NTGRDS + 1 ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 5. Refine grids ! 5.a Set up loop ! ALLOCATE ( GSTATS(NG), GSTOLD(NG), PGRID(NG) ) GSTATS(:)%INSTAT = .TRUE. WRITE (NDSO,950) DONE = .FALSE. ! CALL GRINFO WRITE (NDSO,951) 0, MSTATS%NMIN, MSTATS%NMAX, & 100.*MSTATS%RSTD/XMEAN G0ID = '5.a' IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 INGMIN = MSTATS%NMIN INGMAX = MSTATS%NMAX INGMNC = 0 INGMXC = 0 INGLAG = 3 STDMIN = 100.*MSTATS%RSTD/XMEAN NSTDLG = 0 ! DO IIT=1, NITMAX ! IF ( NG .EQ. 1 ) EXIT ! MSTOLD = MSTATS GSTOLD = GSTATS ! !/T WRITE (NDST,9050) 'a', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD ! ! 5.b Small grid attempt to merge ! IF ( MSTATS%NMIN .LT. NINT(0.45*XMEAN) ) THEN ! CALL GRFSML CALL GRINFO ! G0ID = '5.b' IF ( MSTOLD%NMIN .NE. MSTATS%NMIN ) THEN WRITE (NDSO,951) IIT, MSTATS%NMIN, MSTATS%NMAX, & 100.*MSTATS%RSTD/XMEAN IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 !/O16 WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) !/O16 NTGRDS = NTGRDS + 1 CYCLE ELSE WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & 100.*MSTATS%RSTD/XMEAN IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 END IF ! END IF ! ! 5.c Trim edges of grids and reassign ! CALL GRTRIM CALL GRFILL ( 2 ) ! ! 5.d Attempt to quare-up grid ! CALL GRINFO ! call needed as GRSQRG uses grid ranges !/T WRITE (NDST,9051) 'd', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD CALL GRSQRG CALL GRFILL ( 1 ) ! ! 5.e Remove mid-sea points sticking out of grid ! Call more than once to remove most ..... ! OK = .TRUE. ! DO JJ=1, 4 CALL GRSNGL ( OK ) END DO ! ! 5.f Remove parts of grid separated from main body, and attachable to ! other grids. ! CALL GRSEPA ( OK , 0.10 ) IF ( .NOT. OK ) THEN CALL GRFILL ( 1 ) OK = .TRUE. END IF ! ! 5.g Re-compute grid stats ! CALL GRINFO WRITE (NDSO,951) IIT, MSTATS%NMIN, MSTATS%NMAX, & 100.*MSTATS%RSTD/XMEAN !/T WRITE (NDST,9051) 'g', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD ! G0ID = '5.g' IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 ! ! 5.h Optional GrADS output ! !/O16 WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) !/O16 NTGRDS = NTGRDS + 1 ! ! 5.i Convergence tests ! ... The quick one ! IF ( 100.*MSTATS%RSTD/XMEAN .LE. STARG ) THEN WRITE (NDSO,959) EXIT END IF ! ! ... Monitoring convergence .... ! IF ( 100.*MSTATS%RSTD/XMEAN .LT. 1.0001*STDMIN ) THEN IF ( NSTDLG .LT. MSTDLG ) THEN NSTDLG = 0 ELSE WRITE (NDSO,959) EXIT END IF STDMIN = 100.*MSTATS%RSTD/XMEAN ELSE NSTDLG = NSTDLG + 1 IF ( NSTDLG .GT. MSTDLG ) STDMIN = 1.01*STDMIN END IF ! ! ... Check if stuck on min or max ! IF ( MSTATS%NMAX .LT. INGMAX ) THEN INGMAX = MSTATS%NMAX INGMXC = 0 ELSE INGMXC = INGMXC + 1 END IF ! IF ( MSTATS%NMIN .GT. INGMIN ) THEN INGMIN = MSTATS%NMIN INGMNC = 0 ELSE INGMNC = INGMNC + 1 END IF ! ! ... Stuck in min ... ! IF ( INGMNC .GE. INGLAG ) THEN ! !/T WRITE (NDST,9052) 'MINIMUM' ! IF ( REAL(INGMIN) .LT. 0.85*XMEAN ) THEN ! !/T WRITE (NDST,9053) 0.85*XMEAN / REAL(INGMIN) CALL GRFSML CALL GRINFO WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & 100.*MSTATS%RSTD/XMEAN INGMIN = MSTATS%NMIN INGMAX = MSTATS%NMAX INGMNC = 0 INGMXC = 0 IF ( DONE ) EXIT ! !/T ELSE !/T WRITE (NDST,9054) !/T END IF ! END IF ! ! ... Stuck in max ... ! IF ( INGMXC .GE. INGLAG ) THEN ! !/T WRITE (NDST,9052) 'MAXIMUM' ! IF ( REAL(INGMAX) .GT. 1.075*XMEAN ) THEN ! !/T WRITE (NDST,9053) REAL(INGMAX) / ( 1.075*XMEAN ) CALL GRINFO WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & 100.*MSTATS%RSTD/XMEAN INGMIN = MSTATS%NMIN INGMAX = MSTATS%NMAX INGMNC = 0 INGMXC = 0 IF ( DONE ) EXIT ! !/T ELSE !/T WRITE (NDST,9054) !/T END IF ! END IF ! END DO ! ! 5.j Test output ! WRITE (NDSO,955) ALLOCATE ( ISNEXT(NG) ) ISNEXT = .TRUE. CALL GRINFO ! DO JJ=1, NG MINNR = NSEA + 1 DO J=1, NG IF ( ISNEXT(J) .AND. GSTATS(J)%NPTS.LT.MINNR ) THEN MINNR = GSTATS(J)%NPTS IG = J END IF END DO ISNEXT(IG) = .FALSE. WRITE (NDST,956) IG, GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & GSTATS(IG)%NXL, GSTATS(IG)%NXH, & GSTATS(IG)%NYL, GSTATS(IG)%NYH END DO ! DEALLOCATE ( ISNEXT ) ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 6. Generate output to make separate grids ! 6.a Set up loop ! WRITE (NDSO,960) ! ZBDUM = 999. IF ( MAXVAL(ZB) .LT. -0.11 ) THEN ZBMIN = -0.1 ELSE ZBMIN = MAXVAL(ZB) + 1. ZBDUM = MAX ( ZBDUM , ZBMIN+1 ) END IF ! J1 = LEN_TRIM(FEXT) J2 = 1 + INT(LOG10(REAL(NG)+0.5)) WRITE (NRFMT,'(A2,I1,A1,I1,A1)') '(I', J2, '.', J2, ')' ! IF ( J1 + J2 + 2 .LE. 10 ) THEN FNAME = FEXT(:J1) // '_p' J3 = J1 + 3 ELSE FNAME = 'part_' J3 = 6 END IF J4 = J3 + J2 - 1 ! NSEAT = 0 ! DO IG=1, NG ! ! ! 6.b Extract grid including halo ! WRITE (NDSO,961) IG CALL GR1GRD NSEAT = NSEAT + PGRID(IG)%NSEA ! WRITE (AEXT,NRFMT) IG FNAME(J3:J4) = AEXT(:J2) J = LEN_TRIM(FNMPRE) ! ! 6.c Writing bottom file ! J5 = J4 + 4 FNAME(J4+1:J5) = '.bot' WRITE (NDSO,962) FNAME(:J5) ! IF ( IDFM1 .EQ. 3 ) THEN OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & FORM='UNFORMATTED',ERR=860,IOSTAT=IERR) ELSE OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), ERR=860,IOSTAT=IERR) END IF REWIND (NDSM) CALL OUTA2R ( PGRID(IG)%ZBIN, PGRID(IG)%NX, PGRID(IG)%NY, & 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, NDST, & NDSE, IDFM1, RFORM1, IDLA1, VSC1, 0.0 ) CLOSE (NDSM) ! ! 6.d Writing obstruction file ! J5 = J4 + 5 FNAME(J4+1:J5) = '.obst' ! IF ( TRFLAG .EQ. 0 ) THEN WRITE (NDSO,963) FNAME(:J5) ELSE WRITE (NDSO,962) FNAME(:J5) ! IF ( IDFM2 .EQ. 3 ) THEN OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & FORM='UNFORMATTED',ERR=860,IOSTAT=IERR) ELSE OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & ERR=860,IOSTAT=IERR) END IF REWIND (NDSM) CALL OUTA2R ( PGRID(IG)%OBSX, PGRID(IG)%NX, PGRID(IG)%NY, & 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, & NDST, NDSE, IDFM2, RFORM2, IDLA2, VSC2, 0.0 ) CALL OUTA2R ( PGRID(IG)%OBSY, PGRID(IG)%NX, PGRID(IG)%NY, & 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, & NDST, NDSE, IDFM2, RFORM2, IDLA2, VSC2, 0.0 ) CLOSE (NDSM) ! END IF ! ! 6.e Writing mask file ! J5 = J4 + 5 FNAME(J4+1:J5) = '.mask' WRITE (NDSO,962) FNAME(:J5) ! IF ( IDFM3 .EQ. 3 ) THEN OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), & FORM='UNFORMATTED',ERR=860,IOSTAT=IERR) ELSE OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), ERR=860,IOSTAT=IERR) END IF REWIND (NDSM) CALL OUTA2I ( PGRID(IG)%MASK, PGRID(IG)%NX, PGRID(IG)%NY, & 1, PGRID(IG)%NX, 1, PGRID(IG)%NY, NDSM, NDST, & NDSE, IDFM3, RFORM3, IDLA3, VSC3, 0 ) CLOSE (NDSM) ! ! 6.f Writing input file ! J5 = J4 + 5 FNAME(J4+1:J5) = '.tmpl' WRITE (NDSO,962) FNAME(:J5) ! OPEN (NDSM,FILE=FNMPRE(:J)//FNAME(:J5), ERR=860,IOSTAT=IERR) ! GNAME(31-J2:30) = AEXT GNAME(30-J2:30-J2) = 'p' WRITE (NDSM,965) GNAME, SIG(2)/SIG(1), TPIINV*SIG(1), NK, & NTH, TH(1)/DTH, FLDRY, FLCX, FLCY, FLCTH, & FLCK, FLSOU, DTMAX, DTCFL, DTCFLI, DTMIN J5 = LEN_TRIM(RFORM1) IF ( REAL(PGRID(IG)%NX) * PGRID(IG)%SX .LT. 359.9 ) THEN PTCLSE = 'NONE' ELSE PTCLSE = IDCLSE END IF WRITE (NDSM,966) IDGRID, FLAGLL, PTCLSE, & PGRID(IG)%NX, PGRID(IG)%NY, & PGRID(IG)%SX, PGRID(IG)%SY, & PGRID(IG)%X0, PGRID(IG)%Y0, & ZBMIN, DMIN, VSC1, IDLA1, IDFM1, & RFORM1(:J5), FNAME(:J4)//'.bot' IF ( TRFLAG .NE. 0 ) THEN J5 = LEN_TRIM(RFORM2) WRITE (NDSM,967) VSC2,IDLA2, IDFM2, RFORM2(:J5), & FNAME(:J4)//'.obst' END IF J5 = LEN_TRIM(RFORM3) WRITE (NDSM,968) IDLA3, IDFM3, RFORM3(:J5), FNAME(:J4)//'.mask' CLOSE (NDSM) ! END DO ! WRITE (NDSO,969) 100. * (REAL(NSEAT)/REAL(NSEA)-1.) ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 7. Write part of ww3_multi.inp ! J5 = 11+J1+J2 INAME(:J5) = 'ww3_multi.'//FEXT(:J1)//'.'//AEXT(:J2) OPEN (NDSM,FILE=FNMPRE(:J)//INAME(:J5), ERR=870,IOSTAT=IERR) ! DO IG=1, NG WRITE (AEXT,NRFMT) IG FNAME(J3:J4) = AEXT(:J2) IF ( FRFLAG ) THEN WRITE (NDSM,970) FNAME(:J4), & FRACL + REAL(IG-1)*(FRACH-FRACL)/REAL(NG), & FRACL + REAL( IG )*(FRACH-FRACL)/REAL(NG) ELSE WRITE (NDSM,970) FNAME(:J4), FRACL, FRACH END IF END DO ! CLOSE (NDSM) ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 8. Write mask file (no halo) ! J5 = 10+J1+J2 INAME(:J5) = 'ww3_mask.'//FEXT(:J1)//'.'//AEXT(:J2) OPEN (NDSM,FILE=FNMPRE(:J)//INAME(:J5), ERR=870,IOSTAT=IERR) ! DO IY=1, NY WRITE (NDSM,980) MSPLIT(IY,:) END DO ! !/O16 CLOSE ( NDSG ) ! !/O16 OPEN ( NDSG,FILE='ww3.ctl') !/O16 WRITE (NDSG,985) NX, X0, SX, NY, Y0, SY, NTGRDS !/O16 CLOSE ( NDSG ) ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 9. End of program ! GOTO 888 ! ! Error escape locations ! 800 CONTINUE WRITE (NDSE,1000) IERR CALL EXTCDE ( 40 ) ! 801 CONTINUE WRITE (NDSE,1001) CALL EXTCDE ( 41 ) ! 802 CONTINUE WRITE (NDSE,1002) IERR CALL EXTCDE ( 42 ) ! 820 CONTINUE WRITE (NDSE,1020) GTYPE CALL EXTCDE ( 20 ) ! 821 CONTINUE WRITE (NDSE,1021) GTYPE CALL EXTCDE ( 21 ) ! 822 CONTINUE WRITE (NDSE,1022) ICLOSE CALL EXTCDE ( 22 ) ! 823 CONTINUE WRITE (NDSE,1023) ICLOSE CALL EXTCDE ( 23 ) ! 824 CONTINUE WRITE (NDSE,1024) CALL EXTCDE ( 24 ) ! 825 CONTINUE WRITE (NDSE,1025) MINGRD, NSEA CALL EXTCDE ( 25 ) ! 830 CONTINUE WRITE (NDSE,1030) CALL EXTCDE ( 30 ) ! 850 CONTINUE WRITE (NDSE,1050) G0ID CALL EXTCDE ( 50 ) ! 860 CONTINUE WRITE (NDSE,1060) FNMPRE(:J)//FNAME(:J5), IERR CALL EXTCDE ( 60 ) ! 870 CONTINUE WRITE (NDSE,1070) FNMPRE(:J)//INAME(:J5), IERR CALL EXTCDE ( 70 ) ! 888 CONTINUE WRITE (NDSO,999) ! ! Formats ! 900 FORMAT (/15X,' *** WAVEWATCH III Grid splitting *** '/ & 15X,'=========================================='/) 901 FORMAT ( ' Comment character is ''',A,''''/) 902 FORMAT ( ' Grid ID : ',A/ & ' Grid name : ',A) 903 FORMAT ( ' Grid type : ',A) 904 FORMAT ( ' Closure : ',A) 905 FORMAT ( ' Grid size : ',I4,' x',I4,' (',I8,')'/) ! 930 FORMAT ( ' Generating ',I3,' grids'/ & ' No more than',I4,' refinement iterations'/ & ' Grid point count std target (%) :',F6.2/ & ' Halo per sub grid extended by',I3,' grid point.') 931 FORMAT ( ' Format info for bottom file :',2I2,F12.4,2X,A) 932 FORMAT ( ' Format info for obstruction file not used') 933 FORMAT ( ' Format info for obstruction file :',2I2,F12.4,2X,A) 934 FORMAT ( ' Format info for mask file :',2I2,I7,7X,A) 935 FORMAT ( ' Part of cummunicator to be used :',2F7.4) 936 FORMAT ( ' Not running grids side-by-side'/ & ' *** NON CONVENTIONAL OPERATION ***'/) ! 950 FORMAT (/' Iterations:'/ & ' nr min max std (%) '/ & ' ---------------------------------') 951 FORMAT (2X,I5,2I8,2F10.2) 952 FORMAT (2X,5x,2I8,2F10.2) 955 FORMAT (/' Resulting grids:'/ & ' grid stradle points range X range Y '/ & ' ---------------------------------------------') 956 FORMAT ( ' ',I4,5X,L1,2X,I7,4I5) 959 FORMAT ( ' Convergence reached') ! 960 FORMAT (/' Generating grid data:'/ & ' ---------------------------------------------') 961 FORMAT ( ' Extracting data for grid',I4) 962 FORMAT ( ' Writing file ',A) 963 FORMAT ( ' File ',A,' not requested') ! 970 FORMAT ( ' ''',A,''' ''LEV'' ''CUR'' ''WND'' ''ICE''', & ' ''D1'' ''D2'' ''D3'' RANK GROUP',2F10.7,' BFLAG') ! 980 FORMAT (1X,360I2) ! !/O16 985 FORMAT ( 'DSET ww3.ww3_gspl'/ & !/O16 'TITLE WAVEWATCH III grid splitting data'/ & !/O16 'OPTIONS sequential'/ & !/O16 'UNDEF -999.9'/ & !/O16 'XDEF ',I6,' LINEAR ',2F12.5/ & !/O16 'YDEF ',I6,' LINEAR ',2F12.5/ & !/O16 'ZDEF 1 LINEAR 1000.00000 1.00000'/ & !/O16 'TDEF ',I6,' LINEAR 00:00 06JUN1968 1HR'/ & !/O16 'VARS 1'/ & !/O16 'MAP 0 99 grid use map '/ & !/O16 'ENDVARS') ! 965 FORMAT ( '$ -------------------------------------', & '------------------------------- $'/ & '$ WAVEWATCH III Grid preprocessor input', & ' file $'/ & '$ -------------------------------------', & '------------------------------- $'/ & ' ''',A,''''/'$'/ & ' ',F8.4,F10.6,2I6,F8.4/' ',6L2/' ',4F12.4/ & '$ NAMELISTS'/'$') 966 FORMAT ( ' ''',A4,''' ',L1,' ''',A4,''''/1X,I8,I12/ & 4X,2F12.6,' 1.0'/4X,2F12.6,' 1.0'/2F8.2,' 20', & F12.6,2I2,' ''',A,''' ''NAME'' ''',A,'''') 967 FORMAT ( 18X,'30',F12.6,2I2,' ''',A,''' ''NAME'' ''',A,'''' ) 968 FORMAT ( 18X,'40',12X,2I2,' ''',A,''' ''NAME'' ''',A,''''/'$'/ & '$ Note: cannot make output boundary points here'/'$'/ & ' 0. 0. 0. 0. 0'/ & '$ -------------------------------------', & '------------------------------- $'/ & '$ End of input file ', & ' $'/ & '$ -------------------------------------', & '------------------------------- $') ! 969 FORMAT (/' Grid point inflation',F7.2,'%') ! 999 FORMAT(//' End of program '/ & ' ========================================='/ & ' WAVEWATCH III Grid splitting '/) ! 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' ERROR IN OPENING INPUT FILE'/ & ' IOSTAT =',I5/) ! 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' PREMATURE END OF INPUT FILE'/) ! 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' ERROR IN READING FROM INPUT FILE'/ & ' IOSTAT =',I5/) ! 1020 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' SPLITTING NOT AVAILABLE FOR GRID TYPE'/ & ' GTYPE =',I5/) ! 1021 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' GRID TYPE NOT RECOGNIZED'/ & ' GTYPE =',I5/) ! 1022 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' SPLITTING NOT AVAILABLE FOR CLOSURE TYPE'/ & ' ICLOSE =',I5/) ! 1023 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' CLOSURE TYPE NOT RECOGNIZED'/ & ' ICLOSE =',I5/) ! 1024 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' NO ACTIVE SEA POINT IN GRID'/) ! 1025 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' WRONG NUMBER OF SEA POINTS'/ & ' MINGRD, NSEA =',2I7/) ! 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' ILLEGAL PART OF COMMUNICATOR REQUESTED'/) ! 1050 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' SHOULD NOT HAVE ZERO GRID SIZE (',A,') ...'/) ! 1060 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' ERROR IN OPENING FILE ',A/ & ' IOSTAT =',I5/) ! 1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3GSPL : '/ & ' ERROR IN OPENING FILE ',A/ & ' IOSTAT =',I5/) ! !/T 9040 FORMAT ( 'TEST W3GSPL: CHECKERBOARD X-Y:',2I8) !/T 9041 FORMAT ( 'TEST W3GSPL: FILLING CHECKERBOARD TRY:',I3/ & !/T ' GRID, IGX0, IGXN, IGY0, IGYN, POINTS ') !/T 9042 FORMAT ( ' ',I6,2(2I8), I8,2X,A) !/T 9043 FORMAT ( 'TEST W3GSPL: CHECKERBOARD GRIDS:',I4,' (',I4,')') !/T 9044 FORMAT ( ' SMALLEST SIZE/GRID:',I8,I4) !/T 9045 FORMAT ( ' SMALLEST NEIGHBOR :',I8,I4) !/T 9046 FORMAT ( ' GRID',I4', MERGED WITH GRID',I4) !/T 9047 FORMAT ( ' ',I6,I8) !/T 9048 FORMAT ( ' GRID',I4', IS ISOLATED, LEFT UNCHANGED') !/T 9049 FORMAT ( 'TEST W3GSPL: CHECKERBOARD CONSOLIDATED ON',I4,' GRIDS') ! !/T 9050 FORMAT ( 'TEST W3GSPL',A,': MIN, MAX, STD:',2I8,F10.2) !/T 9051 FORMAT ( ' ',A,': MIN, MAX, STD:',2I8,F10.2) 9052 FORMAT ( 'TEST W3GSPL: STUCK ON ',A,' GRID SIZE') 9053 FORMAT ( ' OUT OF RANGE, PROCESSING (',F6.3,')') 9054 FORMAT ( ' IN RANGE, NO ACTION') !/ !/ Embedded subroutines ---------------------------------------------- / !/ CONTAINS !/ ------------------------------------------------------------------- / SUBROUTINE GRINFO !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 13-Sep-2012 | !/ +-----------------------------------+ !/ !/ 06-Sep-2012 : Origination. ( version 4.10 ) !/ 13-Sep-2012 : Option to exclude grids from stats. ( version 4.10 ) !/ ! 1. Purpose : ! ! Compile statistical info on all sub grids (no halo). ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: NOCNT, NOCNTM, NOCNTL, NGC, NSEAC !/S INTEGER, SAVE :: IENT = 0 REAL :: SUMSQR LOGICAL :: LEFT, RIGHT, THERE !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'GRINFO') ! ! 1. Initialization ------------------------------------------------- * ! GSTATS(:)%STRADLE = .FALSE. GSTATS(:)%NPTS = 0 GSTATS(:)%NXL = NX GSTATS(:)%NXH = 1 GSTATS(:)%NYL = NY GSTATS(:)%NYH = 1 ! ! 2. Get STRADLE, NGC ----------------------------------------------- * ! NGC = 0 ! DO IG=1, NG LEFT = .FALSE. RIGHT = .FALSE. IF ( GSTATS(IG)%INSTAT ) NGC = NGC + 1 DO IY=1, NY IF ( MSPLIT(IY, 1) .EQ. IG ) LEFT = .TRUE. IF ( MSPLIT(IY,NX) .EQ. IG ) RIGHT = .TRUE. END DO GSTATS(IG)%STRADLE = LEFT .AND. RIGHT END DO ! IF ( NGC .EQ. 0 ) THEN NGC = 1 DONE = .TRUE. END IF ! ! 3. Run grid stats ------------------------------------------------- * ! 3.a General ! DO IY=1, NY DO IX=1, NX IG = MSPLIT(IY,IX) IF ( MSPLIT(IY,IX) .GT. 0 ) THEN GSTATS(IG)%NPTS = GSTATS(IG)%NPTS + 1 GSTATS(IG)%NXL = MIN ( GSTATS(IG)%NXL , IX ) GSTATS(IG)%NXH = MAX ( GSTATS(IG)%NXH , IX ) GSTATS(IG)%NYL = MIN ( GSTATS(IG)%NYL , IY ) GSTATS(IG)%NYH = MAX ( GSTATS(IG)%NYH , IY ) END IF END DO END DO ! ! 3.b Stradled grids ! IF ( NG .GT. 1) THEN DO IG=1, NG IF ( GSTATS(IG)%STRADLE ) THEN NOCNT = 0 NOCNTM = 0 NOCNTL = 0 DO IX=1, NX THERE = .FALSE. DO IY=1, NY IF ( MSPLIT(IY,IX) .EQ. IG ) THEN THERE = .TRUE. EXIT END IF END DO IF ( THERE ) THEN NOCNT = 0 ELSE NOCNT = NOCNT + 1 IF ( NOCNT .GT. NOCNTM ) THEN NOCNTM = NOCNT NOCNTL = IX END IF END IF END DO GSTATS(IG)%NXL = NOCNTL + 1 GSTATS(IG)%NXH = NOCNTL - NOCNTM END IF END DO ELSE GSTATS(1)%STRADLE = .FALSE. END IF ! ! 3.c Corrected NSEA ! NSEAC = 0 ! DO IG=1, NG IF ( GSTATS(IG)%INSTAT ) NSEAC = NSEAC + GSTATS(IG)%NPTS END DO ! ! 4. Run overall stats ---------------------------------------------- * ! MSTATS%NMIN = NSEA + 1 MSTATS%NMAX = 0 XMEAN = REAL(NSEAC) / REAL(NGC) SUMSQR = 0. ! DO IG=1, NG IF ( .NOT. GSTATS(IG)%INSTAT ) CYCLE MSTATS%NMIN = MIN ( MSTATS%NMIN , GSTATS(IG)%NPTS ) MSTATS%NMAX = MAX ( MSTATS%NMAX , GSTATS(IG)%NPTS ) SUMSQR = SUMSQR + ( REAL(GSTATS(IG)%NPTS) - XMEAN )**2 END DO ! MSTATS%RSTD = SQRT ( SUMSQR / REAL(NGC) ) ! ! 5. Test output ---------------------------------------------------- * ! !/T1 WRITE (NDST,9000) !/T1 DO IG=1, NG !/T1 WRITE (NDST,9001) IG, GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & !/T1 GSTATS(IG)%NXL, GSTATS(IG)%NXH, & !/T1 GSTATS(IG)%NYL, GSTATS(IG)%NYH !/T1 END DO !/T1 WRITE (NDST,9010) MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD ! RETURN ! ! Formats ! !/T1 9000 FORMAT ( 'TEST GRINFO: J, STRADLE, NPTS,NXL-H, NYL-H') !/T1 9001 FORMAT ( ' ',I4,2X,L1,2X,I7,4I5) !/T1 9010 FORMAT ( 'TEST GRINFO: MIN, MAX, STD:',2I8,F10.2) ! !/ End of GRINFO ----------------------------------------------------- / !/ END SUBROUTINE GRINFO !/ ------------------------------------------------------------------- / SUBROUTINE GRTRIM !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 01-Feb-2013 | !/ +-----------------------------------+ !/ !/ 07-Sep-2012 : Origination. ( version 4.10 ) !/ 18-Sep-2012 : Include edge points of grid. ( version 4.10 ) !/ 01-Feb-2013 : Add dynamic trim range. ( version 4.10 ) !/ ! 1. Purpose : ! ! Trim edges of all grids where they are next to another grid or next ! to unassigned grid points. This is done in preparation for ! reassigning edges of grids to smaller adjacent grids. ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: ITARG, ITL, IPTS, MX, MY, ICIRC, NWDTH !/S INTEGER, SAVE :: IENT = 0 LOGICAL :: MASK(NY,NX) !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'GRTRIM') ! ITARG = NSEA / NG ! ! 1. Loop over grids ------------------------------------------------ * ! DO IG=1, NG ! IPTS = GSTATS(IG)%NPTS MY = 1 + GSTATS(IG)%NYH - GSTATS(IG)%NYL MX = 1 + GSTATS(IG)%NXH - GSTATS(IG)%NXL IF ( GSTATS(IG)%STRADLE ) MX = MX + NX ICIRC = 2 * ( MX + MY ) ! NWDTH = 1 ! ITL = MIN ( ITARG , MAX ( ITARG-2*ICIRC , 3*ICIRC ) ) IF ( IPTS .LT. ITL ) NWDTH = 0 ! IF ( IPTS.GT.ITARG ) THEN NWDTH = 1 + & MAX(0,+NINT((REAL((IPTS-ITARG))/REAL(ICIRC)-1.)/3.)) ENDIF ! DO J=1, NWDTH ! MASK = .FALSE. ! ! 2. Mark points to be removed -------------------------------------- * ! DO IX=2, NX-1 IF ( MSPLIT( 1,IX) .EQ. IG ) MASK( 1,IX) = & (SEA( 2,IX ).AND.(MSPLIT( 2,IX ).NE.IG)) & .OR. (SEA( 1,IX+1).AND.(MSPLIT( 1,IX+1).NE.IG)) & .OR. (SEA( 1,IX-1).AND.(MSPLIT( 1,IX-1).NE.IG)) DO IY=2, NY-1 IF ( MSPLIT(IY,IX) .EQ. IG ) MASK(IY,IX) = & (SEA(IY+1,IX ).AND.(MSPLIT(IY+1,IX ).NE.IG)) & .OR. (SEA(IY-1,IX ).AND.(MSPLIT(IY-1,IX ).NE.IG)) & .OR. (SEA(IY ,IX+1).AND.(MSPLIT(IY ,IX+1).NE.IG)) & .OR. (SEA(IY ,IX-1).AND.(MSPLIT(IY ,IX-1).NE.IG)) END DO IF ( MSPLIT(NY,IX) .EQ. IG ) MASK(NY,IX) = & (SEA(NY-1,IX ).AND.(MSPLIT(NY-1,IX ).NE.IG)) & .OR. (SEA(NY ,IX+1).AND.(MSPLIT(NY ,IX+1).NE.IG)) & .OR. (SEA(NY ,IX-1).AND.(MSPLIT(NY ,IX-1).NE.IG)) END DO ! IF ( GLOBAL ) THEN IF ( MSPLIT( 1, 1) .EQ. IG ) MASK( 1, 1) = & (SEA( 2, 1).AND.(MSPLIT( 2, 1).NE.IG)) & .OR. (SEA( 1, 2).AND.(MSPLIT( 1, 2).NE.IG)) & .OR. (SEA( 1,NX).AND.(MSPLIT( 1,NX).NE.IG)) IF ( MSPLIT( 1,NX) .EQ. IG ) MASK( 1,NX) = & (SEA( 2,NX ).AND.(MSPLIT( 2,NX ).NE.IG)) & .OR. (SEA( 1, 1 ).AND.(MSPLIT( 1, 1 ).NE.IG)) & .OR. (SEA( 1,NX-1).AND.(MSPLIT( 1,NX-1).NE.IG)) DO IY=2, NY-1 IF ( MSPLIT(IY, 1) .EQ. IG ) MASK(IY, 1) = & (SEA(IY+1, 1).AND.(MSPLIT(IY+1, 1).NE.IG)) & .OR. (SEA(IY-1, 1).AND.(MSPLIT(IY-1, 1).NE.IG)) & .OR. (SEA(IY , 2).AND.(MSPLIT(IY , 2).NE.IG)) & .OR. (SEA(IY ,NX).AND.(MSPLIT(IY ,NX).NE.IG)) IF ( MSPLIT(IY,NX) .EQ. IG ) MASK(IY,NX) = & (SEA(IY+1,NX).AND.(MSPLIT(IY+1,NX).NE.IG)) & .OR. (SEA(IY-1,NX).AND.(MSPLIT(IY-1,NX).NE.IG)) & .OR. (SEA(IY , 1).AND.(MSPLIT(IY , 1).NE.IG)) & .OR. (SEA(IY,NX-1).AND.(MSPLIT(IY,NX-1).NE.IG)) END DO IF ( MSPLIT(NY, 1) .EQ. IG ) MASK(NY, 1) = & (SEA(NY-1, 1).AND.(MSPLIT(NY-1, 1).NE.IG)) & .OR. (SEA(NY , 2).AND.(MSPLIT(NY , 2).NE.IG)) & .OR. (SEA(NY ,NX).AND.(MSPLIT(NY ,NX).NE.IG)) IF ( MSPLIT(NY,NX) .EQ. IG ) MASK(NY,NX) = & (SEA(NY-1,NX).AND.(MSPLIT(NY-1,NX).NE.IG)) & .OR. (SEA(NY , 1).AND.(MSPLIT(NY , 1).NE.IG)) & .OR. (SEA(NY,NX-1).AND.(MSPLIT(NY,NX-1).NE.IG)) ELSE IF ( MSPLIT( 1, 1) .EQ. IG ) MASK( 1, 1) = & (SEA( 2, 1).AND.(MSPLIT( 2, 1).NE.IG)) & .OR. (SEA( 1, 2).AND.(MSPLIT( 1, 2).NE.IG)) IF ( MSPLIT( 1,NX) .EQ. IG ) MASK( 1,NX) = & (SEA( 2,NX ).AND.(MSPLIT( 2,NX ).NE.IG)) & .OR. (SEA( 1,NX-1).AND.(MSPLIT( 1,NX-1).NE.IG)) DO IY=2, NY-1 IF ( MSPLIT(IY, 1) .EQ. IG ) MASK(IY, 1) = & (SEA(IY+1, 1).AND.(MSPLIT(IY+1, 1).NE.IG)) & .OR. (SEA(IY-1, 1).AND.(MSPLIT(IY-1, 1).NE.IG)) & .OR. (SEA(IY , 2).AND.(MSPLIT(IY , 2).NE.IG)) IF ( MSPLIT(IY,NX) .EQ. IG ) MASK(IY,NX) = & (SEA(IY+1,NX).AND.(MSPLIT(IY+1,NX).NE.IG)) & .OR. (SEA(IY-1,NX).AND.(MSPLIT(IY-1,NX).NE.IG)) & .OR. (SEA(IY,NX-1).AND.(MSPLIT(IY,NX-1).NE.IG)) END DO IF ( MSPLIT(NY, 1) .EQ. IG ) MASK(NY, 1) = & (SEA(NY-1, 1).AND.(MSPLIT(NY-1, 1).NE.IG)) & .OR. (SEA(NY , 2).AND.(MSPLIT(NY , 2).NE.IG)) IF ( MSPLIT(NY,NX) .EQ. IG ) MASK(NY,NX) = & (SEA(NY-1,NX).AND.(MSPLIT(NY-1,NX).NE.IG)) & .OR. (SEA(NY,NX-1).AND.(MSPLIT(NY,NX-1).NE.IG)) END IF ! ! 3. Remove marked points ------------------------------------------- * ! DO IX=1, NX DO IY=1, NY IF ( MASK(IY,IX) ) THEN MSPLIT(IY,IX) = -1 END IF END DO END DO ! ! ... End loops started in 1. ! END DO END DO ! RETURN ! ! Formats ! !/ End of GRTRIM ----------------------------------------------------- / !/ END SUBROUTINE GRTRIM !/ ------------------------------------------------------------------- / SUBROUTINE GRFILL ( ND ) !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 01-Feb-2013 | !/ +-----------------------------------+ !/ !/ 07-Sep-2012 : Origination. ( version 4.10 ) !/ 18-Sep-2012 : Include edge points of grid. ( version 4.10 ) !/ Add convergence check. !/ 29-Jan-2013 : Add error code on stop. ( version 4.10 ) !/ 29-Jan-2013 : Add error test output. ( version 4.10 ) !/ 01-Feb-2013 : Loop over selected sea points only. ( version 4.10 ) !/ ! 1. Purpose : ! ! Reassign unassigned grid points to grids, starting with the ! smallest grids. ! ! 3. Parameters : ! ! Parameter list ! ---------------------------------------------------------------- ! ND Int. I Depth of halo for first sweep. ! ---------------------------------------------------------------- ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ INTEGER, INTENT(IN) :: ND !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: NMIN, I, NDEPTH, NITT, NADD, IXL, IXR,& NLEFT, NRIGHT, NXL, NXH, NYL, NYH INTEGER :: NXYOFF = 3 INTEGER :: IIX(NSEA), IIY(NSEA), ISEA, NSEAL !/S INTEGER, SAVE :: IENT = 0 LOGICAL :: DONE(NG), MASK(NY,NX), FLOST(NG), & XFL(NX), YFL(NY) !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'GRFILL') ! ! 1. Loop to assure all reassigned ---------------------------------- * ! NDEPTH = ND NITT = 0 NLEFT = -1 FLOST = .FALSE. ! NSEAL = 0 DO IX=1, NX DO IY=1, NY IF ( MSPLIT(IY,IX) .EQ. -1 ) THEN NSEAL = NSEAL + 1 IIX(NSEAL) = IX IIY(NSEAL) = IY END IF END DO END DO ! DO NITT = NITT + 1 ! ! 2. Loop over all grids -------------------------------------------- * ! DONE = .FALSE. ! DO J=1, NG ! ! 3. Find smallest unprocessed grid --------------------------------- * ! NMIN = NSEA + 1 IG = 0 ! DO I=1, NG IF ( .NOT.DONE(I) .AND. GSTATS(I)%NPTS.LT.NMIN ) THEN IG = I NMIN = GSTATS(I)%NPTS END IF END DO ! DONE(IG) = .TRUE. ! !/T2 WRITE (NDST,9030) IG, J, NMIN ! ! 4. Loop for halos per grid ---------------------------------------- * ! DO, I=1, NDEPTH ! MASK = .FALSE. ! ! 5. Mark grid point for adding ------------------------------------- * ! DO ISEA=1, NSEAL IX = IIX(ISEA) IY = IIY(ISEA) IXL = 1 + MOD(IX-2+NX,NX) IXR = 1 + MOD(IX,NX) IF ( MSPLIT(IY,IX) .EQ. -1 ) MASK(IY,IX) = & ( MSPLIT(IY+1,IX ) .EQ. IG ) & .OR. ( MSPLIT(IY-1,IX ) .EQ. IG ) & .OR. ( MSPLIT(IY ,IXR) .EQ. IG ) & .OR. ( MSPLIT(IY ,IXL) .EQ. IG ) END DO ! ! 6. Add marked grid point ------------------------------------------ * ! NADD = 0 ! DO ISEA=1, NSEAL IX = IIX(ISEA) IY = IIY(ISEA) IF ( MASK(IY,IX) ) THEN MSPLIT(IY,IX) = IG NADD = NADD + 1 END IF END DO ! IF ( NADD .EQ. 0 ) EXIT ! ! ... End loop started in 4. ! END DO ! ! ... End loop started in 2. ! END DO ! NDEPTH = 1 ! ! 7. Check convergence ---------------------------------------------- * ! 7.a Find number of points left ! NRIGHT = NLEFT NLEFT = 0 ! DO ISEA=1, NSEAL IX = IIX(ISEA) IY = IIY(ISEA) IF ( MSPLIT(IY,IX) .EQ. -1 ) NLEFT = NLEFT + 1 END DO ! !/T2 WRITE (NDST,9070) NITT, NLEFT ! ! 7.b No point left, exit loop ! IF ( NLEFT .EQ. 0 ) EXIT ! ! 7.c Stuck with points left ! IF ( NRIGHT .GT. 0 ) THEN IF ( NLEFT .EQ. NRIGHT ) THEN ! ! 7.d Do lost point correction once ! IF ( .NOT. FLOST(IG) ) THEN CALL GRLOST FLOST(IG) = .TRUE. ELSE ! ! 7.e Got stuck for good, error message and ouput ! WRITE (NDSE,1000) IG, NITT, NLEFT ! XFL = .FALSE. YFL = .FALSE. ! DO ISEA=1, NSEAL IX = IIX(ISEA) IY = IIY(ISEA) IF ( MSPLIT(IY,IX) .EQ. -1 ) THEN XFL(MAX(1,IX-NXYOFF):MIN(NX,IX+NXYOFF)) = .TRUE. YFL(MAX(1,IY-NXYOFF):MIN(NY,IY+NXYOFF)) = .TRUE. END IF END DO ! NXL = 0 NXH = 0 DO IX=1, NX IF ( XFL(IX) .AND. NXL.EQ. 0 ) NXL = IX IF ( XFL(IX) .AND. IX.EQ. NX ) NXH = IX IF ( .NOT. XFL(IX) .AND. NXL.NE. 0 ) NXH = IX-1 IF ( NXH .NE. 0 ) THEN NYL = 0 NYH = 0 DO IY=1, NY IF ( YFL(IY) .AND. NYL.EQ. 0 ) NYL = IY IF ( YFL(IY) .AND. IY.EQ. NY ) NYH = IY IF ( .NOT. YFL(IY) .AND. NYL.NE. 0 ) & NYH = IY-1 IF ( NYH .NE. 0 ) THEN WRITE (NDST,1001) NXL, NXH, NYH, NYL DO I=NYH, NYL, -1 WRITE (NDST,1002) MSPLIT(I,NXL:NXH) END DO NYL = 0 NYH = 0 END IF END DO NXL = 0 NXH = 0 END IF END DO ! ! ... Stop program with error output ... ! STOP 01 ENDIF ! END IF END IF ! ! ... End loop started in 1. ! END DO ! RETURN ! ! Formats ! 1000 FORMAT (/' *** ERROR GRFILL : NO MORE CONVERGENCE, ', & 'NITT, NLEFT:',2I8,' ***'/) 1001 FORMAT ( ' MAP OUTPUT FOR GRID',I3,' AND X AND Y RANGE :',4I6/) 1002 FORMAT ( ' ',60I2) ! !/T2 9030 FORMAT ( 'TEST GRFILL: PROCESSING GRID',I5,' (',I5,')',I8) !/T2 9060 FORMAT ( 'TEST GRFILL: GRID, HALO, NADD :',I5,I2,I8) !/T2 9070 FORMAT ( 'TEST GRFILL: NITT, NLEFT :',2I6) ! !/ End of GRFILL ----------------------------------------------------- / !/ END SUBROUTINE GRFILL !/ ------------------------------------------------------------------- / SUBROUTINE GRLOST !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : .9-Jan-2013 | !/ +-----------------------------------+ !/ !/ 31-Jan-2013 : Origination. ( version 4.10 ) !/ ! 1. Purpose : ! ! Reassign unassigned grid points to gridsR. Dealing with lost ! point by finding clostst grids. ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: IX, IY, IOFF, JJX, JX, JY, IG, I !/S INTEGER, SAVE :: IENT = 0 INTEGER :: IFOUND(-1:NG) !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'GRLOST') ! ! 1. Loop over all grid points -------------------------------------- * ! DO IX=1, NX DO IY=1, NY ! IF ( MSPLIT(IY,IX) .EQ. -1 ) THEN ! ! 2. Find nearest grid(s) ------------------------------------------- * ! IOFF = 1 ! DO ! IFOUND = 0 DO JJX=IX-IOFF, IX+IOFF IF ( GLOBAL ) THEN JX = 1 + MOD(JJX-1+2*NX,NX) ELSE JX = JJX END IF IF ( JX.LT.1 .OR. JX.GT.NX ) CYCLE DO JY=IY-IOFF, IY+IOFF IF ( JY.LT.1 .OR. JY.GT.NY ) CYCLE IFOUND(MSPLIT(JY,JX)) = IFOUND(MSPLIT(JY,JX)) + 1 END DO END DO ! IG = 0 DO I=1, NG IF ( IFOUND(I) .GT. 0 ) THEN IG = I EXIT END IF END DO ! IF ( IG .NE. 0 ) THEN MSPLIT(IY,IX) = IG EXIT END IF ! IOFF = IOFF + 1 IF ( IOFF .GT. NX .AND. IOFF.GT.NY ) EXIT END DO ! ! ... End of loops and logic started in 1. ! END IF ! END DO END DO ! RETURN ! ! Formats ! !/ End of GRLOST ----------------------------------------------------- / !/ END SUBROUTINE GRLOST !/ ------------------------------------------------------------------- / SUBROUTINE GRSQRG !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 07-Sep-2012 | !/ +-----------------------------------+ !/ !/ 07-Sep-2012 : Origination. ( version 4.10 ) !/ ! 1. Purpose : ! ! Attemp to square-up grid by taking off grid point in outermost ! grid point in X and Y only, after which GRFILL is to be run to ! re-assign grid points, ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: MX, MY !/S INTEGER, SAVE :: IENT = 0 !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'GRSQRG') ! ! 1. Loop over grids ------------------------------------------------ * ! DO IG=1, NG ! MY = 1 + GSTATS(IG)%NYH - GSTATS(IG)%NYL MX = 1 + GSTATS(IG)%NXH - GSTATS(IG)%NXL IF ( GSTATS(IG)%STRADLE ) MX = MX + NX ! ! 2. Top ------------------------------------------------------------ * ! IF ( MY .GE. 5 ) THEN ! DO IX=1, NX IF (MSPLIT(GSTATS(IG)%NYH,IX) .EQ. IG ) & MSPLIT(GSTATS(IG)%NYH,IX) = -1 END DO ! ! 3. Bottom --------------------------------------------------------- * ! DO IX=1, NX IF (MSPLIT(GSTATS(IG)%NYL,IX) .EQ. IG ) & MSPLIT(GSTATS(IG)%NYL,IX) = -1 END DO ! END IF ! ! 4. Left ----------------------------------------------------------- * ! IF ( MX .GE. 5 ) THEN ! DO IY=GSTATS(IG)%NYL, GSTATS(IG)%NYH IF (MSPLIT(IY,GSTATS(IG)%NXL) .EQ. IG ) & MSPLIT(IY,GSTATS(IG)%NXL) = -1 END DO ! ! 5. Right ---------------------------------------------------------- * ! DO IY=GSTATS(IG)%NYH, GSTATS(IG)%NYH IF (MSPLIT(IY,GSTATS(IG)%NXH) .EQ. IG ) & MSPLIT(IY,GSTATS(IG)%NXH) = -1 END DO ! END IF ! ! ... End loop started in 1. ! END DO ! RETURN ! ! Formats ! !/ End of GRSQRG ----------------------------------------------------- / !/ END SUBROUTINE GRSQRG !/ ------------------------------------------------------------------- / SUBROUTINE GRSNGL ( OK ) !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 09-Sep-2012 | !/ +-----------------------------------+ !/ !/ 09-Sep-2012 : Origination. ( version 4.10 ) !/ ! 1. Purpose : ! ! Remove points from a grid that are in the middle of the sea, but ! that have omly one adjacent point in the same grid. Directly ! select a new grid for this point rather than deactivate and use ! GRFILL. ! ! 3. Parameters : ! ! Parameter list ! ---------------------------------------------------------------- ! OK Log. I/O Flag for grid status, .F. if values of ! -1 are left in MSPLIT. ! ---------------------------------------------------------------- ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ LOGICAL, INTENT(INOUT) :: OK !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: NX0, NXN, IXL, IXH, COUNT(-1:NG), & INEW1, INEW2, INEW !/S INTEGER, SAVE :: IENT = 0 !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'GRSNGL') ! ! 1. Set up looping ------------------------------------------------- * ! IF ( GLOBAL ) THEN NX0 = 1 NXN = NX ELSE NX0 = 2 NXN = NX-1 END IF ! ! 2. Loops over 2D grid --------------------------------------------- * ! DO IX=NX0, NXN ! IXL = IX - 1 IXH = IX + 1 IF ( IX .EQ. 1 ) IXL = NX IF ( IX .EQ. NX ) IXH = 1 ! DO IY=2, NY-1 ! ! 3. Central sea points only ---------------------------------------- * ! IF ( SEA(IY,IX) .AND. SEA(IY-1,IX ) .AND. SEA(IY+1,IX ) & .AND. SEA(IY ,IXL) .AND. SEA(IY ,IXH) ) THEN ! ! 4. Check for 'lost points' ---------------------------------------- * ! COUNT = 0 IG = MSPLIT(IY,IX) ! COUNT(IG) = 1 COUNT(MSPLIT(IY-1,IX )) = COUNT(MSPLIT(IY-1,IX )) + 1 COUNT(MSPLIT(IY+1,IX )) = COUNT(MSPLIT(IY+1,IX )) + 1 COUNT(MSPLIT(IY ,IXL)) = COUNT(MSPLIT(IY ,IXL)) + 1 COUNT(MSPLIT(IY ,IXH)) = COUNT(MSPLIT(IY ,IXH)) + 1 ! IF ( COUNT(IG) .LE. 2 ) THEN ! !/T3 WRITE (NDST,9040) IX, IY, IG ! INEW1 = -1 INEW2 = -1 ! DO J=1, NG IF ( COUNT(J) .GE. 2 ) THEN !/T3 WRITE (NDST,9041) J IF ( INEW1 .EQ. -1 ) THEN INEW1 = J ELSE INEW2 = J EXIT END IF END IF END DO ! IF ( INEW1 .EQ. -1 ) THEN INEW = -1 OK = .FALSE. !/T3 WRITE (NDST,9043) ELSE IF ( INEW2 .EQ. -1 ) THEN INEW = INEW1 !/T3 WRITE (NDST,9042) INEW ELSE IF ( GSTATS(INEW1)%NPTS .GT. & GSTATS(INEW2)%NPTS ) THEN INEW = INEW2 ELSE INEW = INEW1 END IF !/T3 WRITE (NDST,9042) INEW END IF ! MSPLIT(IY,IX) = INEW ! END IF ! END IF ! ! ... End loops started in 2. ! END DO ! END DO ! RETURN ! ! Formats ! !/T3 9040 FORMAT ( 'TEST GRSNGL: POINT FOUND, IX, IY, IG:',2I5,I4) !/T3 9041 FORMAT ( ' CANDIDATE GRID :',10X,I4) !/T3 9042 FORMAT ( ' GRID USED :',10X,I4) !/T3 9043 FORMAT ( ' GRID LEFT UNDIFINED') ! !/ End of GRSNGL ----------------------------------------------------- / !/ END SUBROUTINE GRSNGL !/ ------------------------------------------------------------------- / SUBROUTINE GRSEPA ( OK, FRAC ) !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 01-Feb-2013 | !/ +-----------------------------------+ !/ !/ 10-Sep-2012 : Origination. ( version 4.10 ) !/ 18-Sep-2012 : Include edge points of grid. ( version 4.10 ) !/ 01-Feb-2013 : Much faster algorithms. ( version 4.10 ) !/ ! 1. Purpose : ! ! Remove smller parts of a grid that are separated from the main ! body, and that can be attached to other grids. ! ! 3. Parameters : ! ! Parameter list ! ---------------------------------------------------------------- ! OK Log. I/O Flag for grid status, .F. if values of ! -1 are left in MSPLIT. ! FRAC Real I Fraction of average size used to remove grid ! part. ! ---------------------------------------------------------------- ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ REAL, INTENT(IN) :: FRAC LOGICAL, INTENT(INOUT) :: OK !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: IPAVG, IPCHCK, ID, IPTOT, IX, IY, & IXL, IYL, IDL, JX, JY, KY, IPT, & IXH, IYH, I, J, K, L, IMIN, LMIN !/S INTEGER, SAVE :: IENT = 0 INTEGER :: GMASK(NY,NX), IIX(NSEA), IIY(NSEA) INTEGER, ALLOCATABLE :: PMAP(:), INGRD(:) LOGICAL :: PREV LOGICAL,ALLOCATABLE :: FLNEXT(:), NEXTTO(:,:) !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'GRSEPA') ! IPAVG = NINT ( REAL(NSEA) / REAL(NG) ) IPCHCK = NINT ( FRAC * REAL(NSEA) / REAL(NG) ) ! !/T4 WRITE (NDST,9000) IPAVG, IPCHCK ! ! 1. Loop over grids ------------------------------------------------ * ! DO IG=1, NG ! GMASK = 0 ID = 0 ! !/T4 WRITE (NDST,9010) IG ! ! 2. Find all parts ------------------------------------------------- * ! 2.a First loop, partial parts ! IPTOT = 0 ! DO IX=1, NX ! IXL = 1 + MOD(IX-2+NX,NX) PREV = .FALSE. ! DO IY=1, NY IF (MSPLIT(IY,IX) .EQ. IG ) THEN IPTOT = IPTOT + 1 IIX(IPTOT) = IX IIY(IPTOT) = IY IF ( .NOT. PREV) THEN ID = ID + 1 PREV = .TRUE. END IF GMASK(IY,IX) = ID ELSE IF ( PREV ) THEN PREV = .FALSE. IDL = 0 DO JY=IY-1, 1, -1 IF ( GMASK(JY,IX) .EQ. 0 ) EXIT IF ( GMASK(JY,IXL).NE.0 .AND. IDL.EQ.0 ) & IDL = GMASK(JY,IXL) END DO IF ( IDL .NE. 0 ) THEN DO KY=JY+1, IY-1 IF ( GMASK(KY,IX).EQ.ID ) GMASK(KY,IX) = IDL END DO ID = ID - 1 END IF ! END IF END DO END DO ! ! 2.b Grid too small, do not cut ! IF ( IPTOT .LE. IPAVG ) THEN !/T4 WRITE (NDST,9020) IPTOT, IPAVG CYCLE END IF ! ! 2.c Neighbouring grid parts ! Raw data ! ALLOCATE ( NEXTTO(0:ID,0:ID), PMAP(0:ID) ) NEXTTO = .FALSE. ! DO IPT=1, IPTOT IX = IIX(IPT) IY = IIY(IPT) IXL = 1 + MOD(IX-2+NX,NX) IYL = IY - 1 IXH = 1 + MOD(IX,NX) IYH = IY + 1 NEXTTO( GMASK(IY,IX) , GMASK(IY ,IXL) ) = .TRUE. NEXTTO( GMASK(IY,IX) , GMASK(IY ,IXH) ) = .TRUE. NEXTTO( GMASK(IY,IX) , GMASK(IYL,IX ) ) = .TRUE. NEXTTO( GMASK(IY,IX) , GMASK(IYH,IX ) ) = .TRUE. END DO ! ! Make symmetric ! DO I=1, ID DO J=1, ID NEXTTO(I,J) = NEXTTO(I,J) .OR. NEXTTO(J,I) END DO END DO ! ! Connect accross neighbours ! DO I=1, ID DO J=1, ID IF ( NEXTTO(I,J) ) THEN DO K=1, ID IF ( NEXTTO(K,J) ) THEN NEXTTO(K,I) = .TRUE. NEXTTO(I,K) = .TRUE. END IF END DO END IF END DO END DO ! ! Map the parts ! IDL = ID PMAP = 0 ID = 0 ! DO I=1, IDL IF ( PMAP(I) .EQ. 0 ) THEN ID = ID + 1 DO J=1, IDL IF ( NEXTTO(J,I) ) EXIT END DO IF ( J .GT. IDL ) THEN PMAP(I) = ID ELSE DO K=I, IDL IF ( PMAP(K).EQ.0 .AND. NEXTTO(J,K) ) PMAP(K) = ID END DO END IF END IF END DO ! DEALLOCATE ( NEXTTO ) ! ! 3. Grid is contiguous --------------------------------------------- * ! IF ( ID .EQ. 1 ) THEN !/T4 WRITE (NDST,9030) IG DEALLOCATE ( PMAP ) CYCLE END IF ! ! 4. Grid is split, get stats --------------------------------------- * ! !/T4 WRITE (NDST,9040) IG ! ! 4.a Construct final map for grid ! DO IPT=1, IPTOT IX = IIX(IPT) IY = IIY(IPT) GMASK(IY,IX) = PMAP(GMASK(IY,IX)) END DO ! DEALLOCATE ( PMAP ) ! ! 4.b Run stats ! ALLOCATE ( INGRD(ID), FLNEXT(ID) ) INGRD = 0 FLNEXT = .FALSE. IPTOT = 0 ! DO JX=1, NX DO JY=1, NY IF ( GMASK(JY,JX) .GT. 0 ) THEN INGRD(GMASK(JY,JX)) = INGRD(GMASK(JY,JX)) + 1 IPTOT = IPTOT + 1 END IF END DO END DO ! DO JX=1, NX DO JY=1, NY-1 IF ( ( GMASK(JY ,JX) .GT. 0 ) .AND. & ( SEA(JY+1,JX) .AND. MSPLIT(JY+1,JX).NE.IG ) ) & FLNEXT(GMASK(JY ,JX)) = .TRUE. IF ( ( GMASK(JY+1,JX) .GT. 0 ) .AND. & ( SEA(JY ,JX) .AND. MSPLIT(JY ,JX).NE.IG ) ) & FLNEXT(GMASK(JY+1,JX)) = .TRUE. END DO END DO ! DO JY=1, NY DO JX=1, NX-1 IF ( ( GMASK(JY,JX ) .GT. 0 ) .AND. & ( SEA(JY,JX+1) .AND. MSPLIT(JY,JX+1).NE.IG ) ) & FLNEXT(GMASK(JY,JX )) = .TRUE. IF ( ( GMASK(JY,JX+1) .GT. 0 ) .AND. & ( SEA(JY,JX ) .AND. MSPLIT(JY,JX ).NE.IG ) ) & FLNEXT(GMASK(JY,JX+1)) = .TRUE. END DO IF ( GLOBAL ) THEN IF ( ( GMASK(JY,NX) .GT. 0 ) .AND. & ( SEA(JY, 1) .AND. MSPLIT(JY, 1).NE.IG ) ) & FLNEXT(GMASK(JY,NX)) = .TRUE. IF ( ( GMASK(JY, 1) .GT. 0 ) .AND. & ( SEA(JY,NX) .AND. MSPLIT(JY,NX).NE.IG ) ) & FLNEXT(GMASK(JY, 1)) = .TRUE. END IF END DO ! !/T4 DO J=1, ID !/T4 WRITE (NDST,9041) J, INGRD(J), FLNEXT(J) !/T4 END DO ! ! 5. Grid large enough, find smallest part -------------------------- * ! IMIN = NSEA LMIN = 0 ! DO J=1, ID IF ( FLNEXT(J) .AND. INGRD(J).LT.IMIN ) THEN IMIN = INGRD(J) LMIN = J END IF END DO ! IF ( LMIN .EQ. 0 ) THEN !/T4 WRITE (NDST,9050) DEALLOCATE ( INGRD, FLNEXT ) CYCLE END IF ! IF ( IMIN .GT. IPCHCK ) THEN !/T4 WRITE (NDST,9051) DEALLOCATE ( INGRD, FLNEXT ) CYCLE END IF ! ! 6. Part to cut has been identified -------------------------------- * ! !/T4 WRITE (NDST,9060) LMIN ! DO JX=1, NX DO JY=1, NY IF ( GMASK(JY,JX) .EQ. LMIN ) MSPLIT(JY,JX) = -1 END DO END DO ! DEALLOCATE ( INGRD, FLNEXT ) OK = .FALSE. ! ! ... End loops started in 1. ! END DO ! RETURN ! ! Formats ! !/T4 9000 FORMAT ( 'TEST GRSEPA: IPAVG/CHCK:',2I8) !/T4 9010 FORMAT ( 'TEST GRSEPA: WORKING ON GRID'I4) !/T4 9020 FORMAT ( ' GRID TOO SMALL TO CUT',2I8) !/T4 9030 FORMAT ( 'TEST GRSEPA: GRID',I4,' IS CONTIGUOUS') !/T4 9040 FORMAT ( 'TEST GRSEPA: GRID',I4,' CONTAINS PARTS') !/T4 9041 FORMAT ( ' PART, SIZE, NEIGHBOUR:',I4,I8,L4) !/T4 9050 FORMAT ( ' NO PART NEXT TO OTHER') !/T4 9051 FORMAT ( ' NO PART SMALL ENOUGH') !/T4 9060 FORMAT ( ' CUTTING PART',I4) ! !/ End of GRSEPA ----------------------------------------------------- / !/ END SUBROUTINE GRSEPA !/ ------------------------------------------------------------------- / SUBROUTINE GRFSML !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 04-Feb-2013 | !/ +-----------------------------------+ !/ !/ 13-Sep-2012 : Origination. ( version 4.10 ) !/ 04-Feb-2013 : Bug fix grid splitting. ( version 4.10 ) !/ ! 1. Purpose : ! ! Subroutine called when lowest grid size is stuck. Attempting to ! joint to neighbor grid, otherwise mark as accepted small grid. ! note that small grid does not influence parallel scaling like a ! big grid does ..... ! ! 1-Feb-2013: Also used for early small-grid merging. ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: NSMALL, IGMIN(NG), NNEXT, JG, IGADD, & IGTEST, FREE(NG), NFREE, NBIG, IGB, & MX, MY, NX0, NXN, NY0, NYN, JX !/T5 INTEGER :: NXNT !/S INTEGER, SAVE :: IENT = 0 CHARACTER(LEN=1) :: NEXTTO(0:NG,0:NG), TEMP(NG) !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'GRFSML') ! ! 1. Find small(s) -------------------------------------------------- * ! NSMALL = 0 IGMIN = 0 ! DO IG=1,NG IF ( GSTATS(IG)%INSTAT .AND. & GSTATS(IG)%NPTS .EQ. MSTATS%NMIN ) THEN NSMALL = NSMALL + 1 IGMIN(NSMALL) = IG END IF END DO ! !/T5 WRITE (NDST,9010) NSMALL, IGMIN(:NSMALL) ! ! 2. Find neighbours ------------------------------------------------ * ! NEXTTO = '.' ! DO IX=1, NX-1 DO IY=1, NY-1 NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY+1,IX )) = 'X' NEXTTO(MSPLIT(IY+1,IX ),MSPLIT(IY ,IX )) = 'X' NEXTTO(MSPLIT(IY ,IX+1),MSPLIT(IY ,IX )) = 'X' NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY ,IX+1)) = 'X' END DO END DO ! IF ( GLOBAL ) THEN DO IY=1, NY-1 NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY+1,NX)) = 'X' NEXTTO(MSPLIT(IY+1,NX),MSPLIT(IY ,NX)) = 'X' NEXTTO(MSPLIT(IY , 1),MSPLIT(IY ,NX)) = 'X' NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY , 1)) = 'X' END DO END IF ! DO IG=0,NG NEXTTO(IG,IG) = '-' END DO ! !/T5 WRITE (NDST,9020) !/T5 DO IG=1, NG !/T5 TEMP = NEXTTO(IG,1:) !/T5 WRITE (NDST,9021) IG, TEMP !/T5 END DO ! ! 3. Loop over small grids ------------------------------------------ * ! FREE = 0 NFREE = 0 ! DO J=1, NSMALL ! !/T5 WRITE (NDST,9030) IGMIN(J) ! ! 3.a Find neighbours ! IG = IGMIN(J) IGADD = 0 IGTEST = NSEA + 1 NNEXT = 0 DO JG=1, NG IF ( NEXTTO(IG,JG) .EQ. 'X' ) THEN NNEXT = NNEXT + 1 IF ( GSTATS(JG)%NPTS .LT. IGTEST ) THEN IGTEST = GSTATS(JG)%NPTS IGADD = JG END IF END IF END DO ! !/T5 WRITE (NDST,9031) NNEXT ! ! 3.b No neighbours found, mark as 'not to be processed further' ! IF ( NNEXT .EQ. 0 ) THEN GSTATS(IG)%INSTAT = .FALSE. !/T5 WRITE (NDST,9032) IG ELSE ! ! 3.c Check smallest neighbor ! !/T5 WRITE (NDST,9033) IGADD, IGTEST, IGTEST+INGMIN, NINT(XMEAN) ! IF ( IGTEST + INGMIN .LT. NINT(XMEAN) ) THEN ! ! ... Merge grids ! DO IX=1, NX DO IY=1, NY IF ( MSPLIT(IY,IX) .EQ. IG ) MSPLIT(IY,IX) = IGADD END DO END DO ! NFREE = NFREE + 1 FREE(NFREE) = IG ! ELSE ! ! ... Remove grid(s) from stats ! !/T5 WRITE (NDST,9034) ! GSTATS(IG)%INSTAT = .FALSE. !/T5 WRITE (NDST,9032) IG NNEXT = 0 DO JG=1, NG IF ( NEXTTO(IGADD,JG) .EQ. 'X' ) NNEXT = NNEXT + 1 END DO IF ( NNEXT .EQ. 1 ) THEN GSTATS(IGADD)%INSTAT = .FALSE. !/T5 WRITE (NDST,9032) IGADD END IF ! END IF ! END IF ! END DO ! ! 4. Make new grids as needed --------------------------------------- * ! !/T5 WRITE (NDST,9040) NFREE ! DO J=1, NFREE ! !/T5 WRITE (NDST,9041) FREE(J) ! ! 4.a Find biggest grid ! NBIG = 0 IGB = 0 ! DO IG=1, NG IF ( GSTATS(IG)%NPTS .GT. NBIG ) THEN NBIG = GSTATS(IG)%NPTS IGB = IG END IF END DO ! ! 4.a Split biggest grid ! NX0 = GSTATS(IGB)%NXL NXN = GSTATS(IGB)%NXH NY0 = GSTATS(IGB)%NYL NYN = GSTATS(IGB)%NYH ! MY = 1 + GSTATS(IGB)%NYH - GSTATS(IGB)%NYL MX = 1 + GSTATS(IGB)%NXH - GSTATS(IGB)%NXL IF ( GSTATS(IGB)%STRADLE ) MX = MX + NX ! IF ( MY .GE. MX ) THEN !/T5 WRITE (NDST,9042) IGB, 'VERTICAL', MX, MY NYN = NY0 + MY/2 ELSE !/T5 WRITE (NDST,9042) IGB, 'HORIZONTAL', MX, MY NXN = NX0 + MX/2 !/T5 NXNT = 1 + MOD(NXN-1,NX) END IF !/T5 WRITE (NDST,9043) GSTATS(IGB)%NXL, GSTATS(IGB)%NXH, & !/T5 GSTATS(IGB)%NYL, GSTATS(IGB)%NYH, & !/T5 GSTATS(IGB)%STRADLE, NX0, NXN, NY0, NYN ! DO IX=NX0, NXN JX = 1 + MOD(IX-1,NX) DO IY=NY0, NYN IF ( MSPLIT(IY,JX) .EQ. IGB ) MSPLIT(IY,JX) = FREE(J) END DO END DO ! GSTATS(IGB)%NPTS = 0 GSTATS(FREE(J))%NPTS = 0 ! END DO ! RETURN ! ! Formats ! !/T5 9010 FORMAT ( 'TEST GRFSML:',I2,' SMALL GRIDS:',10I4) !/T5 9020 FORMAT ( 'TEST GRFSML: NEIGHBOUR MAP PER GRID') !/T5 9021 FORMAT (2X,I3,2X,120A1) !/T5 9030 FORMAT ( 'TEST GRFSML: PROCESSING SMALL GRID',I4) !/T5 9031 FORMAT ( ' GRID HAS',I3,' NEIGHBOURS') !/T5 9032 FORMAT ( ' REMOVED GRID',I4,' FROM STATS') !/T5 9033 FORMAT ( ' SMALLEST NEIGHBOUR AND SIZE',I4,I6/ & !/T5 ' SIZE OF COMBINED GRIDS',I8,' (',I8,')') !/T5 9034 FORMAT ( ' GRIDS TOO LARGE TO MERGE') !/T5 9040 FORMAT ( 'TEST GRFSML: GENERATING',I3,' NEW GRIDS') !/T5 9041 FORMAT ( ' MAKING GRID NR.:',I4) !/T5 9042 FORMAT ( ' SPLITTING GRID',I3,' ',A,', MX,MY:',2I6) !/T5 9043 FORMAT ( ' OLD RANGE :',4I6,L4/ & !/T5 ' NEW RANGE :',4I6) ! !/ End of GRFSML ----------------------------------------------------- / !/ END SUBROUTINE GRFSML !/ ------------------------------------------------------------------- / SUBROUTINE GRFLRG !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 29-Jan-2013 | !/ +-----------------------------------+ !/ !/ 19-Sep-2012 : Origination. ( version 4.10 ) !/ 29-Jan-2013 : Add error code on stop. ( version 4.10 ) !/ ! 1. Purpose : ! ! Like GRFSML for largest grid ... ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: NBIG, IGMAX(NG), NNEXT, JG !!! INTEGER :: NSMALL, IGMIN(NG), NNEXT, JG, IGADD, & !!! IGTEST, FREE(NG), NFREE, NBIG, IGB, & !!! MX, MY, NX0, NXN, NY0, NYN !!!!/S INTEGER, SAVE :: IENT = 0 CHARACTER(LEN=1) :: NEXTTO(0:NG,0:NG), TEMP(NG) !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'GRFLRG') ! ! 1. Find big(s) ---------------------------------------------------- * ! NBIG = 0 IGMAX = 0 ! DO IG=1,NG IF ( GSTATS(IG)%INSTAT .AND. & GSTATS(IG)%NPTS .EQ. MSTATS%NMAX ) THEN NBIG = NBIG + 1 IGMAX(NBIG) = IG END IF END DO ! !/T6 WRITE (NDST,9010) NBIG, IGMAX(:NBIG) ! ! 2. Find neighbours ------------------------------------------------ * ! NEXTTO = '.' ! DO IX=1, NX-1 DO IY=1, NY-1 NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY+1,IX )) = 'X' NEXTTO(MSPLIT(IY+1,IX ),MSPLIT(IY ,IX )) = 'X' NEXTTO(MSPLIT(IY ,IX+1),MSPLIT(IY ,IX )) = 'X' NEXTTO(MSPLIT(IY ,IX ),MSPLIT(IY ,IX+1)) = 'X' END DO END DO ! IF ( GLOBAL ) THEN DO IY=1, NY-1 NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY+1,NX)) = 'X' NEXTTO(MSPLIT(IY+1,NX),MSPLIT(IY ,NX)) = 'X' NEXTTO(MSPLIT(IY , 1),MSPLIT(IY ,NX)) = 'X' NEXTTO(MSPLIT(IY ,NX),MSPLIT(IY , 1)) = 'X' END DO END IF ! DO IG=0,NG NEXTTO(IG,IG) = '-' END DO ! !/T6 WRITE (NDST,9020) !/T6 DO IG=1, NG !/T6 TEMP = NEXTTO(IG,1:) !/T6 WRITE (NDST,9021) IG, TEMP !/T6 END DO ! ! 3. Loop over big grids -------------------------------------------- * ! DO J=1, NBIG ! !/T6 WRITE (NDST,9030) IGMAX(J) ! ! 3.a Find neighbours ! IG = IGMAX(J) NNEXT = 0 DO JG=1, NG IF ( NEXTTO(IG,JG) .EQ. 'X' ) NNEXT = NNEXT + 1 END DO ! !/T6 WRITE (NDST,9031) NNEXT ! ! 3.b Enough neighbours found, mark as 'not to be processed further' ! IF ( NNEXT .GE. 1 ) THEN GSTATS(IG)%INSTAT = .FALSE. !/T6 WRITE (NDST,9032) ELSE ! ! 3.c Biggest grid is isolated, should split ! WRITE (NDSE,930) STOP 11 ! END IF ! END DO ! RETURN ! ! Formats ! 930 FORMAT ( ' *** ERROR GRFLRG: LARGEST GRID IS ISOLATED ***' & ' SPLITTING NOT YET IMPLEMENTED '/) ! !/T6 9010 FORMAT ( 'TEST GRFLRG:',I2,' BIG GRIDS:',10I4) !/T6 9020 FORMAT ( 'TEST GRFLRG: NEIGHBOUR MAP PER GRID') !/T6 9021 FORMAT (2X,I3,2X,120A1) !/T6 9030 FORMAT ( 'TEST GRFLRG: PROCESSING BIG GRID',I4) !/T6 9031 FORMAT ( ' GRID HAS',I3,' NEIGHBOURS') !/T6 9032 FORMAT ( ' NO ACTION') ! !/ End of GRFLRG ----------------------------------------------------- / !/ END SUBROUTINE GRFLRG !/ ------------------------------------------------------------------- / SUBROUTINE GR1GRD !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 18-Nov-2012 | !/ +-----------------------------------+ !/ !/ 23-Sep-2012 : Origination. ( version 4.10 ) !/ 24-Jan-2013 : Correct X0 to be in range. ( version 4.10 ) !/ 04-Feb-2013 : Add corner point to halo. ( version 4.10 ) !/ 18-Nov-2012 : Add user-defined halo extension. ( version 4.14 ) !/ ! 1. Purpose : ! ! Extract single grid from master map, including halo needed for ! grid overlap in ww3_multi. ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: NIT, IIT, IXL, IXH, IYL, IYH, NOCNT,& NOCNTM, NOCNTL, JX, JY, ISEA, MX, MY INTEGER :: MTMP2(NY,NX) !/S INTEGER, SAVE :: IENT = 0 REAL :: XOFF LOGICAL :: MASK(NY,NX), LEFT, RIGHT, THERE !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'GR1GRD') ! !/T7 WRITE (NDST,9000) IG ! ! 1. Set up MTEMP with MAPSTA 0,1,3 for grid ------------------------ * ! DO IX=1, NX DO IY=1, NY IF ( MSPLIT(IY,IX) .EQ. IG ) THEN MTEMP(IY,IX) = 1 ELSE IF ( MSPLIT(IY,IX) .GT. 0 ) THEN MTEMP(IY,IX) = 3 ELSE MTEMP(IY,IX) = 0 END IF END DO END DO ! ! 2. Add ALL MAPSTA = 2 points to grid ------------------------------ * ! DO IX=1, NX DO IY=1, NY IF ( MAPSTA(IY,IX) .EQ. 2 ) THEN MTEMP(IY,IX) = 2 END IF END DO END DO ! ! 3. Add halo ------------------------------------------------------- * ! 3.a Set up halo width depending on scheme and time steps ! NEEDED TO SET UP A LITTLE WIDER. NOT SURE WHY. NEED TO CHECK WITH ! WMEQL SUBROUTINE. ! !/PR0 NIT = 0 !/PR1 NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 !/UQ NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 !/UNO NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 ! ! 3.b Exand halo ! DO IIT=1, NIT ! MASK = .FALSE. ! DO IX=1, NX IXL = 1 + MOD(IX-2+NX,NX) IXH = 1 + MOD(IX,NX) DO IY=2, NY-1 IF ( MTEMP(IY,IX) .EQ. 3 ) MASK(IY,IX) = & ( ( MTEMP(IY+1,IX ) .EQ. 1 ) .OR. & ( MTEMP(IY-1,IX ) .EQ. 1 ) .OR. & ( MTEMP(IY ,IXH) .EQ. 1 ) .OR. & ( MTEMP(IY ,IXL) .EQ. 1 ) ) & .OR. ( ( MTEMP(IY+1,IXL) .EQ. 1 ) .AND. & ( ( MTEMP(IY ,IXL) .EQ. 1 ) .OR. & ( MTEMP(IY+1,IX ) .EQ. 1 ) ) ) & .OR. ( ( MTEMP(IY+1,IXH) .EQ. 1 ) .AND. & ( ( MTEMP(IY ,IXH) .EQ. 1 ) .OR. & ( MTEMP(IY+1,IX ) .EQ. 1 ) ) ) & .OR. ( ( MTEMP(IY-1,IXH) .EQ. 1 ) .AND. & ( ( MTEMP(IY ,IXH) .EQ. 1 ) .OR. & ( MTEMP(IY-1,IX ) .EQ. 1 ) ) ) & .OR. ( ( MTEMP(IY-1,IXL) .EQ. 1 ) .AND. & ( ( MTEMP(IY ,IXL) .EQ. 1 ) .OR. & ( MTEMP(IY-1,IX ) .EQ. 1 ) ) ) END DO END DO ! DO IX=1, NX DO IY=1, NY IF ( MASK(IY,IX) ) MTEMP(IY,IX) = 1 END DO END DO ! END DO ! ! 3.c Contract halo ! ! MTMP2 = MTEMP ! ! DO IIT=1, NIT ! ! MASK = .FALSE. ! ! DO IX=1, NX ! IXL = 1 + MOD(IX-2+NX,NX) ! IXH = 1 + MOD(IX,NX) ! DO IY=2, NY-1 ! IF ( MTMP2(IY,IX) .EQ. 1 ) MASK(IY,IX) = & ! ( ( MTMP2(IY+1,IX ) .EQ. 3 ) .OR. & ! ( MTMP2(IY-1,IX ) .EQ. 3 ) .OR. & ! ( MTMP2(IY ,IXH) .EQ. 3 ) .OR. & ! ( MTMP2(IY ,IXL) .EQ. 3 ) ) & ! .OR. ( ( MTMP2(IY+1,IXL) .EQ. 3 ) .AND. & ! ( ( MTMP2(IY ,IXL) .EQ. 3 ) .OR. & ! ( MTMP2(IY+1,IX ) .EQ. 3 ) ) ) & ! .OR. ( ( MTMP2(IY+1,IXH) .EQ. 3 ) .AND. & ! ( ( MTMP2(IY ,IXH) .EQ. 3 ) .OR. & ! ( MTMP2(IY+1,IX ) .EQ. 3 ) ) ) & ! .OR. ( ( MTMP2(IY-1,IXH) .EQ. 3 ) .AND. & ! ( ( MTMP2(IY ,IXH) .EQ. 3 ) .OR. & ! ( MTMP2(IY-1,IX ) .EQ. 3 ) ) ) & ! .OR. ( ( MTMP2(IY-1,IXL) .EQ. 3 ) .AND. & ! ( ( MTMP2(IY ,IXL) .EQ. 3 ) .OR. & ! ( MTMP2(IY-1,IX ) .EQ. 3 ) ) ) ! END DO ! END DO ! ! DO IX=1, NX ! DO IY=1, NY ! IF ( MASK(IY,IX) ) MTMP2(IY,IX) = 3 ! END DO ! END DO ! ! END DO ! ! 3.d Check if consistent ..... ! ! DO IX=1, NX ! DO IY=1, NY ! IF ( MSPLIT(IY,IX).EQ.IG .OR. MTMP2(IY,IX).EQ.1 ) THEN ! IF ( MSPLIT(IY,IX).EQ.IG .AND. MTMP2(IY,IX).NE.1 ) THEN ! write (ndst,*) ix, iy, ' in grid, not in e-c grid' ! END IF ! IF ( MSPLIT(IY,IX).NE.IG .AND. MTMP2(IY,IX).EQ.1 ) THEN ! write (ndst,*) ix, iy, ' in e-c grid, not in grid' ! END IF ! END IF ! END DO ! END DO ! ! 4. Remove extraeneous MAPSTA = 2 ---------------------------------- * ! DO IX=1, NX ! IF ( GLOBAL ) THEN IXL = 1 + MOD(IX-2+NX,NX) IXH = 1 + MOD(IX,NX) ELSE IXL = MAX ( 1 , IX-1 ) IXH = MIN ( NX , IX+1 ) END IF ! DO IY=1, NY IF ( MTEMP(IY,IX) .EQ. 2 ) THEN IYL = MAX ( 1 , IY-1 ) IYH = MIN ( NY , IY+1 ) IF ( .NOT. ( ( MTEMP(IYL,IX ) .EQ. 1 ) .OR. & ( MTEMP(IYH,IX ) .EQ. 1 ) .OR. & ( MTEMP(IY ,IXL) .EQ. 1 ) .OR. & ( MTEMP(IY ,IXH) .EQ. 1 ) ) ) & MTEMP(IY,IX) = 3 END IF END DO ! END DO ! !/T7 WRITE (NDST,9040) ! ! 5. Recompute grid range ------------------------------------------- * ! Using GSTOLD to store info for modified grid ! !/T7 WRITE (NDST,9050) GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & !/T7 GSTATS(IG)%NXL, GSTATS(IG)%NXH, & !/T7 GSTATS(IG)%NYL, GSTATS(IG)%NYH ! GSTOLD(IG)%STRADLE = .FALSE. GSTOLD(IG)%NPTS = 0 GSTOLD(IG)%NXL = NX GSTOLD(IG)%NXH = 1 GSTOLD(IG)%NYL = NY GSTOLD(IG)%NYH = 1 ! IF ( GLOBAL ) THEN ! LEFT = .FALSE. RIGHT = .FALSE. ! DO IY=1, NY IF ( MTEMP(IY, 1).EQ.1 .OR. MTEMP(IY, 1).EQ.2 ) LEFT = .TRUE. IF ( MTEMP(IY,NX).EQ.1 .OR. MTEMP(IY,NX).EQ.2 ) RIGHT = .TRUE. END DO GSTOLD(IG)%STRADLE = LEFT .AND. RIGHT ! END IF ! DO IY=1, NY DO IX=1, NX IF ( MTEMP(IY,IX).EQ.1 .OR. MTEMP(IY,IX).EQ.2 ) THEN GSTOLD(IG)%NPTS = GSTOLD(IG)%NPTS + 1 GSTOLD(IG)%NXL = MIN ( GSTOLD(IG)%NXL , IX ) GSTOLD(IG)%NXH = MAX ( GSTOLD(IG)%NXH , IX ) GSTOLD(IG)%NYL = MIN ( GSTOLD(IG)%NYL , IY ) GSTOLD(IG)%NYH = MAX ( GSTOLD(IG)%NYH , IY ) END IF END DO END DO ! IF ( GSTOLD(IG)%STRADLE ) THEN NOCNT = 0 NOCNTM = 0 NOCNTL = 0 DO IX=1, NX THERE = .FALSE. DO IY=1, NY IF ( MTEMP(IY,IX).EQ.1 .OR. MTEMP(IY,IX).EQ.2 ) THEN THERE = .TRUE. EXIT END IF END DO IF ( THERE ) THEN NOCNT = 0 ELSE NOCNT = NOCNT + 1 IF ( NOCNT .GT. NOCNTM ) THEN NOCNTM = NOCNT NOCNTL = IX END IF END IF END DO GSTOLD(IG)%NXL = NOCNTL + 1 GSTOLD(IG)%NXH = NOCNTL - NOCNTM END IF ! ! ... Make sure outside of grid is 2 or 3 ! !/T7 WRITE (NDST,9051) GSTOLD(IG)%STRADLE, GSTOLD(IG)%NPTS, & !/T7 GSTOLD(IG)%NXL, GSTOLD(IG)%NXH, & !/T7 GSTOLD(IG)%NYL, GSTOLD(IG)%NYH LEFT = .FALSE. RIGHT = .FALSE. ! DO IX=1, NX LEFT = LEFT .OR. ( MTEMP(GSTOLD(IG)%NYL,IX) .EQ. 1 ) RIGHT = RIGHT .OR. ( MTEMP(GSTOLD(IG)%NYH,IX) .EQ. 1 ) END DO ! IF ( LEFT ) GSTOLD(IG)%NYL = GSTOLD(IG)%NYL - 1 IF ( RIGHT ) GSTOLD(IG)%NYH = GSTOLD(IG)%NYH + 1 ! DO IY=1, NY LEFT = LEFT .OR. ( MTEMP(IY,GSTOLD(IG)%NXL) .EQ. 1 ) RIGHT = RIGHT .OR. ( MTEMP(IY,GSTOLD(IG)%NXH) .EQ. 1 ) END DO ! IF ( LEFT ) GSTOLD(IG)%NXL = GSTOLD(IG)%NXL - 1 IF ( RIGHT ) GSTOLD(IG)%NXH = GSTOLD(IG)%NXH + 1 ! IF ( GLOBAL .AND. GSTOLD(IG)%NXL.EQ.0 ) THEN GSTOLD(IG)%NXL = NX GSTOLD(IG)%STRADLE = .TRUE. END IF ! IF ( GLOBAL .AND. GSTOLD(IG)%NXH.EQ.NX+1 ) THEN GSTOLD(IG)%NXH = 1 GSTOLD(IG)%STRADLE = .TRUE. END IF ! !/T7 WRITE (NDST,9052) GSTOLD(IG)%STRADLE, GSTOLD(IG)%NPTS, & !/T7 GSTOLD(IG)%NXL, GSTOLD(IG)%NXH, & !/T7 GSTOLD(IG)%NYL, GSTOLD(IG)%NYH ! ! 6. Extract reduced grid data -------------------------------------- * ! MY = 1 + GSTOLD(IG)%NYH - GSTOLD(IG)%NYL MX = 1 + GSTOLD(IG)%NXH - GSTOLD(IG)%NXL IF ( GSTOLD(IG)%STRADLE ) MX = MX + NX PGRID(IG)%NY = MY PGRID(IG)%NX = MX PGRID(IG)%NSEA = GSTOLD(IG)%NPTS PGRID(IG)%X0 = X0 + REAL(GSTOLD(IG)%NXL-1)*SX PGRID(IG)%Y0 = Y0 + REAL(GSTOLD(IG)%NYL-1)*SY PGRID(IG)%SX = SX PGRID(IG)%SY = SY ! XOFF = 360. * REAL ( NINT((PGRID(IG)%X0+0.5*REAL(MX-1)*SX)/360.) ) PGRID(IG)%X0 = PGRID(IG)%X0 - XOFF ! !/T7 WRITE (NDST,9060) PGRID(IG)%NX, PGRID(IG)%NY, PGRID(IG)%NSEA, & !/T7 PGRID(IG)%X0, PGRID(IG)%Y0, PGRID(IG)%SX, PGRID(IG)%SY ! ALLOCATE ( PGRID(IG)%ZBIN(MX,MY) , & PGRID(IG)%OBSX(MX,MY) , & PGRID(IG)%OBSY(MX,MY) , & PGRID(IG)%MASK(MX,MY) ) ! PGRID(IG)%ZBIN = ZBDUM PGRID(IG)%OBSX = 0. PGRID(IG)%OBSY = 0. PGRID(IG)%MASK = 99 ! DO IX=1, PGRID(IG)%NX JX = 1 + MOD ( IX+GSTOLD(IG)%NXL-2 , NX ) DO IY=1, PGRID(IG)%NY JY = IY + GSTOLD(IG)%NYL - 1 ISEA = MAPFS(JY,JX) IF ( MTEMP(JY,JX) .NE. 0 ) THEN PGRID(IG)%ZBIN(IX,IY) = ZB(ISEA) END IF IF ( TRFLAG .NE. 0 ) THEN PGRID(IG)%OBSX(IX,IY) = 1. - TRNX(JY,JX) PGRID(IG)%OBSY(IX,IY) = 1. - TRNY(JY,JX) END IF PGRID(IG)%MASK(IX,IY) = MTEMP(JY,JX) END DO END DO ! RETURN ! ! Formats ! !/T7 9000 FORMAT ( 'TEST GR1GRD: EXTRACTING GRID:',I4) !/T7 9040 FORMAT ( ' MASK ON FULL GRID COMPUTED') !/T7 9050 FORMAT ( 'TEST GR1GRD: GRID STATS :'/ & !/T7 ' GRID MAP :',L2,2X,I8,4I5) !/T7 9051 FORMAT ( ' HALO ADDED :',L2,2X,I8,4I5) !/T7 9052 FORMAT ( ' BORDER ADDED :',L2,2X,I8,4I5) !/T7 9060 FORMAT ( 'TEST GR1GRD: EXTRACTED GRID :',2I5,I8/ & !/T7 ' ',4E12.5) ! !/ End of GR1GRD ----------------------------------------------------- / !/ END SUBROUTINE GR1GRD !/ !/ End of W3GSPL ----------------------------------------------------- / !/ END PROGRAM W3GSPL