WAVEWATCH III  beta 0.0.1
Functions/Subroutines
wminiomd Module Reference

Internal IO routines for the multi-grid model. More...

Functions/Subroutines

subroutine wmiobs (IMOD)
 Stage internal boundary data in the data structure BPSTGE. More...
 
subroutine wmiobg (IMOD, DONE)
 Gather internal boundary data for a given model. More...
 
subroutine wmiobf (IMOD)
 Finalize staging of internal boundary data in the data structure BPSTGE (MPI only). More...
 
subroutine wmiohs (IMOD)
 Stage internal high-to-low data in the data structure HGSTGE. More...
 
subroutine wmiohg (IMOD, DONE)
 Gather internal high-to-low data for a given model. More...
 
subroutine wmiohf (IMOD)
 Finalize staging of internal high-to-low data in the data structure HGSTGE (MPI only). More...
 
subroutine wmioes (IMOD)
 Stage internal same-rank data in the data structure EQSTGE. More...
 
subroutine wmioeg (IMOD, DONE)
 Gather internal same-rank data for a given model. More...
 
subroutine wmioef (IMOD)
 Finalize staging of internal same-rank data in the data structure EQSTGE (MPI only). More...
 

Detailed Description

Internal IO routines for the multi-grid model.

Author
H. L. Tolman
Date
28-Sep-2016

Function/Subroutine Documentation

◆ wmiobf()

subroutine wminiomd::wmiobf ( integer, intent(in)  IMOD)

Finalize staging of internal boundary data in the data structure BPSTGE (MPI only).

Post appropriate 'wait' functions to assure that the communication has finished.

Parameters
[in]IMODModel number of grid from which data has been staged.
Author
H. L. Tolman
Date
29-May-2006

Definition at line 1212 of file wminiomd.F90.

1212  !/
1213  !/ +-----------------------------------+
1214  !/ | WAVEWATCH III NOAA/NCEP |
1215  !/ | H. L. Tolman |
1216  !/ | FORTRAN 90 |
1217  !/ | Last update : 29-May-2006 !
1218  !/ +-----------------------------------+
1219  !/
1220  !/ 18-Oct-2005 : Origination. ( version 3.08 )
1221  !/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 )
1222  !/
1223  ! 1. Purpose :
1224  !
1225  ! Finalize staging of internal boundary data in the data
1226  ! structure BPSTGE (MPI only).
1227  !
1228  ! 2. Method :
1229  !
1230  ! Post appropriate 'wait' functions to assure that the
1231  ! communication has finished.
1232  !
1233  ! 3. Parameters :
1234  !
1235  ! Parameter list
1236  ! ----------------------------------------------------------------
1237  ! IMOD Int. I Model number of grid from which data has
1238  ! been staged.
1239  ! ----------------------------------------------------------------
1240  !
1241  ! 4. Subroutines used :
1242  !
1243  ! Name Type Module Description
1244  ! ----------------------------------------------------------------
1245  ! STRACE Subr. W3SERVMD Subroutine tracing.
1246  !
1247  ! MPI_WAITALL
1248  ! Subr. mpif.h MPI routines.
1249  ! ----------------------------------------------------------------
1250  !
1251  ! 5. Called by :
1252  !
1253  ! Name Type Module Description
1254  ! ----------------------------------------------------------------
1255  ! WMINIT Subr WMINITMD Multi-grid model initialization.
1256  ! WMWAVE Subr WMWAVEMD Multi-grid wave model.
1257  ! ----------------------------------------------------------------
1258  !
1259  ! 6. Error messages :
1260  !
1261  ! 7. Remarks :
1262  !
1263  ! 8. Structure :
1264  !
1265  ! See source code.
1266  !
1267  ! 9. Switches :
1268  !
1269  ! !/SHRD Shared/distributed memory models.
1270  ! !/DIST
1271  ! !/MPI
1272  !
1273  ! !/S Enable subroutine tracing.
1274  ! !/T Test output.
1275  !
1276  ! 10. Source code :
1277  !
1278  !/ ------------------------------------------------------------------- /
1279  !
1280  USE wmmdatmd
1281  !
1282 #ifdef W3_S
1283  USE w3servmd, ONLY: strace
1284 #endif
1285  !
1286  IMPLICIT NONE
1287  !
1288 #ifdef W3_MPI
1289  include "mpif.h"
1290 #endif
1291  !/
1292  !/ ------------------------------------------------------------------- /
1293  !/ Parameter list
1294  !/
1295  INTEGER, INTENT(IN) :: IMOD
1296  !/
1297  !/ ------------------------------------------------------------------- /
1298  !/ Local parameters
1299  !/
1300  INTEGER :: J
1301 #ifdef W3_MPI
1302  INTEGER :: IERR_MPI
1303  INTEGER, POINTER :: NRQ, IRQ(:)
1304  INTEGER, ALLOCATABLE :: STATUS(:,:)
1305 #endif
1306 #ifdef W3_S
1307  INTEGER, SAVE :: IENT = 0
1308 #endif
1309  !/
1310 #ifdef W3_S
1311  CALL strace (ient, 'WMIOBF')
1312 #endif
1313  !
1314  ! -------------------------------------------------------------------- /
1315  ! 0. Initializations
1316  !
1317 #ifdef W3_T
1318  WRITE (mdst,9000) imod
1319 #endif
1320  !
1321  ! -------------------------------------------------------------------- /
1322  ! 1. Loop over grids
1323  !
1324  DO j=1, nrgrd
1325  !
1326 #ifdef W3_MPI
1327  nrq => bpstge(j,imod)%NRQBPS
1328 #endif
1329  !
1330  ! 1.a Nothing to finalize
1331  !
1332 #ifdef W3_MPI
1333  IF ( nrq .EQ. 0 ) cycle
1334  irq => bpstge(j,imod)%IRQBPS
1335 #endif
1336  !
1337  ! 1.b Wait for communication to end
1338  !
1339 #ifdef W3_MPI
1340  ALLOCATE ( status(mpi_status_size,nrq) )
1341  CALL mpi_waitall ( nrq, irq, status, ierr_mpi )
1342  DEALLOCATE ( status )
1343 #endif
1344  !
1345  ! 1.c Reset arrays and counter
1346  !
1347 #ifdef W3_MPI
1348  nrq = 0
1349  DEALLOCATE ( bpstge(j,imod)%IRQBPS , &
1350  bpstge(j,imod)%TSTORE )
1351 #endif
1352  !
1353 #ifdef W3_T
1354  WRITE (mdst,9010) j
1355 #endif
1356  !
1357  END DO
1358  !
1359  RETURN
1360  !
1361  ! Formats
1362  !
1363 #ifdef W3_T
1364 9000 FORMAT ( ' TEST WMIOBF : FINALIZE STAGING DATA FROM GRID ',i3)
1365 9010 FORMAT ( ' TEST WMIOBF : FINISHED WITH TARGET ',i3)
1366 #endif
1367  !/
1368  !/ End of WMIOBF ----------------------------------------------------- /
1369  !/

References wmmdatmd::bpstge, include(), wmmdatmd::mdst, wmmdatmd::nrgrd, and w3servmd::strace().

Referenced by wminitmd::wminit(), wminitmd::wminitnml(), and wmwavemd::wmwave().

◆ wmiobg()

subroutine wminiomd::wmiobg ( integer, intent(in)  IMOD,
logical, intent(out), optional  DONE 
)

Gather internal boundary data for a given model.

For the shared memory version, data are gathered from the data structure BPSTGE. For the distributed memory version, the gathering of the data are finished first.

Gathering of data is triggered by the time stamp of the data that is presently in the storage arrays.

This routine preempts the data flow normally executed by W3IOBC and W3UBPT, and hence bypasses both routines in W3WAVE.

Parameters
[in]IMODModel number of grid from which data is to be gathered.
[out]DONEFlag for completion of operation (opt).
Author
H. L. Tolman
Date
29-May-2006

Definition at line 497 of file wminiomd.F90.

497  !/
498  !/ +-----------------------------------+
499  !/ | WAVEWATCH III NOAA/NCEP |
500  !/ | H. L. Tolman |
501  !/ | FORTRAN 90 |
502  !/ | Last update : 29-May-2006 !
503  !/ +-----------------------------------+
504  !/
505  !/ 18-Oct-2005 : Origination. ( version 3.08 )
506  !/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 )
507  !/
508  ! 1. Purpose :
509  !
510  ! Gather internal boundary data for a given model.
511  !
512  ! 2. Method :
513  !
514  ! For the shared memory version, datat are gathered from the data
515  ! structure BPSTGE. For the distributed memeory version, the
516  ! gathering of thee data are finished first.
517  !
518  ! Gathering of data is triggered by the time stamp of the data
519  ! that is presently in the storage arrays.
520  !
521  ! This routine preempts the data flow normally executed by
522  ! W3IOBC and W3UBPT, and hence bypasses both routines in W3WAVE.
523  !
524  ! 2. Method :
525  !
526  ! Using storage array BPSTAGE and time stamps.
527  !
528  ! 3. Parameters :
529  !
530  ! Parameter list
531  ! ----------------------------------------------------------------
532  ! IMOD Int. I Model number of grid from which data is to
533  ! be gathered.
534  ! DONE Log. O Flag for completion of operation (opt).
535  ! ----------------------------------------------------------------
536  !
537  ! 4. Subroutines used :
538  !
539  ! Name Type Module Description
540  ! ----------------------------------------------------------------
541  ! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM
542  ! Subr. WxxDATMD Manage data structures.
543  ! W3CSPC Subr. W3CSPCMD Spectral grid conversion.
544  ! W3UBPT Subr. W3UBPTMD Update internal bounday spectra.
545  ! W3IOBC Subr W3IOBCMD I/O of boundary data.
546  ! STRACE Sur. W3SERVMD Subroutine tracing.
547  ! EXTCDE Sur. Id. Program abort.
548  ! DSEC21 Func. W3TIMEMD Difference between times.
549  !
550  ! MPI_IRECV, MPI_TESTALL, MPI_WAITALL
551  ! Subr. mpif.h MPI routines.
552  ! ----------------------------------------------------------------
553  !
554  ! 5. Called by :
555  !
556  ! Name Type Module Description
557  ! ----------------------------------------------------------------
558  ! WMINIT Subr WMINITMD Multi-grid model initialization.
559  ! WMWAVE Subr WMWAVEMD Multi-grid wave model.
560  ! ----------------------------------------------------------------
561  !
562  ! 6. Error messages :
563  !
564  ! See FORMAT labels 1001-1002.
565  !
566  ! 7. Remarks :
567  !
568  ! 8. Structure :
569  !
570  ! 9. Switches :
571  !
572  ! !/SHRD Shared/distributed memory models.
573  ! !/DIST
574  ! !/MPI
575  !
576  ! !/S Enable subroutine tracing.
577  ! !/T Enable test output
578  !
579  ! 10. Source code :
580  !
581  !/ ------------------------------------------------------------------- /
582  !
583  USE w3gdatmd
584  USE w3wdatmd
585  USE w3adatmd
586  USE w3odatmd
587  USE wmmdatmd
588  !
589  USE w3cspcmd, ONLY: w3cspc
590  USE w3timemd, ONLY: dsec21
591  USE w3updtmd, ONLY: w3ubpt
592  USE w3iobcmd, ONLY: w3iobc
593  USE w3servmd, ONLY: extcde
594  ! USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC_GLOB
595 #ifdef W3_S
596  USE w3servmd, ONLY: strace
597 #endif
598  !
599  IMPLICIT NONE
600  !
601 #ifdef W3_MPI
602  include "mpif.h"
603 #endif
604  !/
605  !/ ------------------------------------------------------------------- /
606  !/ Parameter list
607  !/
608  INTEGER, INTENT(IN) :: IMOD
609  LOGICAL, INTENT(OUT), OPTIONAL :: DONE
610  !/
611  !/ ------------------------------------------------------------------- /
612  !/ Local parameters
613  !/
614  INTEGER :: J, I, IOFF, TTEST(2), ITEST
615 #ifdef W3_MPI
616  INTEGER :: IERR_MPI, IT0, ITAG, IFROM, &
617  ISEA, JSEA, ISPROC
618 #endif
619 #ifdef W3_MPIT
620  INTEGER :: ICOUNT
621 #endif
622 #ifdef W3_S
623  INTEGER, SAVE :: IENT = 0
624 #endif
625  INTEGER, POINTER :: VTIME(:)
626 #ifdef W3_MPI
627  INTEGER, POINTER :: NRQ, IRQ(:)
628  INTEGER, ALLOCATABLE :: STATUS(:,:)
629 #endif
630  REAL :: DTTST, DT1, DT2, W1, W2
631  REAL, POINTER :: SBPI(:,:)
632 #ifdef W3_MPI
633  REAL, ALLOCATABLE :: TSTORE(:,:)
634  LOGICAL :: FLAGOK
635 #endif
636 #ifdef W3_MPIT
637  LOGICAL :: FLAG
638 #endif
639  !/
640 #ifdef W3_S
641  CALL strace (ient, 'WMIOBG')
642 #endif
643 
644 
645  !
646  ! -------------------------------------------------------------------- /
647  ! 0. Initializations
648  !
649 #ifdef W3_T
650  WRITE (mdst,9000) imod
651  WRITE (mdst,9001) nbi2g(imod,:)
652 #endif
653  !
654  IF ( PRESENT(done) ) done = .false.
655  !
656  CALL w3seto ( imod, mdse, mdst )
657  !
658  IF ( iaproc .GT. naproc ) THEN
659  IF ( PRESENT(done) ) done = .true.
660 #ifdef W3_T
661  WRITE (mdst,9002)
662 #endif
663  RETURN
664  END IF
665  !
666  IF ( sum(nbi2g(imod,:)) .EQ. 0 ) THEN
667  IF ( PRESENT(done) ) done = .true.
668 #ifdef W3_T
669  WRITE (mdst,9003)
670 #endif
671  RETURN
672  END IF
673  !
674  CALL w3setg ( imod, mdse, mdst )
675  CALL w3setw ( imod, mdse, mdst )
676  CALL w3seta ( imod, mdse, mdst )
677  !
678  IF ( tbpin(1) .NE. -1 ) THEN
679  IF ( dsec21(time,tbpin) .GT. 0. ) THEN
680  IF ( PRESENT(done) ) done = .true.
681 #ifdef W3_T
682  WRITE (mdst,9004)
683 #endif
684  RETURN
685  END IF
686  END IF
687  !
688  ! -------------------------------------------------------------------- /
689  ! 1. Testing / gathering data in staging arrays
690  !
691 #ifdef W3_T
692  WRITE (mdst,9010)
693 #endif
694  !
695  ! 1.a Shared memory version, test valid times. - - - - - - - - - - - - /
696  !
697 #ifdef W3_SHRD
698  DO j=1, nrgrd
699 #endif
700  !
701 #ifdef W3_SHRD
702  IF ( nbi2g(imod,j) .EQ. 0 ) cycle
703  vtime => bpstge(imod,j)%VTIME
704 #endif
705  !
706 #ifdef W3_SHRD
707  IF ( vtime(1) .EQ. -1 ) THEN
708  IF ( nmproc .EQ. nmperr ) WRITE (mdse,1001)
709  CALL extcde ( 1001 )
710  END IF
711 #endif
712  !
713 #ifdef W3_SHRD
714  dttst = dsec21( time, vtime )
715  IF ( dttst.LE.0. .AND. tbpin(1).NE.-1 ) RETURN
716 #endif
717  !
718 #ifdef W3_SHRD
719  END DO
720 #endif
721  !
722  ! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - /
723  !
724 #ifdef W3_MPIT
725  WRITE (mdst,9011) nbista(imod)
726 #endif
727  !
728  ! 1.b.1 NBISTA = 0
729  ! Check if staging arrays are initialized.
730  ! Post the proper receives.
731  !
732 #ifdef W3_MPI
733  IF ( nbista(imod) .EQ. 0 ) THEN
734 #endif
735  !
736 #ifdef W3_MPI
737  nrq => mdatas(imod)%NRQBPG
738  nrq = nrgrd + sum(nbi2g(imod,:))
739  ALLOCATE ( mdatas(imod)%IRQBPG(nrq) )
740  irq => mdatas(imod)%IRQBPG
741  irq = 0
742  nrq = 0
743 #endif
744  !
745 #ifdef W3_MPI
746  DO j=1, nrgrd
747  IF ( nbi2g(imod,j) .EQ. 0 ) cycle
748 #endif
749  !
750  ! ..... Staging arrays
751  !
752 #ifdef W3_MPI
753  IF ( bpstge(imod,j)%INIT ) THEN
754  IF ( respec(imod,j) ) THEN
755  DEALLOCATE ( bpstge(imod,j)%SBPI )
756  bpstge(imod,j)%INIT = .false.
757 #endif
758 #ifdef W3_MPIT
759  WRITE (mdst,9012) j, 'RESET'
760 #endif
761 #ifdef W3_MPI
762  ELSE
763  IF ( SIZE(bpstge(imod,j)%SBPI(:,1)) .NE. &
764  sgrds(j)%NSPEC .OR. &
765  SIZE(bpstge(imod,j)%SBPI(1,:)) .NE. &
766  nbi2g(imod,j) ) THEN
767  IF ( improc .EQ. nmperr ) WRITE (mdse,1003)
768  CALL extcde (1003)
769  END IF
770 #endif
771 #ifdef W3_MPIT
772  WRITE (mdst,9012) j, 'TESTED'
773 #endif
774 #ifdef W3_MPI
775  END IF
776  END IF
777 #endif
778  !
779 #ifdef W3_MPI
780  IF ( .NOT. bpstge(imod,j)%INIT ) THEN
781  nspec => sgrds(j)%NSPEC
782  ALLOCATE (bpstge(imod,j)%SBPI(nspec,nbi2g(imod,j)))
783  nspec => sgrds(imod)%NSPEC
784  bpstge(imod,j)%INIT = .true.
785 #endif
786 #ifdef W3_MPIT
787  WRITE (mdst,9012) j, 'INITIALIZED'
788 #endif
789 #ifdef W3_MPI
790  END IF
791 #endif
792  !
793  ! ..... Check valid time to determine staging.
794  !
795 #ifdef W3_MPI
796  vtime => bpstge(imod,j)%VTIME
797  IF ( vtime(1) .EQ. -1 ) THEN
798  dttst = 0.
799  ELSE
800  dttst = dsec21( time, vtime )
801  END IF
802 #endif
803 #ifdef W3_MPIT
804  WRITE (mdst,9013) vtime, dttst
805 #endif
806  !
807  ! ..... Post receives for data gather
808  !
809 #ifdef W3_MPI
810  IF ( dttst .LE. 0. ) THEN
811 #endif
812 #ifdef W3_MPIT
813  WRITE (mdst,9014) j
814 #endif
815  !
816  ! ..... Time
817  !
818 #ifdef W3_MPI
819  itag = mtag0 + j + (imod-1)*nrgrd
820  ifrom = mdatas(j)%CROOT - 1
821  nrq = nrq + 1
822  CALL mpi_irecv ( bpstge(imod,j)%VTIME, 2, &
823  mpi_integer, ifrom, itag, &
824  mpi_comm_mwave, irq(nrq), &
825  ierr_mpi )
826 #endif
827 #ifdef W3_MPIT
828  WRITE (mdst,9015) nrq, ifrom+1, itag-mtag0, &
829  irq(nrq), ierr_mpi
830 #endif
831  !
832  ! ..... Spectra
833  !
834 #ifdef W3_MPI
835  IF ( j .EQ. 1 ) THEN
836  ioff = 0
837  ELSE
838  ioff = sum(nbi2g(imod,1:j-1))
839  END IF
840 #endif
841  !
842 #ifdef W3_MPI
843  it0 = mtag0 + nrgrd**2 + sum(nbi2g(1:imod-1,:)) &
844  + sum(nbi2g(imod,1:j-1))
845 #endif
846  !
847 #ifdef W3_MPI
848  sbpi => bpstge(imod,j)%SBPI
849 #endif
850  !
851 #ifdef W3_MPI
852  naproc => outpts(j)%NAPROC
853  nspec => sgrds(j)%NSPEC
854  DO i=1, nbi2g(imod,j)
855  isea = nbi2s(ioff+i,2)
856  CALL init_get_jsea_isproc_glob(isea, j, jsea, isproc)
857  nrq = nrq + 1
858  itag = it0 + i
859  CALL mpi_irecv ( sbpi(1,i), nspec, &
860  mpi_real, isproc-1, &
861  itag, mpi_comm_mwave, &
862  irq(nrq), ierr_mpi )
863 #endif
864 #ifdef W3_MPIT
865  WRITE (mdst,9016) nrq, jsea, isproc, &
866  itag-mtag0, irq(nrq), ierr_mpi
867 #endif
868 #ifdef W3_MPI
869  END DO
870  nspec => sgrds(imod)%NSPEC
871  naproc => outpts(imod)%NAPROC
872 #endif
873  !
874  ! ..... End IF for posting receives 1.b.1
875  !
876 #ifdef W3_MPIT
877  WRITE (mdst,9017)
878 #endif
879 #ifdef W3_MPI
880  END IF
881 #endif
882  !
883  ! ..... End grid loop J in 1.b.1
884  !
885 #ifdef W3_MPI
886  END DO
887 #endif
888 #ifdef W3_MPIT
889  WRITE (mdst,9018) nrq
890 #endif
891  !
892  ! ..... Reset status
893  ! NOTE: if NBI.EQ.0 all times are already OK, skip to section 2
894  !
895 #ifdef W3_MPI
896  IF ( nbi .GT. 0 ) THEN
897  nbista(imod) = 1
898 #endif
899 #ifdef W3_MPIT
900  WRITE (mdst,9011) nbista(imod)
901 #endif
902 #ifdef W3_MPI
903  END IF
904 #endif
905  !
906  ! ..... End IF in 1.b.1
907  !
908 #ifdef W3_MPI
909  END IF
910 #endif
911  !
912  ! 1.b.2 NBISTA = 1
913  ! Wait for communication to finish.
914  ! If DONE defined, check if done, otherwise wait.
915  !
916 #ifdef W3_MPI
917  IF ( nbista(imod) .EQ. 1 ) THEN
918 #endif
919  !
920 #ifdef W3_MPI
921  nrq => mdatas(imod)%NRQBPG
922  irq => mdatas(imod)%IRQBPG
923  ALLOCATE ( status(mpi_status_size,nrq) )
924 #endif
925  !
926  ! ..... Test communication if DONE is present, wait otherwise
927  !
928 #ifdef W3_MPI
929  IF ( PRESENT(done) ) THEN
930 #endif
931  !
932 #ifdef W3_MPI
933  CALL mpi_testall ( nrq, irq, flagok, status, &
934  ierr_mpi )
935 #endif
936  !
937 #ifdef W3_MPIT
938  icount = 0
939  DO i=1, nrq
940  CALL mpi_test ( irq(i), flag, status(1,1), &
941  ierr_mpi )
942  flagok = flagok .AND. flag
943  IF ( flag ) icount = icount + 1
944  END DO
945  WRITE (mdst,9019) 100. * real(icount) / real(nrq)
946 #endif
947  !
948 #ifdef W3_MPI
949  ELSE
950 #endif
951  !
952 #ifdef W3_MPI
953  CALL mpi_waitall ( nrq, irq, status, ierr_mpi )
954  flagok = .true.
955 #endif
956  !
957 #ifdef W3_MPI
958  END IF
959 #endif
960  !
961 #ifdef W3_MPI
962  DEALLOCATE ( status )
963 #endif
964  !
965  ! ..... Go on based on FLAGOK
966  !
967 #ifdef W3_MPI
968  IF ( flagok ) THEN
969  DEALLOCATE ( mdatas(imod)%IRQBPG )
970  nrq = 0
971  ELSE
972  RETURN
973  END IF
974 #endif
975  !
976 #ifdef W3_MPI
977  nbista(imod) = 2
978 #endif
979 #ifdef W3_MPIT
980  WRITE (mdst,9011) nbista(imod)
981 #endif
982  !
983  ! 1.b.3 Convert spectra if needed
984  !
985 #ifdef W3_MPI
986  DO j=1, nrgrd
987 #endif
988  !
989 #ifdef W3_MPI
990  IF ( respec(imod,j) .AND. nbi2g(imod,j).NE.0 ) THEN
991 #endif
992  !
993 #ifdef W3_MPIT
994  WRITE (mdst,9100) j
995 #endif
996 #ifdef W3_MPI
997  nspec => sgrds(j)%NSPEC
998  ALLOCATE ( tstore(nspec,nbi2g(imod,j)))
999  nspec => sgrds(imod)%NSPEC
1000  tstore = bpstge(imod,j)%SBPI
1001  DEALLOCATE ( bpstge(imod,j)%SBPI )
1002  ALLOCATE (bpstge(imod,j)%SBPI(nspec,nbi2g(imod,j)))
1003 #endif
1004  !
1005 #ifdef W3_MPI
1006  sbpi => bpstge(imod,j)%SBPI
1007  CALL w3cspc ( tstore, sgrds(j)%NK, sgrds(j)%NTH, &
1008  sgrds(j)%XFR, sgrds(j)%FR1, sgrds(j)%TH(1), &
1009  sbpi, nk, nth, xfr, fr1, th(1), &
1010  nbi2g(imod,j), mdst, mdse, sgrds(imod)%FACHFE)
1011 #endif
1012  !
1013 #ifdef W3_MPI
1014  DEALLOCATE ( tstore )
1015 #endif
1016  !
1017 #ifdef W3_MPI
1018  END IF
1019 #endif
1020  !
1021 #ifdef W3_MPI
1022  END DO
1023 #endif
1024  !
1025 #ifdef W3_MPI
1026  nbista(imod) = 0
1027 #endif
1028 #ifdef W3_MPIT
1029  WRITE (mdst,9011) nbista(imod)
1030 #endif
1031  !
1032 #ifdef W3_MPI
1033  END IF
1034 #endif
1035  !
1036  ! -------------------------------------------------------------------- /
1037  ! 2. Update arrays ABPI0/N and data times
1038  !
1039 #ifdef W3_T
1040  WRITE (mdst,9020)
1041 #endif
1042  !
1043  ! 2.a Determine next valid time
1044  !
1045  ttest = -1
1046  DO j=1, nrgrd
1047  IF ( nbi2g(imod,j) .EQ. 0 ) cycle
1048  vtime => bpstge(imod,j)%VTIME
1049  IF ( ttest(1) .EQ. -1 ) THEN
1050  ttest = vtime
1051  ELSE
1052  dttst = dsec21(vtime,ttest)
1053  IF ( dttst .GT. 0. ) ttest = vtime
1054  END IF
1055  END DO
1056  !
1057 #ifdef W3_T
1058  WRITE (mdst,9021) ttest
1059 #endif
1060  !
1061  ! 2.b Shift data
1062  !
1063  IF ( tbpin(1) .EQ. -1 ) THEN
1064  dttst = dsec21(ttest,time)
1065  IF ( dttst .NE. 0. ) THEN
1066  IF ( nmproc .EQ. nmperr ) WRITE (mdse,1002)
1067  CALL extcde(1002)
1068  END IF
1069  abpi0 = 0.
1070  ELSE
1071  tbpi0 = tbpin
1072  abpi0 = abpin
1073  END IF
1074  !
1075  ! 2.c Loop over grids for new spectra
1076  !
1077  DO j=1, nrgrd
1078  !
1079  IF ( nbi2g(imod,j) .EQ. 0 ) cycle
1080  vtime => bpstge(imod,j)%VTIME
1081  sbpi => bpstge(imod,j)%SBPI
1082  !
1083  IF ( j .EQ. 1 ) THEN
1084  ioff = 0
1085  ELSE
1086  ioff = sum(nbi2g(imod,1:j-1))
1087  END IF
1088  !
1089  IF ( tbpin(1) .EQ. -1 ) THEN
1090  w1 = 0.
1091  w2 = 1.
1092  ELSE
1093  dt1 = dsec21(tbpi0,vtime)
1094  dt2 = dsec21(tbpi0,ttest)
1095  w2 = dt2 / dt1
1096  w1 = 1. - w2
1097  END IF
1098 #ifdef W3_T
1099  WRITE (mdst,9022) nbi2g(imod,j), j, ioff+1, w1, w2
1100 #endif
1101  !
1102  abpin(:,ioff+1:ioff+nbi2g(imod,j)) = &
1103  w1 * abpi0(:,ioff+1:ioff+nbi2g(imod,j)) + &
1104  w2 * sbpi(:,1:nbi2g(imod,j))
1105  !
1106  END DO
1107  !
1108  ! 2.d New time
1109  !
1110  tbpin = ttest
1111  !
1112  ! -------------------------------------------------------------------- /
1113  ! 3. Dump data to file if requested
1114  !
1115  IF ( iaproc.EQ.napbpt .AND. bcdump(imod) ) THEN
1116 #ifdef W3_T
1117  WRITE (mdst,9030)
1118 #endif
1119  CALL w3iobc ( 'DUMP', nds(9), tbpin, tbpin, itest, imod )
1120  END IF
1121  !
1122  ! -------------------------------------------------------------------- /
1123  ! 4. Update arrays BBPI0/N
1124  !
1125 #ifdef W3_T
1126  WRITE (mdst,9040)
1127 #endif
1128  !
1129  CALL w3ubpt
1130  !
1131  ! -------------------------------------------------------------------- /
1132  ! 5. Successful update
1133  !
1134  IF ( PRESENT(done) ) done = .true.
1135  !
1136  RETURN
1137  !
1138  ! Formats
1139  !
1140 #ifdef W3_SHRD
1141 1001 FORMAT (/' *** ERROR WMIOBG : NO DATA IN STAGING ARRAY ***'/ &
1142  ' CALL WMIOBS FIRST '/)
1143 #endif
1144 1002 FORMAT (/' *** ERROR WMIOBG : INITIAL DATA NOT AT INITAL ', &
1145  'MODEL TIME ***'/)
1146 #ifdef W3_MPI
1147 1003 FORMAT (/' *** ERROR WMIOBG : UNEXPECTED SIZE OF STAGING', &
1148  ' ARRAY ***')
1149 #endif
1150  !
1151 #ifdef W3_T
1152 9000 FORMAT ( ' TEST WMIOBG : GATHERING DATA FOR GRID ',i3)
1153 9001 FORMAT ( ' TEST WMIOBG : NR. OF SPECTRA PER SOURCE GRID : '/ &
1154  ' ',25i4)
1155 9002 FORMAT ( ' TEST WMIOBG : NO DATA NEEDED ON PROCESSOR')
1156 9003 FORMAT ( ' TEST WMIOBG : NO DATA TO BE GATHERED')
1157 9004 FORMAT ( ' TEST WMIOBG : DATA UP TO DATE')
1158 #endif
1159  !
1160 #ifdef W3_T
1161 9010 FORMAT ( ' TEST WMIOBG : TEST DATA AVAILABILITY')
1162 #endif
1163 #ifdef W3_MPIT
1164 9011 FORMAT ( ' MPIT WMIOBG : NBISTA =',i2)
1165 9012 FORMAT ( ' STAGING ARRAY FROM',i4,1x,a)
1166 9013 FORMAT ( ' VTIME, DTTST :',i9.8,i7.6,1x,f8.1)
1167 9014 FORMAT (/' MPIT WMIOBG : RECEIVE FROM GRID',i4/ &
1168  ' +------+------+------+------+--------------+'/ &
1169  ' | IH | ID | FROM | TAG | handle err |'/ &
1170  ' +------+------+------+------+--------------+')
1171 9015 FORMAT ( ' |',i5,' | TIME |',2(i5,' |'),i9,i4,' |')
1172 9016 FORMAT ( ' |',i5,' |',i5,' |',2(i5,' |'),i9,i4,' |')
1173 9017 FORMAT ( ' +------+------+------+------+--------------+'/)
1174 9018 FORMAT ( ' MPIT WMIOBG : NRQHGH:',i10/)
1175 9019 FORMAT ( ' MPIT WMIOBG : RECEIVES FINISHED :',f6.1,'%')
1176 9100 FORMAT ( ' MPIT WMIOBG : CONVERTING SPECTRA FROM GRID',i3)
1177 #endif
1178  !
1179 #ifdef W3_T
1180 9020 FORMAT ( ' TEST WMIOBG : FILLING ABPI0/N AND TIMES')
1181 9021 FORMAT ( ' TEST WMIOBG : NEXT VALID TIME FOR ABPIN:',i9.8,i7.6)
1182 9022 FORMAT ( ' TEST WMIOBG : GETTING',i4,' SPECTRA FROM GRID ', &
1183  i3,' STORING AT ',i3/ &
1184  ' WEIGHTS : ',2f6.3)
1185 #endif
1186  !
1187 #ifdef W3_T
1188 9030 FORMAT ( ' TEST WMIOBG : DUMP DATA TO FILE')
1189 #endif
1190  !
1191 #ifdef W3_T
1192 9040 FORMAT ( ' TEST WMIOBG : FILLING BBPI0/N')
1193 #endif
1194  !/
1195  !/ End of WMIOBG ----------------------------------------------------- /
1196  !/

References w3odatmd::abpi0, w3odatmd::abpin, wmmdatmd::bcdump, wmmdatmd::bpstge, w3timemd::dsec21(), w3servmd::extcde(), w3gdatmd::fr1, w3odatmd::iaproc, wmmdatmd::improc, include(), wmmdatmd::init_get_jsea_isproc_glob(), wmmdatmd::mdatas, wmmdatmd::mdse, wmmdatmd::mdst, wmmdatmd::mpi_comm_mwave, wmmdatmd::mtag0, w3odatmd::napbpt, w3odatmd::naproc, w3odatmd::nbi, wmmdatmd::nbi2g, wmmdatmd::nbi2s, wmmdatmd::nbista, w3odatmd::nds, w3gdatmd::nk, wmmdatmd::nmperr, wmmdatmd::nmproc, wmmdatmd::nrgrd, w3gdatmd::nspec, w3gdatmd::nth, w3odatmd::outpts, wmmdatmd::respec, w3gdatmd::sgrds, w3servmd::strace(), w3odatmd::tbpi0, w3odatmd::tbpin, w3gdatmd::th, w3wdatmd::time, w3cspcmd::w3cspc(), w3iobcmd::w3iobc(), w3adatmd::w3seta(), w3gdatmd::w3setg(), w3odatmd::w3seto(), w3wdatmd::w3setw(), w3updtmd::w3ubpt(), and w3gdatmd::xfr.

Referenced by wminitmd::wminit(), wminitmd::wminitnml(), and wmwavemd::wmwave().

◆ wmiobs()

subroutine wminiomd::wmiobs ( integer, intent(in)  IMOD)

Stage internal boundary data in the data structure BPSTGE.

For the shared memory version, arrays are initialized and the data are copied. For the distributed memory version, the data are moved using a non-blocking send. In this case, the arrays are dimensioned on the receiving side.

Parameters
[in]IMODModel number of grid from which data is to be staged.
Author
H. L. Tolman
Date
06-Jun-2018

Definition at line 105 of file wminiomd.F90.

105  !/
106  !/ +-----------------------------------+
107  !/ | WAVEWATCH III NOAA/NCEP |
108  !/ | H. L. Tolman |
109  !/ | FORTRAN 90 |
110  !/ | Last update : 06-Jun-2018 !
111  !/ +-----------------------------------+
112  !/
113  !/ 06-Oct-2005 : Origination. ( version 3.08 )
114  !/ 29-May-2006 : Adding buffering for MPI. ( version 3.09 )
115  !/ 30-Jan-2007 : Fix memory leak. ( version 3.10 )
116  !/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 )
117  !/ 06-Jun-2018 : Use W3PARALL/add DEBUGIOBC/PDLIB ( version 6.04 )
118  !/
119  ! 1. Purpose :
120  !
121  ! Stage internal boundary data in the data structure BPSTGE.
122  !
123  ! 2. Method :
124  !
125  ! For the shared memory version, arrays are initialized and the
126  ! data are copied. For the distributed memory version, the data
127  ! are moved using a non-blocking send. in this case, the arrays
128  ! are dimensioned on the recieving side.
129  !
130  ! 3. Parameters :
131  !
132  ! Parameter list
133  ! ----------------------------------------------------------------
134  ! IMOD Int. I Model number of grid from which data is to
135  ! be staged.
136  ! ----------------------------------------------------------------
137  !
138  ! 4. Subroutines used :
139  !
140  ! Name Type Module Description
141  ! ----------------------------------------------------------------
142  ! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM
143  ! Subr. WxxDATMD Manage data structures.
144  ! W3CSPC Subr. W3CSPCMD Spectral grid conversion.
145  ! STRACE Subr. W3SERVMD Subroutine tracing.
146  ! EXTCDE Sur. Id. Program abort.
147  !
148  ! MPI_ISEND
149  ! Subr. mpif.h MPI routines.
150  ! ----------------------------------------------------------------
151  !
152  ! 5. Called by :
153  !
154  ! Name Type Module Description
155  ! ----------------------------------------------------------------
156  ! WMINIT Subr WMINITMD Multi-grid model initialization.
157  ! WMWAVE Subr WMWAVEMD Multi-grid wave model.
158  ! ----------------------------------------------------------------
159  !
160  ! 6. Error messages :
161  !
162  ! See FORMAT label 1001.
163  !
164  ! 7. Remarks :
165  !
166  ! 8. Structure :
167  !
168  ! See source code.
169  !
170  ! 9. Switches :
171  !
172  ! !/SHRD Shared/distributed memory models.
173  ! !/DIST
174  ! !/MPI
175  !
176  ! !/S Enable subroutine tracing.
177  ! !/T Enable test output
178  ! !/MPIT
179  !
180  ! 10. Source code :
181  !
182  !/ ------------------------------------------------------------------- /
183  !
184  USE w3gdatmd
185  USE w3wdatmd
186  USE w3adatmd
187  USE w3odatmd
188  USE wmmdatmd
189  !
190  USE w3cspcmd, ONLY: w3cspc
191  USE w3servmd, ONLY: extcde
192  USE w3parall, ONLY: init_get_jsea_isproc
193 #ifdef W3_S
194  USE w3servmd, ONLY: strace
195 #endif
196  !
197  IMPLICIT NONE
198  !
199 #ifdef W3_MPI
200  include "mpif.h"
201 #endif
202  !/
203  !/ ------------------------------------------------------------------- /
204  !/ Parameter list
205  !/
206  INTEGER, INTENT(IN) :: IMOD
207  !/
208  !/ ------------------------------------------------------------------- /
209  !/ Local parameters
210  !/
211  INTEGER :: J, I, IOFF, ISEA, JSEA, IS
212 #ifdef W3_DIST
213  INTEGER :: ISPROC
214 #endif
215 #ifdef W3_MPI
216  INTEGER :: IP, IT0, ITAG, IERR_MPI
217  INTEGER, POINTER :: NRQ, IRQ(:)
218 #endif
219 #ifdef W3_S
220  INTEGER, SAVE :: IENT = 0
221 #endif
222  REAL, POINTER :: SBPI(:,:), TSTORE(:,:)
223  !/
224 #ifdef W3_S
225  CALL strace (ient, 'WMIOBS')
226 #endif
227  !
228  ! -------------------------------------------------------------------- /
229  ! 0. Initializations
230  !
231 #ifdef W3_T
232  WRITE (mdst,9000) imod
233  WRITE (mdst,9001) nbi2g(:,imod)
234 #endif
235  !
236  IF ( sum(nbi2g(:,imod)) .EQ. 0 ) RETURN
237  !
238  CALL w3seto ( imod, mdse, mdst )
239  CALL w3setg ( imod, mdse, mdst )
240  CALL w3setw ( imod, mdse, mdst )
241  CALL w3seta ( imod, mdse, mdst )
242  !
243  ! -------------------------------------------------------------------- /
244  ! 1. Loop over grids
245  !
246  DO j=1, nrgrd
247  !
248  IF ( nbi2g(j,imod) .EQ. 0 ) cycle
249  !
250  CALL wmsetm ( j , mdse, mdst )
251  !
252  IF ( imod .EQ. 1 ) THEN
253  ioff = 0
254  ELSE
255  ioff = sum(nbi2g(j,1:imod-1))
256  END IF
257  !
258 #ifdef W3_T
259  WRITE (mdst,9010) nbi2g(j,imod),imod,j,ioff+1,respec(j,imod)
260 #endif
261  !
262  ! -------------------------------------------------------------------- /
263  ! 2. Allocate arrays
264  !
265 #ifdef W3_SHRD
266  IF ( bpstge(j,imod)%INIT ) THEN
267  IF ( SIZE(bpstge(j,imod)%SBPI(:,1)) .NE. nspec .OR. &
268  SIZE(bpstge(j,imod)%SBPI(1,:)) &
269  .NE. nbi2g(j,imod) ) THEN
270  DEALLOCATE ( bpstge(j,imod)%SBPI )
271  bpstge(j,imod)%INIT = .false.
272  END IF
273  END IF
274 #endif
275  !
276 #ifdef W3_SHRD
277  IF ( .NOT. bpstge(j,imod)%INIT ) THEN
278  nspec => sgrds(j)%NSPEC
279  ALLOCATE ( bpstge(j,imod)%SBPI(nspec,nbi2g(j,imod)) )
280  nspec => sgrds(imod)%NSPEC
281  bpstge(j,imod)%INIT = .true.
282  END IF
283 #endif
284  !
285 #ifdef W3_SHRD
286  IF ( respec(j,imod) ) THEN
287  ALLOCATE ( tstore(nspec,nbi2g(j,imod)) )
288  sbpi => tstore
289  ELSE
290  sbpi => bpstge(j,imod)%SBPI
291  END IF
292 #endif
293  !
294 #ifdef W3_MPI
295  naproc => outpts(j)%NAPROC
296  ALLOCATE ( irq(nbi2g(j,imod)*naproc+naproc) )
297  ALLOCATE ( bpstge(j,imod)%TSTORE(nspec,nbi2g(j,imod)) )
298  naproc => outpts(imod)%NAPROC
299 #endif
300  !
301 #ifdef W3_MPI
302  nrq => bpstge(j,imod)%NRQBPS
303  sbpi => bpstge(j,imod)%TSTORE
304 #endif
305  !
306 #ifdef W3_MPI
307  nrq = 0
308  irq = 0
309 #endif
310  !
311  ! -------------------------------------------------------------------- /
312  ! 3. Set the time
313  ! Note that with MPI the send needs to be posted to the local
314  ! processor too to make time management possible.
315  !
316 #ifdef W3_T
317  WRITE (mdst,9030) time
318 #endif
319 #ifdef W3_MPIT
320  WRITE (mdst,9080)
321 #endif
322  !
323 #ifdef W3_SHRD
324  bpstge(j,imod)%VTIME = time
325 #endif
326  !
327 #ifdef W3_MPI
328  IF ( iaproc .EQ. 1 ) THEN
329  bpstge(j,imod)%STIME = time
330  itag = mtag0 + imod + (j-1)*nrgrd
331  IF ( itag .GT. mtag1 ) THEN
332  WRITE (mdse,1001)
333  CALL extcde (1001)
334  END IF
335  DO ip=1, nmproc
336  IF ( allprc(ip,j) .NE. 0 .AND. &
337  allprc(ip,j) .LE. outpts(j)%NAPROC ) THEN
338  nrq = nrq + 1
339  CALL mpi_isend ( bpstge(j,imod)%STIME, 2, &
340  mpi_integer, ip-1, itag, &
341  mpi_comm_mwave, irq(nrq), &
342  ierr_mpi )
343 #endif
344 #ifdef W3_MPIT
345  WRITE (mdst,9081) nrq, ip, itag-mtag0, &
346  irq(nrq), ierr_mpi
347 #endif
348 #ifdef W3_MPI
349  END IF
350  END DO
351  END IF
352 #endif
353  !
354  ! -------------------------------------------------------------------- /
355  ! 4. Stage the spectral data
356  !
357  DO i=1, nbi2g(j,imod)
358  !
359  isea = nbi2s(ioff+i,2)
360 #ifdef W3_SHRD
361  jsea = isea
362 #endif
363 #ifdef W3_DIST
364  CALL init_get_jsea_isproc(isea, jsea, isproc)
365  IF ( isproc .NE. iaproc ) cycle
366 #endif
367 #ifdef W3_MPI
368  it0 = mtag0 + nrgrd**2 + sum(nbi2g(1:j-1,:)) + &
369  sum(nbi2g(j,1:imod-1))
370 #endif
371  !
372  DO is=1, nspec
373  sbpi(is,i) = va(is,jsea) * sig2(is) / cg(1+(is-1)/nth,isea)
374  END DO
375  !
376 #ifdef W3_MPI
377  DO ip=1, nmproc
378  IF ( allprc(ip,j) .NE. 0 .AND. &
379  allprc(ip,j) .LE. outpts(j)%NAPROC ) THEN
380  nrq = nrq + 1
381  itag = it0 + i
382  IF ( itag .GT. mtag1 ) THEN
383  WRITE (mdse,1001)
384  CALL extcde (1001)
385  END IF
386  CALL mpi_isend ( sbpi(1,i), nspec, mpi_real, &
387  ip-1, itag, mpi_comm_mwave, &
388  irq(nrq), ierr_mpi )
389 #endif
390 #ifdef W3_MPIT
391  WRITE (mdst,9082) nrq, jsea, ip, itag-mtag0, &
392  irq(nrq), ierr_mpi
393 #endif
394 #ifdef W3_MPI
395  END IF
396  END DO
397 #endif
398  !
399  END DO
400  !
401 #ifdef W3_MPIT
402  WRITE (mdst,9083)
403  WRITE (mdst,9084) nrq
404 #endif
405  !
406 #ifdef W3_MPI
407  IF ( nrq .GT. 0 ) THEN
408  ALLOCATE ( bpstge(j,imod)%IRQBPS(nrq) )
409  bpstge(j,imod)%IRQBPS = irq(:nrq)
410  ELSE
411  DEALLOCATE ( bpstge(j,imod)%TSTORE )
412  END IF
413 #endif
414  !
415 #ifdef W3_MPI
416  DEALLOCATE ( irq )
417 #endif
418  !
419  ! -------------------------------------------------------------------- /
420  ! 5. Convert spectra ( !/SHRD only )
421  !
422 #ifdef W3_SHRD
423  IF ( respec(j,imod) ) THEN
424  sbpi => bpstge(j,imod)%SBPI
425  CALL w3cspc ( tstore, nk, nth, xfr, fr1, th(1), &
426  sbpi, sgrds(j)%NK, sgrds(j)%NTH, sgrds(j)%XFR, &
427  sgrds(j)%FR1, sgrds(j)%TH(1), nbi2g(j,imod), &
428  mdst, mdse, sgrds(j)%FACHFE )
429  DEALLOCATE ( tstore )
430  END IF
431 #endif
432  !
433  ! ... End of loop over grids
434  !
435  END DO
436  !
437  RETURN
438  !
439  ! Formats
440  !
441 #ifdef W3_MPI
442 1001 FORMAT (/' *** ERROR WMIOBS : REQUESTED MPI TAG EXCEEDS', &
443  ' UPPER BOUND (MTAG1) ***')
444 #endif
445 #ifdef W3_T
446 9000 FORMAT ( ' TEST WMIOBS : STAGING DATA FROM GRID ',i3)
447 9001 FORMAT ( ' TEST WMIOBS : NR. OF SPECTRA PER GRID : '/ &
448  ' ',25i4)
449 #endif
450  !
451 #ifdef W3_T
452 9010 FORMAT ( ' TEST WMIOBS : STAGING',i4,' SPECTRA FROM GRID ', &
453  i3,' TO GRID ',i3/ &
454  ' STARTING WITH SPECTRUM ',i4, &
455  ', RESPEC =',l2)
456 #endif
457  !
458 #ifdef W3_T
459 9030 FORMAT ( ' TEST WMIOBS : TIME :',i10.8,i7.6)
460 #endif
461  !
462 #ifdef W3_MPIT
463 9080 FORMAT (/' MPIT WMIOBS: COMMUNICATION CALLS '/ &
464  ' +------+------+------+------+--------------+'/ &
465  ' | IH | ID | TARG | TAG | handle err |'/ &
466  ' +------+------+------+------+--------------+')
467 9081 FORMAT ( ' |',i5,' | TIME |',2(i5,' |'),i9,i4,' |')
468 9082 FORMAT ( ' |',i5,' |',i5,' |',2(i5,' |'),i9,i4,' |')
469 9083 FORMAT ( ' +------+------+------+------+--------------+')
470 9084 FORMAT ( ' MPIT WMIOBS: NRQBPT:',i10/)
471 #endif
472  !/
473  !/ End of WMIOBS ----------------------------------------------------- /
474  !/

References wmmdatmd::allprc, wmmdatmd::bpstge, w3adatmd::cg, w3servmd::extcde(), w3gdatmd::fr1, w3odatmd::iaproc, include(), w3parall::init_get_jsea_isproc(), wmmdatmd::mdse, wmmdatmd::mdst, wmmdatmd::mpi_comm_mwave, wmmdatmd::mtag0, wmmdatmd::mtag1, w3odatmd::naproc, wmmdatmd::nbi2g, wmmdatmd::nbi2s, w3gdatmd::nk, wmmdatmd::nmproc, wmmdatmd::nrgrd, w3gdatmd::nspec, w3gdatmd::nth, w3odatmd::outpts, wmmdatmd::respec, w3gdatmd::sgrds, w3gdatmd::sig2, w3servmd::strace(), w3gdatmd::th, w3wdatmd::time, w3wdatmd::va, w3cspcmd::w3cspc(), w3adatmd::w3seta(), w3gdatmd::w3setg(), w3odatmd::w3seto(), w3wdatmd::w3setw(), wmmdatmd::wmsetm(), and w3gdatmd::xfr.

Referenced by wminitmd::wminit(), wminitmd::wminitnml(), and wmwavemd::wmwave().

◆ wmioef()

subroutine wminiomd::wmioef ( integer, intent(in)  IMOD)

Finalize staging of internal same-rank data in the data structure EQSTGE (MPI only).

Post appropriate 'wait' functions to assure that the communication has finished.

Parameters
[in]IMODModel number of grid from which data has been staged.
Author
H. L. Tolman
Date
25-May-2006

Definition at line 3399 of file wminiomd.F90.

3399  !/
3400  !/ +-----------------------------------+
3401  !/ | WAVEWATCH III NOAA/NCEP |
3402  !/ | H. L. Tolman |
3403  !/ | FORTRAN 90 |
3404  !/ | Last update : 25-May-2006 !
3405  !/ +-----------------------------------+
3406  !/
3407  !/ 25-May-2006 : Origination. ( version 3.09 )
3408  !/
3409  ! 1. Purpose :
3410  !
3411  ! Finalize staging of internal same-rank data in the data
3412  ! structure EQSTGE (MPI only).
3413  !
3414  ! 2. Method :
3415  !
3416  ! Post appropriate 'wait' functions to assure that the
3417  ! communication has finished.
3418  !
3419  ! 3. Parameters :
3420  !
3421  ! Parameter list
3422  ! ----------------------------------------------------------------
3423  ! IMOD Int. I Model number of grid from which data has
3424  ! been staged.
3425  ! ----------------------------------------------------------------
3426  !
3427  ! 4. Subroutines used :
3428  !
3429  ! Name Type Module Description
3430  ! ----------------------------------------------------------------
3431  ! STRACE Subr. W3SERVMD Subroutine tracing.
3432  ! ----------------------------------------------------------------
3433  !
3434  ! 5. Called by :
3435  !
3436  ! Name Type Module Description
3437  ! ----------------------------------------------------------------
3438  ! WMWAVE Subr WMWAVEMD Multi-grid wave model.
3439  ! ----------------------------------------------------------------
3440  !
3441  ! 6. Error messages :
3442  !
3443  ! 7. Remarks :
3444  !
3445  ! 8. Structure :
3446  !
3447  ! See source code.
3448  !
3449  ! 9. Switches :
3450  !
3451  ! !/SHRD Shared/distributed memory models.
3452  ! !/DIST
3453  ! !/MPI
3454  !
3455  ! !/S Enable subroutine tracing.
3456  ! !/T Test output.
3457  !
3458  ! 10. Source code :
3459  !
3460  !/ ------------------------------------------------------------------- /
3461  !
3462  USE wmmdatmd
3463  !
3464 #ifdef W3_S
3465  USE w3servmd, ONLY: strace
3466 #endif
3467  !
3468  IMPLICIT NONE
3469  !
3470 #ifdef W3_MPI
3471  include "mpif.h"
3472 #endif
3473  !/
3474  !/ ------------------------------------------------------------------- /
3475  !/ Parameter list
3476  !/
3477  INTEGER, INTENT(IN) :: IMOD
3478  !/
3479  !/ ------------------------------------------------------------------- /
3480  !/ Local parameters
3481  !/
3482  INTEGER :: J
3483 #ifdef W3_MPI
3484  INTEGER :: IERR_MPI
3485  INTEGER, POINTER :: NRQ, IRQ(:)
3486  INTEGER, ALLOCATABLE :: STATUS(:,:)
3487 #endif
3488 #ifdef W3_S
3489  INTEGER, SAVE :: IENT = 0
3490 #endif
3491  !/
3492 #ifdef W3_S
3493  CALL strace (ient, 'WMIOEF')
3494 #endif
3495  !
3496  ! -------------------------------------------------------------------- /
3497  ! 0. Initializations
3498  !
3499 #ifdef W3_T
3500  WRITE (mdst,9000) imod
3501 #endif
3502  !
3503  ! -------------------------------------------------------------------- /
3504  ! 1. Loop over grids
3505  !
3506  DO j=1, nrgrd
3507  !
3508 #ifdef W3_MPI
3509  nrq => eqstge(j,imod)%NRQEQS
3510 #endif
3511  !
3512  ! 1.a Nothing to finalize
3513  !
3514 #ifdef W3_MPI
3515  IF ( nrq .EQ. 0 ) cycle
3516  irq => eqstge(j,imod)%IRQEQS
3517 #endif
3518  !
3519  ! 1.b Wait for communication to end
3520  !
3521 #ifdef W3_MPI
3522  ALLOCATE ( status(mpi_status_size,nrq) )
3523  CALL mpi_waitall ( nrq, irq, status, ierr_mpi )
3524  DEALLOCATE ( status )
3525 #endif
3526  !
3527  ! 1.c Reset arrays and counter
3528  !
3529 #ifdef W3_MPI
3530  DEALLOCATE ( eqstge(j,imod)%IRQEQS, &
3531  eqstge(j,imod)%TSTORE, &
3532  eqstge(j,imod)%OUTDAT )
3533  nrq = 0
3534 #endif
3535  !
3536 #ifdef W3_T
3537  WRITE (mdst,9010) j
3538 #endif
3539  !
3540  END DO
3541  !
3542  RETURN
3543  !
3544  ! Formats
3545  !
3546 #ifdef W3_T
3547 9000 FORMAT ( ' TEST WMIOEF : FINALIZE STAGING DATA FROM GRID ',i3)
3548 9010 FORMAT ( ' TEST WMIOEF : FINISHED WITH TARGET ',i3)
3549 #endif
3550  !/
3551  !/ End of WMIOEF ----------------------------------------------------- /
3552  !/

References wmmdatmd::eqstge, include(), wmmdatmd::mdst, wmmdatmd::nrgrd, and w3servmd::strace().

Referenced by wmwavemd::wmwave().

◆ wmioeg()

subroutine wminiomd::wmioeg ( integer, intent(in)  IMOD,
logical, intent(out), optional  DONE 
)

Gather internal same-rank data for a given model.

For distributed memory version first receive all staged data. After staged data is present, average, convert as necessary, and store in basic spectral arrays.

Using storage array EQSTGE and time stamps.

Parameters
[in]IMODModel number of grid from which data is to be gathered.
[out]DONEFlag for completion of operation (opt).
Author
H. L. Tolman
Date
22-Jan-2007

Definition at line 2820 of file wminiomd.F90.

2820  !/
2821  !/ +-----------------------------------+
2822  !/ | WAVEWATCH III NOAA/NCEP |
2823  !/ | H. L. Tolman |
2824  !/ | FORTRAN 90 |
2825  !/ | Last update : 22-Jan-2007 !
2826  !/ +-----------------------------------+
2827  !/
2828  !/ 25-May-2006 : Origination. ( version 3.09 )
2829  !/ 21-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 )
2830  !/ 22-Jan-2007 : Adding NAVMAX. ( version 3.10 )
2831  !/
2832  ! 1. Purpose :
2833  !
2834  ! Gather internal same-rank data for a given model.
2835  !
2836  ! 2. Method :
2837  !
2838  ! For distributed memory version first receive all staged data.
2839  ! After staged data is present, average, convert as necessary,
2840  ! and store in basic spectral arrays.
2841  !
2842  ! 2. Method :
2843  !
2844  ! Using storage array EQSTGE and time stamps.
2845  !
2846  ! 3. Parameters :
2847  !
2848  ! Parameter list
2849  ! ----------------------------------------------------------------
2850  ! IMOD Int. I Model number of grid from which data is to
2851  ! be gathered.
2852  ! DONE Log. O Flag for completion of operation (opt).
2853  ! ----------------------------------------------------------------
2854  !
2855  ! 4. Subroutines used :
2856  !
2857  ! Name Type Module Description
2858  ! ----------------------------------------------------------------
2859  ! W3SETG, W3SETW, W3SETA, W3SETO
2860  ! Subr. WxxDATMD Manage data structures.
2861  ! W3CSPC Subr. W3CSPCMD Spectral grid conversion.
2862  ! STRACE Sur. W3SERVMD Subroutine tracing.
2863  ! DSEC21 Func. W3TIMEMD Difference between times.
2864  ! ----------------------------------------------------------------
2865  !
2866  ! 5. Called by :
2867  !
2868  ! Name Type Module Description
2869  ! ----------------------------------------------------------------
2870  ! WMWAVE Subr WMWAVEMD Multi-grid wave model.
2871  ! ----------------------------------------------------------------
2872  !
2873  ! 6. Error messages :
2874  !
2875  ! See FORMAT labels 1001-1002.
2876  !
2877  ! 7. Remarks :
2878  !
2879  ! 8. Structure :
2880  !
2881  ! 9. Switches :
2882  !
2883  ! !/SHRD Shared/distributed memory models.
2884  ! !/DIST
2885  ! !/MPI
2886  !
2887  ! !/S Enable subroutine tracing.
2888  ! !/T Enable test output
2889  ! !/MPIT
2890  !
2891  ! 10. Source code :
2892  !
2893  !/ ------------------------------------------------------------------- /
2894  !
2895  USE w3gdatmd
2896  USE w3wdatmd
2897  USE w3adatmd
2898  USE w3odatmd
2899  USE wmmdatmd
2900  !
2901  USE w3cspcmd, ONLY: w3cspc
2902  USE w3timemd, ONLY: dsec21
2903  USE w3servmd, ONLY: extcde
2904 #ifdef W3_PDLIB
2905  use yownodepool, only: npa
2906  USE yowexchangemodule, only : pdlib_exchange2dreal_zero
2907 #endif
2908 #ifdef W3_S
2909  USE w3servmd, ONLY: strace
2910 #endif
2911  !
2912  IMPLICIT NONE
2913  !
2914 #ifdef W3_MPI
2915  include "mpif.h"
2916 #endif
2917  !/
2918  !/ ------------------------------------------------------------------- /
2919  !/ Parameter list
2920  !/
2921  INTEGER, INTENT(IN) :: IMOD
2922  LOGICAL, INTENT(OUT), OPTIONAL :: DONE
2923  !/
2924  !/ ------------------------------------------------------------------- /
2925  !/ Local parameters
2926  !/
2927  INTEGER :: J, I, ISEA, JSEA, IA, IS
2928 #ifdef W3_S
2929  INTEGER, SAVE :: IENT = 0
2930 #endif
2931 #ifdef W3_MPI
2932  INTEGER :: IT0, ITAG, IFROM, IERR_MPI, &
2933  NA, IP, I1, I2
2934 #endif
2935 #ifdef W3_MPIT
2936  INTEGER :: ICOUNT
2937 #endif
2938  INTEGER, POINTER :: VTIME(:)
2939 #ifdef W3_MPI
2940  INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:)
2941 #endif
2942  REAL :: DTTST, WGHT
2943  REAL, POINTER :: SPEC1(:,:), SPEC2(:,:), SPEC(:,:)
2944 #ifdef W3_MPI
2945  REAL, POINTER :: SEQL(:,:,:)
2946  LOGICAL :: FLAGOK
2947  LOGICAL :: FLAG
2948 #endif
2949  !/
2950 #ifdef W3_S
2951  CALL strace (ient, 'WMIOEG')
2952 #endif
2953  !
2954  ! -------------------------------------------------------------------- /
2955  ! 0. Initializations
2956  !
2957 #ifdef W3_T
2958  WRITE (mdst,9000) imod
2959  WRITE (mdst,9001) 'NREC', eqstge(imod,:)%NREC
2960 #endif
2961  !
2962  IF ( PRESENT(done) ) done = .false.
2963  !
2964  IF ( eqstge(imod,imod)%NREC .EQ. 0 ) THEN
2965  IF ( PRESENT(done) ) done = .true.
2966 #ifdef W3_T
2967  WRITE (mdst,9002)
2968 #endif
2969  RETURN
2970  END IF
2971  !
2972  CALL w3seto ( imod, mdse, mdst )
2973  CALL w3setg ( imod, mdse, mdst )
2974  CALL w3setw ( imod, mdse, mdst )
2975  CALL w3seta ( imod, mdse, mdst )
2976  !
2977  ! -------------------------------------------------------------------- /
2978  ! 1. Testing / gathering data in staging arrays
2979  !
2980 #ifdef W3_T
2981  WRITE (mdst,9010) time
2982 #endif
2983  !
2984  ! 1.a Shared memory version, test valid times. - - - - - - - - - - - - /
2985  !
2986 #ifdef W3_SHRD
2987  DO j=1, nrgrd
2988 #endif
2989  !
2990 #ifdef W3_SHRD
2991  IF ( imod .EQ. j ) cycle
2992  IF ( eqstge(imod,j)%NREC .EQ. 0 ) cycle
2993 #endif
2994  !
2995 #ifdef W3_SHRD
2996  vtime => eqstge(imod,j)%VTIME
2997  IF ( vtime(1) .EQ. -1 ) RETURN
2998  dttst = dsec21( time, vtime )
2999  IF ( dttst .NE. 0. ) RETURN
3000 #endif
3001  !
3002 #ifdef W3_SHRD
3003  END DO
3004 #endif
3005  !
3006  ! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - /
3007  !
3008 #ifdef W3_MPIT
3009  WRITE (mdst,9011) eqlsta(imod)
3010 #endif
3011  !
3012  ! 1.b.1 EQLSTA = 0
3013  ! Check if staging arrays are initialized.
3014  ! Post the proper receives.
3015  !
3016 #ifdef W3_MPI
3017  IF ( eqlsta(imod) .EQ. 0 ) THEN
3018 #endif
3019  !
3020 #ifdef W3_MPI
3021  nrq => mdatas(imod)%NRQEQG
3022  nrq = 0
3023  DO j=1, nrgrd
3024  IF ( j .EQ. imod ) cycle
3025  nrq = nrq + eqstge(imod,j)%NREC * &
3026  eqstge(imod,j)%NAVMAX
3027  END DO
3028  ALLOCATE ( irq(nrq) )
3029  irq = 0
3030  nrq = 0
3031 #endif
3032  !
3033 #ifdef W3_MPI
3034  DO j=1, nrgrd
3035  IF ( imod .EQ. j ) cycle
3036  IF ( eqstge(imod,j)%NREC .EQ. 0 ) cycle
3037 #endif
3038  !
3039  ! ..... Check valid time to determine staging.
3040  !
3041 #ifdef W3_MPI
3042  vtime => eqstge(imod,j)%VTIME
3043  IF ( vtime(1) .EQ. -1 ) THEN
3044  dttst = 1.
3045  ELSE
3046  dttst = dsec21( time, vtime )
3047  END IF
3048 #endif
3049 #ifdef W3_MPIT
3050  WRITE (mdst,9013) vtime, dttst
3051 #endif
3052  !
3053  ! ..... Post receives for data gather
3054  !
3055 #ifdef W3_MPI
3056  IF ( dttst .NE. 0. ) THEN
3057 #endif
3058 #ifdef W3_MPIT
3059  WRITE (mdst,9014) j
3060 #endif
3061  !
3062  ! ..... Spectra
3063  !
3064 #ifdef W3_MPI
3065  it0 = mtag2 + 1
3066  seql => eqstge(imod,j)%SEQL
3067 #endif
3068  !
3069 #ifdef W3_MPI
3070  DO i=1, eqstge(imod,j)%NREC
3071  jsea = eqstge(imod,j)%JSEA(i)
3072  na = eqstge(imod,j)%NAVG(i)
3073  DO ia=1, na
3074  ip = eqstge(imod,j)%RIP(i,ia)
3075  itag = eqstge(imod,j)%RTG(i,ia) + it0
3076  IF ( ip .NE. improc ) THEN
3077  nrq = nrq + 1
3078  CALL mpi_irecv ( seql(1,i,ia), &
3079  sgrds(j)%NSPEC, mpi_real, &
3080  ip-1, itag, mpi_comm_mwave, &
3081  irq(nrq), ierr_mpi )
3082 #endif
3083 #ifdef W3_MPIT
3084  WRITE (mdst,9016) nrq, jsea, ip, &
3085  itag-mtag2, irq(nrq), ierr_mpi
3086 #endif
3087 #ifdef W3_MPI
3088  END IF
3089  END DO
3090  END DO
3091 #endif
3092  !
3093  ! ..... End IF for posting receives 1.b.1
3094  !
3095 #ifdef W3_MPIT
3096  WRITE (mdst,9017)
3097 #endif
3098 #ifdef W3_MPI
3099  END IF
3100 #endif
3101  !
3102  ! ..... End grid loop J in 1.b.1
3103  !
3104 #ifdef W3_MPI
3105  END DO
3106 #endif
3107 #ifdef W3_MPIT
3108  WRITE (mdst,9018) nrq
3109 #endif
3110  !
3111 #ifdef W3_MPI
3112  IF ( nrq .NE. 0 ) THEN
3113  ALLOCATE ( mdatas(imod)%IRQEQG(nrq) )
3114  mdatas(imod)%IRQEQG = irq(1:nrq)
3115  END IF
3116 #endif
3117  !
3118 #ifdef W3_MPI
3119  DEALLOCATE ( irq )
3120 #endif
3121  !
3122  ! ..... Reset status
3123  !
3124 #ifdef W3_MPI
3125  IF ( nrq .GT. 0 ) THEN
3126  eqlsta(imod) = 1
3127 #endif
3128 #ifdef W3_MPIT
3129  WRITE (mdst,9011) eqlsta(imod)
3130 #endif
3131 #ifdef W3_MPI
3132  END IF
3133 #endif
3134  !
3135  ! ..... End IF in 1.b.1
3136  !
3137 #ifdef W3_MPI
3138  END IF
3139 #endif
3140  !
3141  ! 1.b.2 EQLSTA = 1
3142  ! Wait for communication to finish.
3143  ! If DONE defined, check if done, otherwise wait.
3144  !
3145 #ifdef W3_MPI
3146  IF ( eqlsta(imod) .EQ. 1 ) THEN
3147 #endif
3148  !
3149 #ifdef W3_MPI
3150  nrq => mdatas(imod)%NRQEQG
3151  irq => mdatas(imod)%IRQEQG
3152  ALLOCATE ( status(mpi_status_size,nrq) )
3153 #endif
3154  !
3155  ! ..... Test communication if DONE is present, wait otherwise
3156  !
3157 #ifdef W3_MPI
3158  IF ( PRESENT(done) ) THEN
3159 #endif
3160  !
3161 #ifdef W3_MPI
3162  CALL mpi_testall ( nrq, irq, flagok, status, &
3163  ierr_mpi )
3164 #endif
3165  !
3166 #ifdef W3_MPIT
3167  icount = 0
3168  DO i=1, nrq
3169  CALL mpi_test ( irq(i), flag, status(1,1), &
3170  ierr_mpi )
3171  flagok = flagok .AND. flag
3172  IF ( flag ) icount = icount + 1
3173  END DO
3174  WRITE (mdst,9019) 100. * real(icount) / real(nrq)
3175 #endif
3176  !
3177 #ifdef W3_MPI
3178  ELSE
3179 #endif
3180  !
3181 #ifdef W3_MPI
3182  CALL mpi_waitall ( nrq, irq, status, ierr_mpi )
3183  flagok = .true.
3184 #endif
3185 #ifdef W3_MPIT
3186  WRITE (mdst,9019) 100.
3187 #endif
3188  !
3189 #ifdef W3_MPI
3190  END IF
3191 #endif
3192  !
3193 #ifdef W3_MPI
3194  DEALLOCATE ( status )
3195 #endif
3196  !
3197  ! ..... Go on based on FLAGOK
3198  !
3199 #ifdef W3_MPI
3200  IF ( flagok ) THEN
3201  IF ( nrq.NE.0 ) DEALLOCATE ( mdatas(imod)%IRQEQG )
3202  nrq = 0
3203  ELSE
3204  RETURN
3205  END IF
3206 #endif
3207  !
3208 #ifdef W3_MPI
3209  eqlsta(imod) = 0
3210 #endif
3211 #ifdef W3_MPIT
3212  WRITE (mdst,9011) eqlsta(imod)
3213 #endif
3214  !
3215 #ifdef W3_MPI
3216  END IF
3217 #endif
3218  !
3219  ! ..... process locally stored data
3220  !
3221 #ifdef W3_MPI
3222  DO j=1, nrgrd
3223  eqstge(imod,j)%VTIME = time
3224  IF ( j .EQ. imod ) cycle
3225  DO is=1, eqstge(imod,j)%NRQOUT
3226  i = eqstge(imod,j)%OUTDAT(is,1)
3227  i1 = eqstge(imod,j)%OUTDAT(is,2)
3228  i2 = eqstge(imod,j)%OUTDAT(is,3)
3229  eqstge(imod,j)%SEQL(:,i1,i2) = eqstge(imod,j)%TSTORE(:,i)
3230  END DO
3231  END DO
3232 #endif
3233  !
3234  ! -------------------------------------------------------------------- /
3235  ! 2. Data available, process grid by grid
3236  !
3237 #ifdef W3_T
3238  WRITE (mdst,9020)
3239 #endif
3240  !
3241  ! 2.a Do 'native' grid IMOD
3242  !
3243 #ifdef W3_T
3244  WRITE (mdst,9021) imod, eqstge(imod,imod)%NREC
3245 #endif
3246  !
3247  DO i=1, eqstge(imod,imod)%NREC
3248  jsea = eqstge(imod,imod)%JSEA(i)
3249  wght = eqstge(imod,imod)%WGHT(i)
3250  va(:,jsea) = wght * va(:,jsea)
3251  END DO
3252  !
3253  ! 2.b Loop over other grids
3254  !
3255  DO j=1, nrgrd
3256  IF ( imod.EQ.j .OR. eqstge(imod,j)%NREC.EQ.0 ) cycle
3257  !
3258 #ifdef W3_T
3259  WRITE (mdst,9022) j, eqstge(imod,j)%NREC
3260 #endif
3261  !
3262 #ifdef W3_SMC
3263  !! Use 1-1 full boundary spectra without modification. JGLi16Dec2020
3264  IF( gtype .EQ. smctype ) THEN
3265  DO i=1, eqstge(imod,j)%NREC
3266  jsea = eqstge(imod,j)%JSEA(i)
3267  va(:,jsea) = eqstge(imod,j)%SEQL(:,i,1)
3268  END DO
3269  ELSE
3270  !! Other grid boundary spectra may need conversion. JGLi12Apr2021
3271 #endif
3272  !
3273  ! 2.c Average spectra
3274  !
3275 #ifdef W3_T
3276  WRITE (mdst,9023)
3277 #endif
3278  ALLOCATE ( spec1(sgrds(j)%NSPEC,eqstge(imod,j)%NREC) )
3279  spec1 = 0.
3280  !
3281  DO i=1, eqstge(imod,j)%NREC
3282  DO ia=1, eqstge(imod,j)%NAVG(i)
3283  spec1(:,i) = spec1(:,i) + eqstge(imod,j)%SEQL(:,i,ia) * &
3284  eqstge(imod,j)%WAVG(i,ia)
3285  END DO
3286  END DO
3287  !
3288  ! 2.d Convert spectra
3289  !
3290  IF ( respec(imod,j) ) THEN
3291 #ifdef W3_T
3292  WRITE (mdst,9024)
3293 #endif
3294  ALLOCATE ( spec2(nspec,eqstge(imod,j)%NREC) )
3295  !
3296  CALL w3cspc ( spec1, sgrds(j)%NK, sgrds(j)%NTH, &
3297  sgrds(j)%XFR, sgrds(j)%FR1, sgrds(j)%TH(1), &
3298  spec2 , nk, nth, xfr, fr1, th(1), &
3299  eqstge(imod,j)%NREC, mdst, mdse, fachfe)
3300  !
3301  spec => spec2
3302  ELSE
3303  spec => spec1
3304  END IF
3305  !
3306  ! 2.e Apply to native grid
3307  !
3308  DO i=1, eqstge(imod,j)%NREC
3309  isea = eqstge(imod,j)%ISEA(i)
3310  jsea = eqstge(imod,j)%JSEA(i)
3311  wght = eqstge(imod,j)%WGHT(i)
3312 #ifdef W3_SMC
3313  !! Regular grid in same ranked SMC group uses 1-1 mapping. JGLi12Apr2021
3314  IF( ngrpsmc .GT. 0 ) THEN
3315  va(:,jsea) = spec(:,i)
3316  ELSE
3317 #endif
3318  DO is=1, nspec
3319  va(is,jsea) = va(is,jsea) + wght * &
3320  spec(is,i) / sig2(is) * cg(1+(is-1)/nth,isea)
3321  END DO
3322 #ifdef W3_SMC
3323  ENDIF !! NGRPSMC .GT. 0
3324 #endif
3325  END DO
3326  !
3327  ! 2.f Final clean up
3328  !
3329  DEALLOCATE ( spec1 )
3330  IF ( respec(imod,j) ) DEALLOCATE ( spec2 )
3331 
3332 #ifdef W3_SMC
3333  !! End GTYPE .EQ. SMCTYPE
3334  ENDIF
3335 #endif
3336 
3337  !! End 2.b J grid loop.
3338  END DO
3339  !
3340  ! -------------------------------------------------------------------- /
3341  ! 3. Set flag if requested
3342  !
3343  IF ( PRESENT(done) ) done = .true.
3344  !
3345 #ifdef W3_PDLIB
3346  CALL pdlib_exchange2dreal_zero(va)
3347 #endif
3348  !
3349  ! Formats
3350  !
3351 #ifdef W3_T
3352 9000 FORMAT ( ' TEST WMIOEG : GATHERING DATA FOR GRID ',i4)
3353 9001 FORMAT ( ' TEST WMIOEG : ',a,' PER SOURCE GRID : '/13x,20i5)
3354 9002 FORMAT ( ' TEST WMIOEG : NO DATA TO BE GATHERED')
3355 #endif
3356  !
3357 #ifdef W3_T
3358 9010 FORMAT ( ' TEST WMIOEG : TEST DATA AVAILABILITY FOR',i9.8,i7.6)
3359 #endif
3360 #ifdef W3_MPIT
3361 9011 FORMAT ( ' MPIT WMIOEG : EQLSTA =',i2)
3362 9012 FORMAT ( ' STAGING ARRAY FROM',i4,1x,a)
3363 9013 FORMAT ( ' VTIME, DTTST :',i9.8,i7.6,1x,f8.1)
3364 9014 FORMAT (/' MPIT WMIOEG : RECEIVE FROM GRID',i4/ &
3365  ' +------+------+------+------+--------------+'/ &
3366  ' | IH | ID | FROM | TAG | handle err |'/ &
3367  ' +------+------+------+------+--------------+')
3368 9016 FORMAT ( ' |',i5,' |',i5,' |',2(i5,' |'),i9,i4,' |')
3369 9017 FORMAT ( ' +------+------+------+------+--------------+'/)
3370 9018 FORMAT ( ' MPIT WMIOEG : NRQBPT:',i10/)
3371 9019 FORMAT ( ' MPIT WMIOEG : RECEIVES FINISHED :',f6.1,'%')
3372 #endif
3373  !
3374 #ifdef W3_T
3375 9020 FORMAT ( ' TEST WMIOEG : PROCESSING DATA GRID BY GRID')
3376 9021 FORMAT ( ' NATIVE GRID ',i3,' DATA :',i6)
3377 9022 FORMAT ( ' RECEIVING GRID ',i3,' DATA :',i6)
3378 9023 FORMAT ( ' AVERAGE SPECTRA')
3379 9024 FORMAT ( ' CONVERTING SPECTRA')
3380 #endif
3381  !/
3382  !/ End of WMIOEG ----------------------------------------------------- /
3383  !/

References w3adatmd::cg, w3timemd::dsec21(), wmmdatmd::eqlsta, wmmdatmd::eqstge, w3servmd::extcde(), w3gdatmd::fachfe, w3gdatmd::fr1, w3gdatmd::gtype, wmmdatmd::improc, include(), wmmdatmd::mdatas, wmmdatmd::mdse, wmmdatmd::mdst, wmmdatmd::mpi_comm_mwave, wmmdatmd::mtag2, wmmdatmd::ngrpsmc, w3gdatmd::nk, yownodepool::npa, wmmdatmd::nrgrd, w3gdatmd::nspec, w3gdatmd::nth, yowexchangemodule::pdlib_exchange2dreal_zero(), wmmdatmd::respec, w3gdatmd::sgrds, w3gdatmd::sig2, w3gdatmd::smctype, w3servmd::strace(), w3gdatmd::th, w3wdatmd::time, w3wdatmd::va, w3cspcmd::w3cspc(), w3adatmd::w3seta(), w3gdatmd::w3setg(), w3odatmd::w3seto(), w3wdatmd::w3setw(), and w3gdatmd::xfr.

Referenced by wmwavemd::wmwave().

◆ wmioes()

subroutine wminiomd::wmioes ( integer, intent(in)  IMOD)

Stage internal same-rank data in the data structure EQSTGE.

Directly fill staging arrays in shared memory version, or post the corresponding sends in distributed memory version.

Parameters
[in]IMODModel number of grid from which data is to be staged.
Author
H. L. Tolman
Date
28-Sep-2016

Definition at line 2493 of file wminiomd.F90.

2493  !/
2494  !/ +-----------------------------------+
2495  !/ | WAVEWATCH III NOAA/NCEP |
2496  !/ | H. L. Tolman |
2497  !/ | FORTRAN 90 |
2498  !/ | Last update : 28-Sep-2016 !
2499  !/ +-----------------------------------+
2500  !/
2501  !/ 25-May-2006 : Origination. ( version 3.09 )
2502  !/ 21-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 )
2503  !/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 )
2504  !/ 16-Dec-2020 : SMC grid use 1-1 spectral exchanges.( version 7.13 )
2505  !/
2506  ! 1. Purpose :
2507  !
2508  ! Stage internal same-rank data in the data structure EQSTGE.
2509  !
2510  ! 2. Method :
2511  !
2512  ! Directly fill staging arrays in shared memory version, or post
2513  ! the corresponding sends in distributed memory version.
2514  !
2515  ! 3. Parameters :
2516  !
2517  ! Parameter list
2518  ! ----------------------------------------------------------------
2519  ! IMOD Int. I Model number of grid from which data is to
2520  ! be staged.
2521  ! ----------------------------------------------------------------
2522  !
2523  ! 4. Subroutines used :
2524  !
2525  ! Name Type Module Description
2526  ! ----------------------------------------------------------------
2527  ! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM
2528  ! Subr. WxxDATMD Manage data structures.
2529  ! STRACE Subr. W3SERVMD Subroutine tracing.
2530  ! EXTCDE Sur. Id. Program abort.
2531  ! DSEC21 Func. W3TIMEMD Difference between times.
2532  ! ----------------------------------------------------------------
2533  !
2534  ! 5. Called by :
2535  !
2536  ! Name Type Module Description
2537  ! ----------------------------------------------------------------
2538  ! WMWAVE Subr WMWAVEMD Multi-grid wave model.
2539  ! ----------------------------------------------------------------
2540  !
2541  ! 6. Error messages :
2542  !
2543  ! See FORMAT label 1001.
2544  !
2545  ! 7. Remarks :
2546  !
2547  ! 8. Structure :
2548  !
2549  ! See source code.
2550  !
2551  ! 9. Switches :
2552  !
2553  ! !/SHRD Shared/distributed memory models.
2554  ! !/DIST
2555  ! !/MPI
2556  !
2557  ! !/S Enable subroutine tracing.
2558  ! !/T Enable test output
2559  ! !/MPIT
2560  !
2561  ! 10. Source code :
2562  !
2563  !/ ------------------------------------------------------------------- /
2564  !
2565  USE w3gdatmd
2566  USE w3wdatmd
2567  USE w3adatmd
2568  USE w3odatmd
2569  USE wmmdatmd
2570  !
2571  USE w3servmd, ONLY: extcde
2572 #ifdef W3_S
2573  USE w3servmd, ONLY: strace
2574 #endif
2575  USE w3timemd, ONLY: dsec21
2576  !
2577  IMPLICIT NONE
2578  !
2579 #ifdef W3_MPI
2580  include "mpif.h"
2581 #endif
2582  !/
2583  !/ ------------------------------------------------------------------- /
2584  !/ Parameter list
2585  !/
2586  INTEGER, INTENT(IN) :: IMOD
2587  !/
2588  !/ ------------------------------------------------------------------- /
2589  !/ Local parameters
2590  !/
2591  INTEGER :: J, NR, I, ISEA, JSEA, IS, I1, I2
2592 #ifdef W3_MPI
2593  INTEGER :: IT0, ITAG, IP, IERR_MPI
2594 #endif
2595 #ifdef W3_S
2596  INTEGER, SAVE :: IENT = 0
2597 #endif
2598 #ifdef W3_MPI
2599  INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:)
2600 #endif
2601 #ifdef W3_SHRD
2602  REAL, POINTER :: SEQL(:,:,:)
2603 #endif
2604 #ifdef W3_MPI
2605  REAL, POINTER :: SEQL(:,:)
2606 #endif
2607  !/
2608 #ifdef W3_S
2609  CALL strace (ient, 'WMIOES')
2610 #endif
2611  !
2612  ! -------------------------------------------------------------------- /
2613  ! 0. Initializations
2614  !
2615 #ifdef W3_T
2616  WRITE (mdst,9000) imod
2617  WRITE (mdst,9001) eqstge(:,imod)%NSND
2618 #endif
2619  !
2620  CALL w3seto ( imod, mdse, mdst )
2621  CALL w3setg ( imod, mdse, mdst )
2622  CALL w3setw ( imod, mdse, mdst )
2623  CALL w3seta ( imod, mdse, mdst )
2624  !
2625  ! -------------------------------------------------------------------- /
2626  ! 1. Loop over grids
2627  !
2628  DO j=1, nrgrd
2629  !
2630  IF ( j .EQ. imod ) cycle
2631  nr = eqstge(j,imod)%NSND
2632  !
2633 #ifdef W3_T
2634  IF ( nr .EQ. 0 ) THEN
2635  WRITE (mdst,9010) j, nr
2636  ELSE
2637  WRITE (mdst,9011) j, nr, dsec21(time,tsync(:,j))
2638  END IF
2639 #endif
2640  !
2641  IF ( nr .EQ. 0 ) cycle
2642  IF ( dsec21(time,tsync(:,j)) .NE. 0. ) stop
2643  !
2644  !!Li Report sending for test. JGLi22Dec2020
2645  ! WRITE (MDSE,*) ' ***WMIOES: Send to GRID', J, &
2646  ! ' from', IMOD, ' NS=', NR, ' on IP', IMPROC
2647  ! -------------------------------------------------------------------- /
2648  ! 2. Allocate arrays and/or point pointers
2649  !
2650 #ifdef W3_SHRD
2651  seql => eqstge(j,imod)%SEQL
2652 #endif
2653 #ifdef W3_MPI
2654  ALLOCATE ( eqstge(j,imod)%TSTORE(nspec,nr) )
2655  seql => eqstge(j,imod)%TSTORE
2656 #endif
2657  !
2658 #ifdef W3_MPI
2659  ALLOCATE ( eqstge(j,imod)%IRQEQS(nr) , &
2660  eqstge(j,imod)%OUTDAT(nr,3) )
2661 #endif
2662  !
2663 #ifdef W3_MPI
2664  nrq => eqstge(j,imod)%NRQEQS
2665  nrqout => eqstge(j,imod)%NRQOUT
2666  irq => eqstge(j,imod)%IRQEQS
2667  outdat => eqstge(j,imod)%OUTDAT
2668  nrq = 0
2669  nrqout = 0
2670  irq = 0
2671 #endif
2672  !
2673  ! -------------------------------------------------------------------- /
2674  ! 3. Set the time
2675  ! Note that with MPI the send needs to be posted to the local
2676  ! processor too to make time management possible.
2677  !
2678 #ifdef W3_T
2679  WRITE (mdst,9030) time
2680 #endif
2681  !
2682 #ifdef W3_SHRD
2683  eqstge(j,imod)%VTIME = time
2684 #endif
2685  !
2686  ! -------------------------------------------------------------------- /
2687  ! 4. Stage the spectral data
2688  !
2689 #ifdef W3_MPIT
2690  WRITE (mdst,9080)
2691 #endif
2692 #ifdef W3_MPI
2693  it0 = mtag2 + 1
2694 #endif
2695  !
2696  DO i=1, nr
2697  !
2698  isea = eqstge(j,imod)%SIS(i)
2699  jsea = eqstge(j,imod)%SJS(i)
2700  i1 = eqstge(j,imod)%SI1(i)
2701  i2 = eqstge(j,imod)%SI2(i)
2702 #ifdef W3_MPI
2703  ip = eqstge(j,imod)%SIP(i)
2704  itag = eqstge(j,imod)%STG(i) + it0
2705  IF ( itag .GT. mtag_ub ) THEN
2706  WRITE (mdse,1001)
2707  CALL extcde (1001)
2708  END IF
2709 #endif
2710  !
2711 #ifdef W3_SMC
2712  !! Equal ranked SMC grids simply pass the wave action. JGLi16Dec2020
2713 #endif
2714 #ifdef W3_MPI
2715 #ifdef W3_SMC
2716  IF( gtype .EQ. smctype ) THEN
2717  seql(:, i) = va(:, jsea)
2718  ELSE
2719 #endif
2720 #endif
2721  DO is=1, nspec
2722 #ifdef W3_SHRD
2723  seql(is,i1,i2) = va(is,jsea) * sig2(is) &
2724  / cg(1+(is-1)/nth,isea)
2725 #endif
2726 #ifdef W3_MPI
2727  seql( is,i ) = va(is,jsea) * sig2(is) &
2728  / cg(1+(is-1)/nth,isea)
2729 #endif
2730  END DO
2731 #ifdef W3_MPI
2732 #ifdef W3_SMC
2733  ENDIF
2734 #endif
2735 #endif
2736  !
2737 #ifdef W3_MPI
2738  IF ( ip .NE. improc ) THEN
2739  nrq = nrq + 1
2740  CALL mpi_isend ( seql(1,i), nspec, mpi_real, ip-1, &
2741  itag, mpi_comm_mwave, irq(nrq), ierr_mpi )
2742 #endif
2743 #ifdef W3_MPIT
2744  WRITE (mdst,9082) nrq, jsea, ip, itag-mtag2, &
2745  irq(nrq), ierr_mpi
2746 #endif
2747 #ifdef W3_MPI
2748  ELSE
2749  nrqout = nrqout + 1
2750  outdat(nrqout,1) = i
2751  outdat(nrqout,2) = i1
2752  outdat(nrqout,3) = i2
2753  END IF
2754 #endif
2755  !
2756  END DO
2757  !
2758 #ifdef W3_MPIT
2759  WRITE (mdst,9083)
2760  WRITE (mdst,9084) nrq
2761 #endif
2762  !
2763  END DO
2764  !
2765  RETURN
2766  !
2767  ! Formats
2768  !
2769 #ifdef W3_MPI
2770 1001 FORMAT (/' *** ERROR WMIOES : REQUESTED MPI TAG EXCEEDS', &
2771  ' UPPER BOUND (MTAG_UB) ***')
2772 #endif
2773 #ifdef W3_T
2774 9000 FORMAT ( ' TEST WMIOES : STAGING DATA FROM GRID ',i3)
2775 9001 FORMAT ( ' TEST WMIOES : NR. OF SPECTRA PER GRID : '/ &
2776  ' ',15i6)
2777 #endif
2778  !
2779 #ifdef W3_T
2780 9010 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',i3, &
2781  ' NR = ',i6)
2782 9011 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',i3, &
2783  ' NR = ',i6,' TIME GAP = ',f8.1)
2784 #endif
2785  !
2786 #ifdef W3_T
2787 9030 FORMAT ( ' TEST WMIOES : TIME :',i10.8,i7.6)
2788 #endif
2789  !/
2790 #ifdef W3_MPIT
2791 9080 FORMAT (/' MPIT WMIOES: COMMUNICATION CALLS '/ &
2792  ' +------+------+------+------+--------------+'/ &
2793  ' | IH | ID | TARG | TAG | handle err |'/ &
2794  ' +------+------+------+------+--------------+')
2795 9082 FORMAT ( ' |',i5,' |',i5,' |',2(i5,' |'),i9,i4,' |')
2796 9083 FORMAT ( ' +------+------+------+------+--------------+')
2797 9084 FORMAT ( ' MPIT WMIOES: NRQEQS:',i10/)
2798 #endif
2799  !/
2800  !/ End of WMIOES ----------------------------------------------------- /
2801  !/

References w3adatmd::cg, w3timemd::dsec21(), wmmdatmd::eqstge, w3servmd::extcde(), w3gdatmd::gtype, wmmdatmd::improc, include(), wmmdatmd::mdse, wmmdatmd::mdst, wmmdatmd::mpi_comm_mwave, wmmdatmd::mtag2, wmmdatmd::mtag_ub, wmmdatmd::nrgrd, w3gdatmd::nspec, w3gdatmd::nth, w3gdatmd::sig2, w3gdatmd::smctype, w3odatmd::stop, w3servmd::strace(), w3wdatmd::time, wmmdatmd::tsync, w3wdatmd::va, w3adatmd::w3seta(), w3gdatmd::w3setg(), w3odatmd::w3seto(), and w3wdatmd::w3setw().

Referenced by wmwavemd::wmwave().

◆ wmiohf()

subroutine wminiomd::wmiohf ( integer, intent(in)  IMOD)

Finalize staging of internal high-to-low data in the data structure HGSTGE (MPI only).

Post appropriate 'wait' functions to assure that the communication has finished.

Parameters
[in]IMODModel number of grid from which data has been staged.
Author
H. L. Tolman
Date
16-Jan-2006

Definition at line 2325 of file wminiomd.F90.

2325  !/
2326  !/ +-----------------------------------+
2327  !/ | WAVEWATCH III NOAA/NCEP |
2328  !/ | H. L. Tolman |
2329  !/ | FORTRAN 90 |
2330  !/ | Last update : 16-Jan-2006 !
2331  !/ +-----------------------------------+
2332  !/
2333  !/ 16-Jan-2006 : Origination. ( version 3.08 )
2334  !/
2335  ! 1. Purpose :
2336  !
2337  ! Finalize staging of internal high-to-low data in the data
2338  ! structure HGSTGE (MPI only).
2339  !
2340  ! 2. Method :
2341  !
2342  ! Post appropriate 'wait' functions to assure that the
2343  ! communication has finished.
2344  !
2345  ! 3. Parameters :
2346  !
2347  ! Parameter list
2348  ! ----------------------------------------------------------------
2349  ! IMOD Int. I Model number of grid from which data has
2350  ! been staged.
2351  ! ----------------------------------------------------------------
2352  !
2353  ! 4. Subroutines used :
2354  !
2355  ! Name Type Module Description
2356  ! ----------------------------------------------------------------
2357  ! STRACE Subr. W3SERVMD Subroutine tracing.
2358  ! ----------------------------------------------------------------
2359  !
2360  ! 5. Called by :
2361  !
2362  ! Name Type Module Description
2363  ! ----------------------------------------------------------------
2364  ! WMWAVE Subr WMWAVEMD Multi-grid wave model.
2365  ! ----------------------------------------------------------------
2366  !
2367  ! 6. Error messages :
2368  !
2369  ! 7. Remarks :
2370  !
2371  ! 8. Structure :
2372  !
2373  ! See source code.
2374  !
2375  ! 9. Switches :
2376  !
2377  ! !/SHRD Shared/distributed memory models.
2378  ! !/DIST
2379  ! !/MPI
2380  !
2381  ! !/S Enable subroutine tracing.
2382  ! !/T Test output.
2383  !
2384  ! 10. Source code :
2385  !
2386  !/ ------------------------------------------------------------------- /
2387  !
2388  USE wmmdatmd
2389  !
2390 #ifdef W3_S
2391  USE w3servmd, ONLY: strace
2392 #endif
2393  !
2394  IMPLICIT NONE
2395  !
2396 #ifdef W3_MPI
2397  include "mpif.h"
2398 #endif
2399  !/
2400  !/ ------------------------------------------------------------------- /
2401  !/ Parameter list
2402  !/
2403  INTEGER, INTENT(IN) :: IMOD
2404  !/
2405  !/ ------------------------------------------------------------------- /
2406  !/ Local parameters
2407  !/
2408  INTEGER :: J
2409 #ifdef W3_MPI
2410  INTEGER :: IERR_MPI
2411  INTEGER, POINTER :: NRQ, IRQ(:)
2412  INTEGER, ALLOCATABLE :: STATUS(:,:)
2413 #endif
2414 #ifdef W3_S
2415  INTEGER, SAVE :: IENT = 0
2416 #endif
2417  !/
2418 #ifdef W3_S
2419  CALL strace (ient, 'WMIOHF')
2420 #endif
2421  !
2422  ! -------------------------------------------------------------------- /
2423  ! 0. Initializations
2424  !
2425 #ifdef W3_T
2426  WRITE (mdst,9000) imod
2427 #endif
2428  !
2429  ! -------------------------------------------------------------------- /
2430  ! 1. Loop over grids
2431  !
2432  DO j=1, nrgrd
2433  !
2434 #ifdef W3_MPI
2435  nrq => hgstge(j,imod)%NRQHGS
2436 #endif
2437  !
2438  ! 1.a Nothing to finalize
2439  !
2440 #ifdef W3_MPI
2441  IF ( nrq .EQ. 0 ) cycle
2442  irq => hgstge(j,imod)%IRQHGS
2443 #endif
2444  !
2445  ! 1.b Wait for communication to end
2446  !
2447 #ifdef W3_MPI
2448  ALLOCATE ( status(mpi_status_size,nrq) )
2449  CALL mpi_waitall ( nrq, irq, status, ierr_mpi )
2450  DEALLOCATE ( status )
2451 #endif
2452  !
2453  ! 1.c Reset arrays and counter
2454  !
2455 #ifdef W3_MPI
2456  nrq = 0
2457  DEALLOCATE ( hgstge(j,imod)%IRQHGS, &
2458  hgstge(j,imod)%TSTORE, &
2459  hgstge(j,imod)%OUTDAT )
2460 #endif
2461  !
2462 #ifdef W3_T
2463  WRITE (mdst,9010) j
2464 #endif
2465  !
2466  END DO
2467  !
2468  RETURN
2469  !
2470  ! Formats
2471  !
2472 #ifdef W3_T
2473 9000 FORMAT ( ' TEST WMIOHF : FINALIZE STAGING DATA FROM GRID ',i3)
2474 9010 FORMAT ( ' TEST WMIOHF : FINISHED WITH TARGET ',i3)
2475 #endif
2476  !/
2477  !/ End of WMIOHF ----------------------------------------------------- /
2478  !/

References wmmdatmd::hgstge, include(), wmmdatmd::mdst, wmmdatmd::nrgrd, and w3servmd::strace().

Referenced by wmwavemd::wmwave().

◆ wmiohg()

subroutine wminiomd::wmiohg ( integer, intent(in)  IMOD,
logical, intent(out), optional  DONE 
)

Gather internal high-to-low data for a given model.

For distributed memory version first receive all staged data. After staged data is present, average, convert as necessary, and store in basic spectral arrays.

Using storage array HGSTAGE and time stamps.

Parameters
[in]IMODModel number of grid from which data is to be gathered.
[out]DONEFlag for completion of operation (opt).
Author
H. L. Tolman
Date
20-Dec-2006

Definition at line 1724 of file wminiomd.F90.

1724  !/
1725  !/ +-----------------------------------+
1726  !/ | WAVEWATCH III NOAA/NCEP |
1727  !/ | H. L. Tolman |
1728  !/ | FORTRAN 90 |
1729  !/ | Last update : 20-Dec-2006 !
1730  !/ +-----------------------------------+
1731  !/
1732  !/ 27-Jan-2006 : Origination. ( version 3.08 )
1733  !/ 20-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 )
1734  !/
1735  ! 1. Purpose :
1736  !
1737  ! Gather internal high-to-low data for a given model.
1738  !
1739  ! 2. Method :
1740  !
1741  ! For distributed memory version first receive all staged data.
1742  ! After staged data is present, average, convert as necessary,
1743  ! and store in basic spectral arrays.
1744  !
1745  ! 2. Method :
1746  !
1747  ! Using storage array HGSTAGE and time stamps.
1748  !
1749  ! 3. Parameters :
1750  !
1751  ! Parameter list
1752  ! ----------------------------------------------------------------
1753  ! IMOD Int. I Model number of grid from which data is to
1754  ! be gathered.
1755  ! DONE Log. O Flag for completion of operation (opt).
1756  ! ----------------------------------------------------------------
1757  !
1758  ! 4. Subroutines used :
1759  !
1760  ! Name Type Module Description
1761  ! ----------------------------------------------------------------
1762  ! W3SETG, W3SETW, W3SETA, W3SETO
1763  ! Subr. WxxDATMD Manage data structures.
1764  ! W3CSPC Subr. W3CSPCMD Spectral grid conversion.
1765  ! STRACE Sur. W3SERVMD Subroutine tracing.
1766  ! DSEC21 Func. W3TIMEMD Difference between times.
1767  ! ----------------------------------------------------------------
1768  !
1769  ! 5. Called by :
1770  !
1771  ! Name Type Module Description
1772  ! ----------------------------------------------------------------
1773  ! WMWAVE Subr WMWAVEMD Multi-grid wave model.
1774  ! ----------------------------------------------------------------
1775  !
1776  ! 6. Error messages :
1777  !
1778  ! See FORMAT labels 1001-1002.
1779  !
1780  ! 7. Remarks :
1781  !
1782  ! 8. Structure :
1783  !
1784  ! 9. Switches :
1785  !
1786  ! !/SHRD Shared/distributed memory models.
1787  ! !/DIST
1788  ! !/MPI
1789  !
1790  ! !/S Enable subroutine tracing.
1791  ! !/T Enable test output
1792  ! !/MPIT
1793  !
1794  ! 10. Source code :
1795  !
1796  !/ ------------------------------------------------------------------- /
1797  !
1798  USE w3gdatmd
1799  USE w3wdatmd
1800  USE w3adatmd
1801  USE w3odatmd
1802  USE wmmdatmd
1803  !
1804  USE w3cspcmd, ONLY: w3cspc
1805  USE w3timemd, ONLY: dsec21
1806  ! USE W3SERVMD, ONLY: EXTCDE
1807 #ifdef W3_PDLIB
1808  use yownodepool, only: npa
1809  USE yowexchangemodule, only : pdlib_exchange2dreal_zero
1810 #endif
1811  USE w3parall, ONLY : init_get_isea
1812 #ifdef W3_S
1813  USE w3servmd, ONLY: strace
1814 #endif
1815  !
1816  IMPLICIT NONE
1817  !
1818 #ifdef W3_MPI
1819  include "mpif.h"
1820 #endif
1821  !/
1822  !/ ------------------------------------------------------------------- /
1823  !/ Parameter list
1824  !/
1825  INTEGER, INTENT(IN) :: IMOD
1826  LOGICAL, INTENT(OUT), OPTIONAL :: DONE
1827  !/
1828  !/ ------------------------------------------------------------------- /
1829  !/ Local parameters
1830  !/
1831  INTEGER :: NTOT, J, IS, NA, IA, JSEA, ISEA, I
1832 #ifdef W3_MPI
1833  INTEGER :: ITAG, IT0, IFROM, ILOC, NLOC, &
1834  ISPROC, IERR_MPI, ICOUNT, &
1835  I0, I1, I2
1836 #endif
1837 #ifdef W3_S
1838  INTEGER, SAVE :: IENT = 0
1839 #endif
1840  INTEGER, POINTER :: VTIME(:)
1841 #ifdef W3_MPI
1842  INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:)
1843 #endif
1844  REAL :: DTTST, WGTH
1845  REAL, POINTER :: SPEC1(:,:), SPEC2(:,:), SPEC(:,:)
1846 #ifdef W3_MPI
1847  REAL, POINTER :: SHGH(:,:,:)
1848 #endif
1849  LOGICAL :: FLGALL
1850 #ifdef W3_MPI
1851  LOGICAL :: FLAGOK
1852 #endif
1853 #ifdef W3_MPIT
1854  LOGICAL :: FLAG
1855 #endif
1856  !/
1857 #ifdef W3_S
1858  CALL strace (ient, 'WMIOHG')
1859 #endif
1860  !
1861  ! -------------------------------------------------------------------- /
1862  ! 0. Initializations
1863  !
1864  IF ( toutp(1,imod) .EQ. -1 ) THEN
1865  dttst = 1.
1866  ELSE
1867  dttst = dsec21( wdatas(imod)%TIME , toutp(:,imod) )
1868  END IF
1869  !
1870  IF ( .NOT. flghg1 ) THEN
1871  flgall = .true.
1872  ELSE IF ( flghg2 ) THEN
1873  flgall = .false.
1874  ELSE IF ( dttst .EQ. 0. ) THEN
1875  flgall = .true.
1876  ELSE
1877  flgall = .false.
1878  END IF
1879  !
1880 #ifdef W3_T
1881  WRITE (mdst,9000) imod, dttst, flgall
1882 #endif
1883  !
1884  IF ( flgall ) THEN
1885 #ifdef W3_T
1886  WRITE (mdst,9001) hgstge(imod,:)%NREC
1887 #endif
1888  ntot = sum(hgstge(imod,:)%NREC)
1889  ELSE
1890 #ifdef W3_T
1891  WRITE (mdst,9001) hgstge(imod,:)%NRC1
1892 #endif
1893  ntot = sum(hgstge(imod,:)%NRC1)
1894  END IF
1895  !
1896  IF ( PRESENT(done) ) done = .false.
1897  !
1898  IF ( ntot .EQ. 0 ) THEN
1899  IF ( PRESENT(done) ) done = .true.
1900 #ifdef W3_T
1901  WRITE (mdst,9003)
1902 #endif
1903  RETURN
1904  END IF
1905  !
1906  CALL w3seto ( imod, mdse, mdst )
1907  CALL w3setg ( imod, mdse, mdst )
1908  CALL w3setw ( imod, mdse, mdst )
1909  CALL w3seta ( imod, mdse, mdst )
1910  !
1911  ! -------------------------------------------------------------------- /
1912  ! 1. Testing / gathering data in staging arrays
1913  !
1914 #ifdef W3_T
1915  WRITE (mdst,9010) time
1916 #endif
1917  !
1918  ! 1.a Shared memory version, test valid times. - - - - - - - - - - - - /
1919  !
1920 #ifdef W3_SHRD
1921  DO j=1, nrgrd
1922 #endif
1923  !
1924 #ifdef W3_SHRD
1925  IF ( flgall ) THEN
1926  ntot = hgstge(imod,j)%NREC
1927  ELSE
1928  ntot = hgstge(imod,j)%NRC1
1929  END IF
1930  IF ( ntot .EQ. 0 ) cycle
1931 #endif
1932  !
1933 #ifdef W3_SHRD
1934  vtime => hgstge(imod,j)%VTIME
1935  IF ( vtime(1) .EQ. -1 ) RETURN
1936  dttst = dsec21( time, vtime )
1937  IF ( dttst .NE. 0. ) RETURN
1938 #endif
1939  !
1940 #ifdef W3_SHRD
1941  END DO
1942 #endif
1943  !
1944  ! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - /
1945  !
1946 #ifdef W3_MPIT
1947  WRITE (mdst,9011) hghsta(imod)
1948 #endif
1949  !
1950  ! 1.b.1 HGHSTA = 0
1951  ! Check if staging arrays are initialized.
1952  ! Post the proper receives.
1953  !
1954 #ifdef W3_MPI
1955  IF ( hghsta(imod) .EQ. 0 ) THEN
1956 #endif
1957  !
1958 #ifdef W3_MPI
1959  nrq => mdatas(imod)%NRQHGG
1960  nrq = 0
1961  DO j=1, nrgrd
1962  IF ( flgall ) THEN
1963  nrq = nrq + hgstge(imod,j)%NREC * &
1964  hgstge(imod,j)%NSMX
1965  ELSE
1966  nrq = nrq + hgstge(imod,j)%NRC1 * &
1967  hgstge(imod,j)%NSMX
1968  END IF
1969  END DO
1970  nrq = max(1,nrq)
1971  ALLOCATE ( irq(nrq) )
1972  irq = 0
1973  nrq = 0
1974 #endif
1975  !
1976 #ifdef W3_MPI
1977  DO j=1, nrgrd
1978  IF ( hgstge(imod,j)%NTOT .EQ. 0 ) cycle
1979 #endif
1980  !
1981  ! ..... Check valid time to determine staging.
1982  !
1983 #ifdef W3_MPI
1984  vtime => hgstge(imod,j)%VTIME
1985  IF ( vtime(1) .EQ. -1 ) THEN
1986  dttst = 1.
1987  ELSE
1988  dttst = dsec21( time, vtime )
1989  END IF
1990 #endif
1991 #ifdef W3_MPIT
1992  WRITE (mdst,9013) vtime, dttst
1993 #endif
1994  !
1995  ! ..... Post receives for data gather
1996  !
1997 #ifdef W3_MPI
1998  IF ( dttst .NE. 0. ) THEN
1999 #endif
2000 #ifdef W3_MPIT
2001  WRITE (mdst,9014) j
2002 #endif
2003  !
2004  ! ..... Spectra
2005  !
2006 #ifdef W3_MPI
2007  it0 = mtag1 + 1
2008  shgh => hgstge(imod,j)%SHGH
2009 #endif
2010  !
2011 #ifdef W3_MPI
2012  IF ( flgall ) THEN
2013  ntot = hgstge(imod,j)%NREC
2014  ELSE
2015  ntot = hgstge(imod,j)%NRC1
2016  END IF
2017 #endif
2018  !
2019 #ifdef W3_MPI
2020  DO i=1, ntot
2021 #endif
2022 #ifdef W3_MPIT
2023  jsea = hgstge(imod,j)%LJSEA(i)
2024 #endif
2025 #ifdef W3_MPI
2026  nloc = hgstge(imod,j)%NRAVG(i)
2027  DO iloc=1, nloc
2028  isproc = hgstge(imod,j)%IMPSRC(i,iloc)
2029  itag = hgstge(imod,j)%ITAG(i,iloc) + it0
2030  IF ( isproc .NE. improc ) THEN
2031  nrq = nrq + 1
2032  CALL mpi_irecv ( shgh(1,iloc,i), &
2033  sgrds(j)%NSPEC, mpi_real, &
2034  isproc-1, itag, mpi_comm_mwave, &
2035  irq(nrq), ierr_mpi )
2036 #endif
2037 #ifdef W3_MPIT
2038  WRITE (mdst,9016) nrq, jsea, isproc, &
2039  itag-mtag1, irq(nrq), ierr_mpi
2040 #endif
2041 #ifdef W3_MPI
2042  END IF
2043  END DO
2044  END DO
2045 #endif
2046  !
2047  ! ..... End IF for posting receives 1.b.1
2048  !
2049 #ifdef W3_MPIT
2050  WRITE (mdst,9017)
2051 #endif
2052 #ifdef W3_MPI
2053  END IF
2054 #endif
2055  !
2056  ! ..... End grid loop J in 1.b.1
2057  !
2058 #ifdef W3_MPI
2059  END DO
2060 #endif
2061 #ifdef W3_MPIT
2062  WRITE (mdst,9018) nrq
2063 #endif
2064  !
2065 #ifdef W3_MPI
2066  ALLOCATE ( mdatas(imod)%IRQHGG(nrq) )
2067  mdatas(imod)%IRQHGG = irq(1:nrq)
2068  DEALLOCATE ( irq )
2069 #endif
2070  !
2071  ! ..... Reset status
2072  !
2073 #ifdef W3_MPI
2074  IF ( nrq .GT. 0 ) THEN
2075  hghsta(imod) = 1
2076 #endif
2077 #ifdef W3_MPIT
2078  WRITE (mdst,9011) hghsta(imod)
2079 #endif
2080 #ifdef W3_MPI
2081  END IF
2082 #endif
2083  !
2084  ! ..... End IF in 1.b.1
2085  !
2086 #ifdef W3_MPI
2087  END IF
2088 #endif
2089  !
2090  ! 1.b.2 HGHSTA = 1
2091  ! Wait for communication to finish.
2092  ! If DONE defined, check if done, otherwise wait.
2093  !
2094 #ifdef W3_MPI
2095  IF ( hghsta(imod) .EQ. 1 ) THEN
2096 #endif
2097  !
2098 #ifdef W3_MPI
2099  nrq => mdatas(imod)%NRQHGG
2100  irq => mdatas(imod)%IRQHGG
2101  ALLOCATE ( status(mpi_status_size,nrq) )
2102 #endif
2103  !
2104  ! ..... Test communication if DONE is present, wait otherwise
2105  !
2106 #ifdef W3_MPI
2107  IF ( PRESENT(done) ) THEN
2108 #endif
2109  !
2110 #ifdef W3_MPI
2111  CALL mpi_testall ( nrq, irq, flagok, status, &
2112  ierr_mpi )
2113 #endif
2114  !
2115 #ifdef W3_MPIT
2116  icount = 0
2117  DO i=1, nrq
2118  CALL mpi_test ( irq(i), flag, status(1,1), &
2119  ierr_mpi )
2120  flagok = flagok .AND. flag
2121  IF ( flag ) icount = icount + 1
2122  END DO
2123  WRITE (mdst,9019) 100. * real(icount) / real(nrq)
2124 #endif
2125  !
2126 #ifdef W3_MPI
2127  ELSE
2128 #endif
2129  !
2130 #ifdef W3_MPI
2131  CALL mpi_waitall ( nrq, irq, status, ierr_mpi )
2132  flagok = .true.
2133 #endif
2134 #ifdef W3_MPIT
2135  WRITE (mdst,9019) 100.
2136 #endif
2137  !
2138 #ifdef W3_MPI
2139  END IF
2140 #endif
2141  !
2142 #ifdef W3_MPI
2143  DEALLOCATE ( status )
2144 #endif
2145  !
2146  ! ..... Go on based on FLAGOK
2147  !
2148 #ifdef W3_MPI
2149  IF ( flagok ) THEN
2150  nrq = 0
2151  DEALLOCATE ( mdatas(imod)%IRQHGG )
2152  ELSE
2153  RETURN
2154  END IF
2155 #endif
2156  !
2157 #ifdef W3_MPI
2158  hghsta(imod) = 0
2159 #endif
2160 #ifdef W3_MPIT
2161  WRITE (mdst,9011) hghsta(imod)
2162 #endif
2163  !
2164 #ifdef W3_MPI
2165  END IF
2166 #endif
2167  !
2168  ! ..... process locally stored data
2169  !
2170 #ifdef W3_MPI
2171  DO j=1, nrgrd
2172  hgstge(imod,j)%VTIME = time
2173  IF ( j .EQ. imod ) cycle
2174  DO is=1, hgstge(imod,j)%NRQOUT
2175  i0 = hgstge(imod,j)%OUTDAT(is,1)
2176  i2 = hgstge(imod,j)%OUTDAT(is,2)
2177  i1 = hgstge(imod,j)%OUTDAT(is,3)
2178  hgstge(imod,j)%SHGH(:,i2,i1) = hgstge(imod,j)%TSTORE(:,i0)
2179  END DO
2180  END DO
2181 #endif
2182  !
2183  ! -------------------------------------------------------------------- /
2184  ! 2. Data available, process grid by grid
2185  !
2186 #ifdef W3_T
2187  WRITE (mdst,9020)
2188 #endif
2189  !
2190  ! 2.a Loop over grids
2191  !
2192  DO j=1, nrgrd
2193  !
2194  IF ( flgall ) THEN
2195  ntot = hgstge(imod,j)%NREC
2196  ELSE
2197  ntot = hgstge(imod,j)%NRC1
2198  END IF
2199  IF ( ntot .EQ. 0 ) cycle
2200  !
2201 #ifdef W3_T
2202  WRITE (mdst,9021) j, ntot
2203 #endif
2204  !
2205  ! 2.b Set up temp data structures
2206  !
2207  IF ( respec(imod,j) ) THEN
2208  ALLOCATE ( spec1(sgrds(j)%NSPEC,ntot), spec2(nspec,ntot) )
2209  spec => spec1
2210  ELSE
2211  ALLOCATE ( spec2(nspec,ntot) )
2212  spec => spec2
2213  END IF
2214  !
2215  ! 2.c Average spectra to temp storage
2216  !
2217 #ifdef W3_T
2218  WRITE (mdst,9022)
2219 #endif
2220  !
2221  DO is=1, ntot
2222  na = hgstge(imod,j)%NRAVG(is)
2223  wgth = hgstge(imod,j)%WGTH(is,1)
2224  spec(:,is) = wgth * hgstge(imod,j)%SHGH(:,1,is)
2225  DO ia=2, na
2226  wgth = hgstge(imod,j)%WGTH(is,ia)
2227  spec(:,is) = spec(:,is) + wgth*hgstge(imod,j)%SHGH(:,ia,is)
2228  END DO
2229  END DO
2230  !
2231  ! 2.d Convert spectral grid as needed
2232  !
2233  IF ( respec(imod,j) ) THEN
2234  !
2235 #ifdef W3_T
2236  WRITE (mdst,9023)
2237 #endif
2238  !
2239  CALL w3cspc ( spec1, sgrds(j)%NK, sgrds(j)%NTH, &
2240  sgrds(j)%XFR, sgrds(j)%FR1, sgrds(j)%TH(1), &
2241  spec2 , nk, nth, xfr, fr1, th(1), &
2242  ntot, mdst, mdse, fachfe)
2243  DEALLOCATE ( spec1 )
2244  !
2245  END IF
2246  !
2247  ! 2.e Move spectra to model
2248  !
2249 #ifdef W3_T
2250  WRITE (mdst,9024)
2251 #endif
2252  !
2253  DO is=1, ntot
2254  jsea = hgstge(imod,j)%LJSEA(is)
2255  CALL init_get_isea(isea, jsea)
2256  DO i=1, nspec
2257  va(i,jsea) = spec2(i,is) / sig2(i) * cg(1+(i-1)/nth,isea)
2258  END DO
2259  END DO
2260  !
2261  DEALLOCATE ( spec2 )
2262  !
2263  END DO
2264  !
2265  ! -------------------------------------------------------------------- /
2266  ! 3. Set flag if reqeusted
2267  !
2268  IF ( PRESENT(done) ) done = .true.
2269  !
2270 #ifdef W3_PDLIB
2271  CALL pdlib_exchange2dreal_zero(va)
2272 #endif
2273  !
2274  ! Formats
2275  !
2276 #ifdef W3_T
2277 9000 FORMAT ( ' TEST WMIOHG : GATHERING DATA FOR GRID ',i3/ &
2278  ' DTOUTP, FLGALL :',f8.1,l4)
2279 9001 FORMAT ( ' TEST WMIOHG : NR. OF SPECTRA PER SOURCE GRID : '/ &
2280  ' ',25i4)
2281 9003 FORMAT ( ' TEST WMIOHG : NO DATA TO BE GATHERED')
2282 #endif
2283  !
2284 #ifdef W3_T
2285 9010 FORMAT ( ' TEST WMIOHG : TEST DATA AVAILABILITY FOR',i9.8,i7.6)
2286 #endif
2287 #ifdef W3_MPIT
2288 9011 FORMAT ( ' MPIT WMIOHG : HGHSTA =',i2)
2289 9013 FORMAT ( ' VTIME, DTTST :',i9.8,i7.6,1x,f8.1)
2290 9014 FORMAT (/' MPIT WMIOHG : RECEIVE FROM GRID',i4/ &
2291  ' +------+------+------+------+--------------+'/ &
2292  ' | IH | ID | FROM | TAG | handle err |'/ &
2293  ' +------+------+------+------+--------------+')
2294 9016 FORMAT ( ' |',i5,' |',i5,' |',2(i5,' |'),i9,i4,' |')
2295 9017 FORMAT ( ' +------+------+------+------+--------------+'/)
2296 9018 FORMAT ( ' MPIT WMIOHG : NRQBPT:',i10/)
2297 9019 FORMAT ( ' MPIT WMIOHG : RECEIVES FINISHED :',f6.1,'%')
2298 #endif
2299  !
2300 #ifdef W3_T
2301 9020 FORMAT ( ' TEST WMIOHG : PROCESSING DATA GRID BY GRID')
2302 9021 FORMAT ( ' FROM GRID ',i3,' NR OF SPECTRA :',i6)
2303 9022 FORMAT ( ' AVERAGE SPECTRA TO TEMP STORAGE')
2304 9023 FORMAT ( ' CONVERT SPECTRAL GRID')
2305 9024 FORMAT ( ' MOVE SPECTRA TO PERMANENT STORAGE')
2306 #endif
2307  !/
2308  !/ End of WMIOHG ----------------------------------------------------- /
2309  !/

References w3adatmd::cg, w3timemd::dsec21(), w3gdatmd::fachfe, wmmdatmd::flghg1, wmmdatmd::flghg2, w3gdatmd::fr1, wmmdatmd::hghsta, wmmdatmd::hgstge, wmmdatmd::improc, include(), w3parall::init_get_isea(), wmmdatmd::mdatas, wmmdatmd::mdse, wmmdatmd::mdst, wmmdatmd::mpi_comm_mwave, wmmdatmd::mtag1, w3gdatmd::nk, yownodepool::npa, wmmdatmd::nrgrd, w3gdatmd::nspec, w3gdatmd::nth, yowexchangemodule::pdlib_exchange2dreal_zero(), wmmdatmd::respec, w3gdatmd::sgrds, w3gdatmd::sig2, w3servmd::strace(), w3gdatmd::th, w3wdatmd::time, wmmdatmd::toutp, w3wdatmd::va, w3cspcmd::w3cspc(), w3adatmd::w3seta(), w3gdatmd::w3setg(), w3odatmd::w3seto(), w3wdatmd::w3setw(), w3wdatmd::wdatas, and w3gdatmd::xfr.

Referenced by wmwavemd::wmwave().

◆ wmiohs()

subroutine wminiomd::wmiohs ( integer, intent(in)  IMOD)

Stage internal high-to-low data in the data structure HGSTGE.

Directly fill staging arrays in shared memory version, or post the corresponding sends in distributed memory version.

Parameters
[in]IMODModel number of grid from which data is to be staged.
Author
H. L. Tolman
Date
28-Sep-2016

Definition at line 1384 of file wminiomd.F90.

1384  !/
1385  !/ +-----------------------------------+
1386  !/ | WAVEWATCH III NOAA/NCEP |
1387  !/ | H. L. Tolman |
1388  !/ | FORTRAN 90 |
1389  !/ | Last update : 28-Sep-2016 !
1390  !/ +-----------------------------------+
1391  !/
1392  !/ 27-Jan-2006 : Origination. ( version 3.08 )
1393  !/ 20-Dec-2006 : Remove VTIME from MPI comm. ( version 3.10 )
1394  !/ 28-Sep-2016 : Add error traps for MPI tags. ( version 5.15 )
1395  !/
1396  ! 1. Purpose :
1397  !
1398  ! Stage internal high-to-low data in the data structure HGSTGE.
1399  !
1400  ! 2. Method :
1401  !
1402  ! Directly fill staging arrays in shared memory version, or post
1403  ! the corresponding sends in distributed memory version.
1404  !
1405  ! 3. Parameters :
1406  !
1407  ! Parameter list
1408  ! ----------------------------------------------------------------
1409  ! IMOD Int. I Model number of grid from which data is to
1410  ! be staged.
1411  ! ----------------------------------------------------------------
1412  !
1413  ! 4. Subroutines used :
1414  !
1415  ! Name Type Module Description
1416  ! ----------------------------------------------------------------
1417  ! W3SETG, W3SETW, W3SETA, W3SETO, WMSETM
1418  ! Subr. WxxDATMD Manage data structures.
1419  ! STRACE Subr. W3SERVMD Subroutine tracing.
1420  ! EXTCDE Sur. Id. Program abort.
1421  ! DSEC21 Func. W3TIMEMD Difference between times.
1422  ! ----------------------------------------------------------------
1423  !
1424  ! 5. Called by :
1425  !
1426  ! Name Type Module Description
1427  ! ----------------------------------------------------------------
1428  ! WMWAVE Subr WMWAVEMD Multi-grid wave model.
1429  ! ----------------------------------------------------------------
1430  !
1431  ! 6. Error messages :
1432  !
1433  ! See FORMAT label 1001.
1434  !
1435  ! 7. Remarks :
1436  !
1437  ! 8. Structure :
1438  !
1439  ! See source code.
1440  !
1441  ! 9. Switches :
1442  !
1443  ! !/SHRD Shared/distributed memory models.
1444  ! !/DIST
1445  ! !/MPI
1446  !
1447  ! !/S Enable subroutine tracing.
1448  ! !/T Enable test output
1449  ! !/MPIT
1450  !
1451  ! 10. Source code :
1452  !
1453  !/ ------------------------------------------------------------------- /
1454  !
1455  USE w3gdatmd
1456  USE w3wdatmd
1457  USE w3adatmd
1458  USE w3odatmd
1459  USE wmmdatmd
1460  !
1461  USE w3servmd, ONLY: extcde
1462 #ifdef W3_S
1463  USE w3servmd, ONLY: strace
1464 #endif
1465  USE w3timemd, ONLY: dsec21
1466  USE w3parall, ONLY: init_get_isea
1467  !
1468  IMPLICIT NONE
1469  !
1470 #ifdef W3_MPI
1471  include "mpif.h"
1472 #endif
1473  !/
1474  !/ ------------------------------------------------------------------- /
1475  !/ Parameter list
1476  !/
1477  INTEGER, INTENT(IN) :: IMOD
1478  !/
1479  !/ ------------------------------------------------------------------- /
1480  !/ Local parameters
1481  !/
1482  INTEGER :: J, NR, I, JSEA, ISEA, IS
1483 #ifdef W3_MPI
1484  INTEGER :: ITAG, IP, IT0, IERR_MPI
1485 #endif
1486  INTEGER :: I1, I2
1487 #ifdef W3_S
1488  INTEGER, SAVE :: IENT = 0
1489 #endif
1490 #ifdef W3_MPI
1491  INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:)
1492 #endif
1493  REAL :: DTOUTP
1494 #ifdef W3_SHRD
1495  REAL, POINTER :: SHGH(:,:,:)
1496 #endif
1497 #ifdef W3_MPI
1498  REAL, POINTER :: SHGH(:,:)
1499 #endif
1500  !/
1501 #ifdef W3_S
1502  CALL strace (ient, 'WMIOHS')
1503 #endif
1504  !
1505  ! -------------------------------------------------------------------- /
1506  ! 0. Initializations
1507  !
1508 #ifdef W3_T
1509  WRITE (mdst,9000) imod, flghg1
1510 #endif
1511  !
1512  IF ( .NOT. flghg1 ) THEN
1513 #ifdef W3_T
1514  WRITE (mdst,9001) hgstge(:,imod)%NSND
1515 #endif
1516  IF ( sum(hgstge(:,imod)%NSND) .EQ. 0 ) RETURN
1517  ELSE
1518 #ifdef W3_T
1519  WRITE (mdst,9001) hgstge(:,imod)%NSN1
1520 #endif
1521  IF ( sum(hgstge(:,imod)%NSN1) .EQ. 0 ) RETURN
1522  END IF
1523  !
1524  CALL w3seto ( imod, mdse, mdst )
1525  CALL w3setg ( imod, mdse, mdst )
1526  CALL w3setw ( imod, mdse, mdst )
1527  CALL w3seta ( imod, mdse, mdst )
1528  !
1529  ! -------------------------------------------------------------------- /
1530  ! 1. Loop over grids
1531  !
1532  DO j=1, nrgrd
1533  !
1534  IF ( j .EQ. imod ) cycle
1535  !
1536  IF ( .NOT. flghg1 ) THEN
1537  nr = hgstge(j,imod)%NSND
1538  ELSE IF ( flghg2 ) THEN
1539  nr = hgstge(j,imod)%NSN1
1540  ELSE
1541  IF ( toutp(1,j) .EQ. -1 ) THEN
1542  dtoutp = 1.
1543  ELSE
1544  dtoutp = dsec21(time,toutp(:,j))
1545  END IF
1546  IF ( dtoutp .EQ. 0. ) THEN
1547  nr = hgstge(j,imod)%NSND
1548  ELSE
1549  nr = hgstge(j,imod)%NSN1
1550  END IF
1551  END IF
1552  !
1553 #ifdef W3_T
1554  IF ( nr .EQ. 0 ) THEN
1555  WRITE (mdst,9010) j, nr
1556  ELSE
1557  WRITE (mdst,9011) j, nr, dsec21(time,tsync(:,j)), dtoutp
1558  END IF
1559 #endif
1560  !
1561  IF ( nr .EQ. 0 ) cycle
1562  IF ( dsec21(time,tsync(:,j)) .NE. 0. ) cycle
1563  !
1564  ! -------------------------------------------------------------------- /
1565  ! 2. Allocate arrays and/or point pointers
1566  !
1567 #ifdef W3_SHRD
1568  shgh => hgstge(j,imod)%SHGH
1569 #endif
1570 #ifdef W3_MPI
1571  ALLOCATE ( hgstge(j,imod)%TSTORE(nspec,nr) )
1572  shgh => hgstge(j,imod)%TSTORE
1573 #endif
1574  !
1575 #ifdef W3_MPI
1576  ALLOCATE ( hgstge(j,imod)%IRQHGS(nr) )
1577  ALLOCATE ( hgstge(j,imod)%OUTDAT(nr,3) )
1578 #endif
1579  !
1580 #ifdef W3_MPI
1581  nrq => hgstge(j,imod)%NRQHGS
1582  nrqout => hgstge(j,imod)%NRQOUT
1583  irq => hgstge(j,imod)%IRQHGS
1584  outdat => hgstge(j,imod)%OUTDAT
1585  nrq = 0
1586  nrqout = 0
1587  irq = 0
1588 #endif
1589  !
1590  ! -------------------------------------------------------------------- /
1591  ! 3. Set the time
1592  ! !/SHRD only.
1593  !
1594 #ifdef W3_T
1595  WRITE (mdst,9030) time
1596 #endif
1597  !
1598 #ifdef W3_SHRD
1599  hgstge(j,imod)%VTIME = time
1600 #endif
1601  !
1602  ! -------------------------------------------------------------------- /
1603  ! 4. Stage the spectral data
1604  !
1605 #ifdef W3_MPIT
1606  WRITE (mdst,9080)
1607 #endif
1608 #ifdef W3_MPI
1609  it0 = mtag1 + 1
1610 #endif
1611  !
1612  DO i=1, nr
1613  !
1614  jsea = hgstge(j,imod)%ISEND(i,1)
1615  CALL init_get_isea(isea, jsea)
1616 #ifdef W3_DIST
1617  ip = hgstge(j,imod)%ISEND(i,2)
1618 #endif
1619  i1 = hgstge(j,imod)%ISEND(i,3)
1620  i2 = hgstge(j,imod)%ISEND(i,4)
1621 #ifdef W3_MPI
1622  itag = hgstge(j,imod)%ISEND(i,5) + it0
1623  IF ( itag .GT. mtag2 ) THEN
1624  WRITE (mdse,1001)
1625  CALL extcde (1001)
1626  END IF
1627 #endif
1628  !
1629  DO is=1, nspec
1630 #ifdef W3_SHRD
1631  shgh(is,i2,i1) = va(is,jsea) * sig2(is) &
1632  / cg(1+(is-1)/nth,isea)
1633 #endif
1634 #ifdef W3_MPI
1635  shgh( is,i ) = va(is,jsea) * sig2(is) &
1636  / cg(1+(is-1)/nth,isea)
1637 #endif
1638  END DO
1639  !
1640 #ifdef W3_MPI
1641  IF ( ip .NE. improc ) THEN
1642  nrq = nrq + 1
1643  CALL mpi_isend ( shgh(1,i), nspec, mpi_real, ip-1, &
1644  itag, mpi_comm_mwave, irq(nrq), ierr_mpi )
1645 #endif
1646 #ifdef W3_MPIT
1647  WRITE (mdst,9082) nrq, jsea, ip, itag-mtag1, &
1648  irq(nrq), ierr_mpi
1649 #endif
1650 #ifdef W3_MPI
1651  ELSE
1652  nrqout = nrqout + 1
1653  outdat(nrqout,1) = i
1654  outdat(nrqout,2) = i2
1655  outdat(nrqout,3) = i1
1656  END IF
1657 #endif
1658  !
1659  END DO
1660  !
1661 #ifdef W3_MPIT
1662  WRITE (mdst,9083)
1663  WRITE (mdst,9084) nrq
1664 #endif
1665  !
1666  END DO
1667  !
1668  RETURN
1669  !
1670  ! Formats
1671  !
1672 #ifdef W3_MPI
1673 1001 FORMAT (/' *** ERROR WMIOHS : REQUESTED MPI TAG EXCEEDS', &
1674  ' UPPER BOUND (MTAG2) ***')
1675 #endif
1676 #ifdef W3_T
1677 9000 FORMAT ( ' TEST WMIOHS : STAGING DATA FROM GRID ',i3, &
1678  ' FLGHG1 = ',l1)
1679 9001 FORMAT ( ' TEST WMIOHS : NR. OF SPECTRA PER GRID : '/ &
1680  ' ',15i6)
1681 #endif
1682  !
1683 #ifdef W3_T
1684 9010 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',i3, &
1685  ' NR = ',i6)
1686 9011 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',i3, &
1687  ' NR = ',i6,' TIME GAP = ',2f8.1)
1688 #endif
1689  !
1690 #ifdef W3_T
1691 9030 FORMAT ( ' TEST WMIOHS : TIME :',i10.8,i7.6)
1692 #endif
1693  !
1694 #ifdef W3_MPIT
1695 9080 FORMAT (/' MPIT WMIOHS: COMMUNICATION CALLS '/ &
1696  ' +------+------+------+------+--------------+'/ &
1697  ' | IH | ID | TARG | TAG | handle err |'/ &
1698  ' +------+------+------+------+--------------+')
1699 9082 FORMAT ( ' |',i5,' |',i5,' |',2(i5,' |'),i9,i4,' |')
1700 9083 FORMAT ( ' +------+------+------+------+--------------+')
1701 9084 FORMAT ( ' MPIT WMIOHS: NRQHGS:',i10/)
1702 #endif
1703  !/
1704  !/ End of WMIOHS ----------------------------------------------------- /
1705  !/

References w3adatmd::cg, w3timemd::dsec21(), w3servmd::extcde(), wmmdatmd::flghg1, wmmdatmd::flghg2, wmmdatmd::hgstge, wmmdatmd::improc, include(), w3parall::init_get_isea(), wmmdatmd::mdse, wmmdatmd::mdst, wmmdatmd::mpi_comm_mwave, wmmdatmd::mtag1, wmmdatmd::mtag2, wmmdatmd::nrgrd, w3gdatmd::nspec, w3gdatmd::nth, w3gdatmd::sig2, w3servmd::strace(), w3wdatmd::time, wmmdatmd::toutp, wmmdatmd::tsync, w3wdatmd::va, w3adatmd::w3seta(), w3gdatmd::w3setg(), w3odatmd::w3seto(), and w3wdatmd::w3setw().

Referenced by wmwavemd::wmwave().

w3gdatmd::nk
integer, pointer nk
Definition: w3gdatmd.F90:1230
wmmdatmd::nbi2s
integer, dimension(:,:), pointer nbi2s
NBI2S.
Definition: wmmdatmd.F90:539
wmmdatmd::respec
logical, dimension(:,:), allocatable respec
RESPEC.
Definition: wmmdatmd.F90:381
w3odatmd::tbpi0
integer, dimension(:), pointer tbpi0
Definition: w3odatmd.F90:464
w3timemd::dsec21
real function dsec21(TIME1, TIME2)
Definition: w3timemd.F90:333
include
cmake src_list cmake include(${CMAKE_CURRENT_SOURCE_DIR}/cmake/check_switches.cmake) check_switches("$
Definition: CMakeLists.txt:15
wmmdatmd::mdse
integer mdse
MDSE.
Definition: wmmdatmd.F90:316
w3tidemd::nr
integer, parameter nr
Definition: w3tidemd.F90:92
w3adatmd
Define data structures to set up wave model auxiliary data for several models simultaneously.
Definition: w3adatmd.F90:26
w3gdatmd::nspec
integer, pointer nspec
Definition: w3gdatmd.F90:1230
w3gdatmd::sgrds
type(sgrd), dimension(:), allocatable, target sgrds
Definition: w3gdatmd.F90:1089
wmmdatmd::init_get_jsea_isproc_glob
subroutine init_get_jsea_isproc_glob(ISEA, J, JSEA, ISPROC)
Introduce mapping for ISPROC and JSEA when using PDLIB in the Multigrid approach.
Definition: wmmdatmd.F90:1333
w3wdatmd
Define data structures to set up wave model dynamic data for several models simultaneously.
Definition: w3wdatmd.F90:18
w3adatmd::cg
real, dimension(:,:), pointer cg
Definition: w3adatmd.F90:575
wmmdatmd::hgstge
type(hgst), dimension(:,:), allocatable, target hgstge
HGSTGE.
Definition: wmmdatmd.F90:530
w3odatmd::iaproc
integer, pointer iaproc
Definition: w3odatmd.F90:457
wmmdatmd::tsync
integer, dimension(:,:), allocatable tsync
TSYNC.
Definition: wmmdatmd.F90:362
w3wdatmd::wdatas
type(wdata), dimension(:), allocatable, target wdatas
Definition: w3wdatmd.F90:168
w3updtmd
Bundles all input updating routines for WAVEWATCH III.
Definition: w3updtmd.F90:22
w3wdatmd::time
integer, dimension(:), pointer time
Definition: w3wdatmd.F90:172
w3gdatmd::fachfe
real, pointer fachfe
Definition: w3gdatmd.F90:1232
wmmdatmd::nbista
integer, dimension(:), allocatable nbista
NBISTA.
Definition: wmmdatmd.F90:371
yowexchangemodule::pdlib_exchange2dreal_zero
subroutine, public pdlib_exchange2dreal_zero(U)
Definition: yowexchangeModule.F90:468
wmmdatmd::hghsta
integer, dimension(:), allocatable hghsta
HGHSTA.
Definition: wmmdatmd.F90:372
w3updtmd::w3ubpt
subroutine w3ubpt
Update spectra at the active boundary points.
Definition: w3updtmd.F90:1314
w3odatmd::abpin
real, dimension(:,:), pointer abpin
Definition: w3odatmd.F90:541
wmmdatmd::bcdump
logical, dimension(:), allocatable bcdump
BCDUMP.
Definition: wmmdatmd.F90:382
w3odatmd::tbpin
integer, dimension(:), pointer tbpin
Definition: w3odatmd.F90:464
w3cspcmd
Convert spectra to new discrete spectral grid.
Definition: w3cspcmd.F90:21
yownodepool::npa
integer, public npa
number of ghost + resident nodes this partition holds
Definition: yownodepool.F90:99
w3odatmd::nbi
integer, pointer nbi
Definition: w3odatmd.F90:530
w3wdatmd::va
real, dimension(:,:), pointer va
Definition: w3wdatmd.F90:183
wmmdatmd::improc
integer improc
IMPROC.
Definition: wmmdatmd.F90:322
w3iobcmd::w3iobc
subroutine w3iobc(INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD)
Write/read boundary conditions file(s).
Definition: w3iobcmd.F90:99
w3odatmd::napbpt
integer, pointer napbpt
Definition: w3odatmd.F90:457
w3gdatmd::th
real, dimension(:), pointer th
Definition: w3gdatmd.F90:1234
wmmdatmd::mtag2
integer, parameter mtag2
MTAG2.
Definition: wmmdatmd.F90:348
w3gdatmd::w3setg
subroutine w3setg(IMOD, NDSE, NDST)
Definition: w3gdatmd.F90:2152
scrip_timers::status
character(len=8), dimension(max_timers), save status
Definition: scrip_timers.f:63
wmmdatmd::toutp
integer, dimension(:,:), allocatable toutp
TOUTP.
Definition: wmmdatmd.F90:364
wmmdatmd::nmproc
integer nmproc
NMPROC.
Definition: wmmdatmd.F90:321
w3adatmd::w3seta
subroutine w3seta(IMOD, NDSE, NDST)
Select one of the WAVEWATCH III grids / models.
Definition: w3adatmd.F90:2645
wmmdatmd::flghg1
logical flghg1
FLGHG1.
Definition: wmmdatmd.F90:379
w3odatmd::stop
logical, pointer stop
Definition: w3odatmd.F90:515
wmmdatmd::mdatas
type(mdata), dimension(:), allocatable, target mdatas
MDATAS.
Definition: wmmdatmd.F90:528
yownodepool
Has data that belong to nodes.
Definition: yownodepool.F90:39
w3servmd
Definition: w3servmd.F90:3
wmmdatmd::nrgrd
integer nrgrd
NRGRD.
Definition: wmmdatmd.F90:330
wmmdatmd::nbi2g
integer, dimension(:,:), allocatable nbi2g
NBI2G.
Definition: wmmdatmd.F90:367
w3wdatmd::w3setw
subroutine w3setw(IMOD, NDSE, NDST)
Select one of the WAVEWATCH III grids / models.
Definition: w3wdatmd.F90:660
wmmdatmd::ngrpsmc
integer ngrpsmc
NGRPSMC.
Definition: wmmdatmd.F90:334
wmmdatmd::mtag_ub
integer, parameter mtag_ub
MPI_TAG_UB on Cray XC40.
Definition: wmmdatmd.F90:349
w3odatmd::w3seto
subroutine w3seto(IMOD, NDSERR, NDSTST)
Definition: w3odatmd.F90:1523
w3gdatmd::nth
integer, pointer nth
Definition: w3gdatmd.F90:1230
w3odatmd
Definition: w3odatmd.F90:3
wmmdatmd::eqstge
type(eqst), dimension(:,:), allocatable, target eqstge
EQSTGE.
Definition: wmmdatmd.F90:531
w3odatmd::nds
integer, dimension(:), pointer nds
Definition: w3odatmd.F90:464
w3iobcmd
Processing of boundary data output.
Definition: w3iobcmd.F90:14
w3cspcmd::w3cspc
subroutine w3cspc(SP1, NFR1, NTH1, XF1, FR1, TH1, SP2, NFR2, NTH2, XF2, FR2, TH2, NSP, NDST, NDSE, FTL)
Convert a set of spectra to a new spectral grid.
Definition: w3cspcmd.F90:146
w3odatmd::naproc
integer, pointer naproc
Definition: w3odatmd.F90:457
wmmdatmd::allprc
integer, dimension(:,:), allocatable allprc
ALLPRC.
Definition: wmmdatmd.F90:360
wmmdatmd::nmperr
integer nmperr
NMPERR.
Definition: wmmdatmd.F90:326
yowexchangemodule
Has only the ghost nodes assign to a neighbor domain.
Definition: yowexchangeModule.F90:39
w3gdatmd::smctype
integer, parameter smctype
Definition: w3gdatmd.F90:627
wmmdatmd::mdst
integer mdst
MDST.
Definition: wmmdatmd.F90:315
wmmdatmd::eqlsta
integer, dimension(:), allocatable eqlsta
EQLSTA.
Definition: wmmdatmd.F90:373
w3gdatmd::sig2
real, dimension(:), pointer sig2
Definition: w3gdatmd.F90:1234
wmmdatmd::mtag0
integer, parameter mtag0
MTAG0.
Definition: wmmdatmd.F90:346
w3gdatmd::fr1
real, pointer fr1
Definition: w3gdatmd.F90:1232
w3servmd::strace
subroutine strace(IENT, SNAME)
Definition: w3servmd.F90:148
wmmdatmd::wmsetm
subroutine wmsetm(IMOD, NDSE, NDST)
Select one of the WAVEWATCH III grids / models.
Definition: wmmdatmd.F90:1169
w3gdatmd::gtype
integer, pointer gtype
Definition: w3gdatmd.F90:1094
w3odatmd::abpi0
real, dimension(:,:), pointer abpi0
Definition: w3odatmd.F90:541
wmmdatmd::mtag1
integer, parameter mtag1
MTAG1.
Definition: wmmdatmd.F90:347
w3gdatmd::xfr
real, pointer xfr
Definition: w3gdatmd.F90:1232
w3parall::init_get_jsea_isproc
subroutine init_get_jsea_isproc(ISEA, JSEA, ISPROC)
Set JSEA for all schemes.
Definition: w3parall.F90:1163
w3gdatmd
Definition: w3gdatmd.F90:16
wmmdatmd
Define data structures to set up wave model dynamic data for several models simultaneously.
Definition: wmmdatmd.F90:16
wmmdatmd::flghg2
logical flghg2
FLGHG2.
Definition: wmmdatmd.F90:380
w3servmd::extcde
subroutine extcde(IEXIT, UNIT, MSG, FILE, LINE, COMM)
Definition: w3servmd.F90:736
wmmdatmd::bpstge
type(bpst), dimension(:,:), allocatable, target bpstge
BPSTGE.
Definition: wmmdatmd.F90:529
w3odatmd::outpts
type(output), dimension(:), allocatable, target outpts
Definition: w3odatmd.F90:452
w3timemd
Definition: w3timemd.F90:3
w3parall
Parallel routines for implicit solver.
Definition: w3parall.F90:22
w3parall::init_get_isea
subroutine init_get_isea(ISEA, JSEA)
Set ISEA for all schemes.
Definition: w3parall.F90:1398
wmmdatmd::mpi_comm_mwave
integer mpi_comm_mwave
MPI_COMM_MWAVE.
Definition: wmmdatmd.F90:344