diff --git a/core/native/build_visual_studio/opendabridge/opendabridge.vcxproj b/core/native/build_visual_studio/opendabridge/opendabridge.vcxproj index b40b0e53a..4874a5620 100644 --- a/core/native/build_visual_studio/opendabridge/opendabridge.vcxproj +++ b/core/native/build_visual_studio/opendabridge/opendabridge.vcxproj @@ -32,28 +32,28 @@ true false Unicode - v142 + v143 DynamicLibrary true false Unicode - v142 + v143 DynamicLibrary false false Unicode - v142 + v143 DynamicLibrary false false Unicode - v142 + v143 diff --git a/model_efdc_dll/.gitignore b/model_efdc_dll/.gitignore new file mode 100644 index 000000000..ad1c781f2 --- /dev/null +++ b/model_efdc_dll/.gitignore @@ -0,0 +1,10 @@ +*genmod.* +*.obj +*.mod +*.lib +*.exp +*.u2d +*.pdb +*.manifest* + +BuildLog.htm diff --git a/model_efdc_dll/documentation.md b/model_efdc_dll/documentation.md index 0a008f298..cfc6720a7 100644 --- a/model_efdc_dll/documentation.md +++ b/model_efdc_dll/documentation.md @@ -57,14 +57,27 @@ C73 ISVPH NPVPH ISRVPH IVPHXY ## Restart files -Input +| Input | Output | +| ------ | ---- | +| RESTART.INP | RESTART.OUT | +| RSTWD.INP | RSTWD.OUT | +| TEMP.RST | TEMP.RSTO | +| WQWCRST.INP | TEMP.RSTO | + +## Run time period + +| Template file | EFDC file | Keyword | +| -------------------------- | ------------------------ | ---- | +| `EFDC_TEMPLATE.INP` |`EFDC.INP` | `C7` `$N_REF_PERIODS$` | +| `EFDC_TEMPLATE.INP` | `EFDC.INP` | `C8` `$RELATIVE_TSTART$` (`TCON` must be 86400) | +| `TOX_EVENT2_TEMPLATE.INP` | `TOX_EVENT2.INP` | `$TSTART$` `$TSTOP$` | + +### Logging + +| File | Content | +| ----- | ------- | +| `model.log` | Initialisation of dll, displays exchange items supported by current EFDC configuration | +| `instance001.log` | Per instance log, logs data exchange with exchange item id for times and values, compute steps, etc. | -``` -RESTART.INP, RSTWD.INP, TEMP.RST, WQWCRST.INP -``` -Output -``` -RESTART.OUT, RSTWD.OUT, TEMP.RSTO, WQWCRST.OUT -``` \ No newline at end of file diff --git a/model_efdc_dll/native/EFDCFortranDLL2012.sln b/model_efdc_dll/native/EFDCFortranDLL2022.sln similarity index 100% rename from model_efdc_dll/native/EFDCFortranDLL2012.sln rename to model_efdc_dll/native/EFDCFortranDLL2022.sln diff --git a/model_efdc_dll/native/efdc_fortran_dll/.gitignore b/model_efdc_dll/native/efdc_fortran_dll/.gitignore new file mode 100644 index 000000000..f49fd16f3 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/.gitignore @@ -0,0 +1 @@ +x64/ \ No newline at end of file diff --git a/model_efdc_dll/native/efdc_fortran_dll/EfdcFortranDLL.vfproj b/model_efdc_dll/native/efdc_fortran_dll/EfdcFortranDLL.vfproj index 82c740f42..9408f275f 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/EfdcFortranDLL.vfproj +++ b/model_efdc_dll/native/efdc_fortran_dll/EfdcFortranDLL.vfproj @@ -2,68 +2,163 @@ - + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -74,21 +169,21 @@ - + - + - + - + - + - + - + - + @@ -100,38 +195,38 @@ - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + @@ -154,7 +249,9 @@ + + @@ -164,25 +261,37 @@ + + + + + - + + + + + + + + @@ -191,22 +300,32 @@ + + + + + + + + + + @@ -222,6 +341,7 @@ + @@ -238,6 +358,8 @@ + + @@ -248,6 +370,7 @@ + @@ -259,6 +382,7 @@ + @@ -290,6 +414,7 @@ + @@ -305,8 +430,10 @@ + + @@ -329,6 +456,7 @@ + @@ -366,6 +494,7 @@ + @@ -378,11 +507,13 @@ + + @@ -397,5 +528,7 @@ - - + + + + diff --git a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_cser_time_series.f90 b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_cser_time_series.f90 index dbc2ba028..e4947990a 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_cser_time_series.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_cser_time_series.f90 @@ -222,7 +222,7 @@ function enlarge_cser_time_series(id,size_n,size_k,size_m) result(ret_val) if ((size_n > csert(id)%NDCSER)) then !reallocate instance memory - if (debug) print*, "enlarge_cser_time_series", id, n, m + if (debug) print*, "enlarge_cser_time_series", id, n, m , k if (debug) print*, "enlarge_cser_time_series", id, size_n, size_m, size_k allocate(csert_new%MCSER(new_m,NSTVM)) @@ -282,6 +282,7 @@ function enlarge_cser_time_series(id,size_n,size_k,size_m) result(ret_val) CSER(1:n,1:k,1:m,:)= CSER_orig deallocate(TCSER_orig, CSER_orig) + ndcser_max= NDCSER !ALLOCATE(CSERT_EFDC(KCM,0:NCSERM,NSTVM)) !ALLOCATE(MCTLAST(NCSERM,NSTVM)) diff --git a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init.f90 b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init.f90 index 007ddcb0f..cefd78b48 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init.f90 @@ -1,6 +1,7 @@ subroutine model_init use global + use mpi ! arguments !real, intent(out) :: time_period @@ -8,13 +9,15 @@ subroutine model_init ! local CHARACTER(len=80) :: TITLE - call model_init_1 + call model_init_1 ! opens output files ! ** CALL INPUT SUBROUTINE CALL VARINIT CALL INPUT(TITLE) + CALL MPI_DECOMPOSITION + call model_init_2 ! ** READ RESTART CONDITIONS OR INITIALIZE SCALAR FIELDS diff --git a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init_2.for b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init_2.for index 66f6db109..4a56358a7 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init_2.for +++ b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init_2.for @@ -184,6 +184,7 @@ C ** DXDJ use omp_lib USE GLOBAL + USE MPI @@ -1009,7 +1010,7 @@ C C C ** SET BOUNDARY CONDITION SWITCHES C - CALL SETBCS + CALL SETBCS_mpi C C ** CALCUATE CURVATURE METRICS (NEW ADDITION) C diff --git a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init_3.for b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init_3.for index 63d284bac..1afa939b8 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init_3.for +++ b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_init_3.for @@ -714,15 +714,7 @@ C C C ** INITIALIZE BUOYANCY AND EQUATION OF STATE C -!$OMP PARALLEL DO PRIVATE(LF,LL) - - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - CALL CALBUOY(LF,LL) -c - enddo + CALL CALBUOY_mpi C C ** INITIALIZE SFL IF(ISRESTI.EQ.0.AND ISTRAN(4).GE.1) C @@ -994,7 +986,7 @@ C ENDIF 5300 FORMAT(' M BELSURF ASURFEL ', & ' VOLSEL',/) - 5301 FORMAT(1X,I3,2X,F10.5,2X,E12.4,2X,E12.4) + 5301 FORMAT(1X,I4,2X,F10.5,2X,E12.4,2X,E12.4) 5302 FORMAT(/) 5303 FORMAT(2X,F10.5,3(2X,E12.4)) C @@ -1090,7 +1082,7 @@ C C ** SMOOTH INITIAL SALINITY C IF(NSBMAX.GE.1)THEN - CALL SALTSMTH + CALL SALTSMTH_mpi ENDIF C C ** OUTPUT INITIAL DEPTH AND SALINITY FIELDS @@ -1131,12 +1123,16 @@ C C C ** INITIALIZE EFDC EXPLORER OUTPUT C - IF(ISSPH(8).EQ.1.OR.ISBEXP.EQ.1) CALL EEXPOUT(1) + IF(IBIN_TYPE.EQ.1)THEN + IF(ISSPH(8).EQ.1.OR.ISBEXP.EQ.1) CALL EEXPOUT_mpi(1) + ELSEIF(IBIN_TYPE.EQ.0)THEN + IF(ISSPH(8).EQ.1.OR.ISBEXP.EQ.1) CALL EEXPOUT_opt_mpi(1) + ENDIF ! { GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 C ** INITIALIZE EFDC HYDRO DISTRIBUTION OUTPUT - IF(ISRESTO.LT.-20)THEN - CALL RESTOUT(-20) - ENDIF +! IF(ISRESTO.LT.-20)THEN +! CALL RESTOUT(-20) +! ENDIF ! } GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 END SUBROUTINE model_init_3 diff --git a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_make_step.f90 b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_make_step.f90 index c95ab1b9a..690c6c350 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_make_step.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_make_step.f90 @@ -17,8 +17,8 @@ subroutine model_make_step(time_period) write(*,'(A,F8.4,A,F6.1,A)') "time integration with HDMT from day ", TBEGIN, ' over ', time_period / 60.0, ' minutes' CALL HDMT elseif (IS2TIM.GE.1) then - write(*,'(A,F8.4,A,F6.1,A)') "time integration with HDMT2T from day ", TBEGIN, ' over ', time_period / 60.0, ' minutes' - CALL HDMT2T + write(*,'(A,F8.4,A,F6.1,A)') "time integration with HDMT2T_mpi from day ", TBEGIN, ' over ', time_period / 60.0, ' minutes' + CALL HDMT2T_mpi end if end subroutine model_make_step diff --git a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_state.f90 b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_state.f90 index 9a9f02fdf..b56b809f0 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_state.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/model_state.f90 @@ -534,6 +534,7 @@ function model_set_state(id) result(ret_val) WQV, WQVX,& ISRESTI, TIMEDAY, NXSP use model_extra_global + use mpi implicit none @@ -552,6 +553,8 @@ function model_set_state(id) result(ret_val) call INPUT(TITLE) + call MPI_DECOMPOSITION + call model_init_2 ! Act like this is a restart diff --git a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/openDA_wrapper.F90 b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/openDA_wrapper.F90 index cd48f1505..75396db4c 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/openDA_wrapper.F90 +++ b/model_efdc_dll/native/efdc_fortran_dll/openDA_wrapper/openDA_wrapper.F90 @@ -102,6 +102,7 @@ function m_openda_wrapper_init_(parent_directory_c, template_directory_c)& #endif use omp_lib + use mpi USE GLOBAL, only: TBEGIN, TCON, TIDALP, NTC, TIMEDAY, & NDASER, NASERM, NDPSER, NPSERM, NDQSER, NQSERM,NDCSER, NCSERM, & NTOX, NSED, NSND, NWQV, NTHDS, NDQCLT, NQCTLM, & @@ -113,7 +114,7 @@ function m_openda_wrapper_init_(parent_directory_c, template_directory_c)& ! return value integer(kind=c_int) :: ret_val ! ret_val < 0: Error; ret_val == 0 success - + !locals character(len=max_path_length) :: output_file_name, message_file_name character(len=max_path_length) :: cwd @@ -123,39 +124,45 @@ function m_openda_wrapper_init_(parent_directory_c, template_directory_c)& integer :: i_number integer :: i logical :: i_open - + + ! initialise MPI environments + ! + ! NOTE: This only supports runs with maximum of 1 rank and no care has been + ! taken to isolate print statements to run only on the first rank. + call mpi_initialize + ! body ret_val = -1 ret_val = c_to_f_string(parent_directory_c, parent_directory) - if (ret_val /= 0) then + if (ret_val /= 0) then print*, "ERROR: maximum path length exceeded for ", parent_directory return end if ret_val = c_to_f_string(template_directory_c, template_directory) - if (ret_val /= 0) then + if (ret_val /= 0) then print*, "ERROR: maximum path length exceeded for ", template_directory return end if - + dm_model_parent_dir = trim(parent_directory) dm_template_model_dir = trim(template_directory) print*, trim(dm_model_parent_dir) output_file_name = trim(dm_model_parent_dir) // '/model.log' message_file_name = trim(dm_model_parent_dir) // '/messages.log' - + ! create new model.log - inquire(file = output_file_name, opened=i_open, number=i_number) + inquire(file = output_file_name, opened=i_open, number=i_number) if (i_open .and. (i_number == dm_general_log_handle)) close(i_number) open(dm_general_log_handle, file=output_file_name, status = 'replace') write(dm_general_log_handle,'(A)') 'EFDC initialized' ! create new messages.log - inquire(file = message_file_name, opened=i_open, number=i_number) + inquire(file = message_file_name, opened=i_open, number=i_number) if (i_open .and. (i_number == message_file_handle)) close(i_number) open(message_file_handle, file=message_file_name, status = 'replace') - + message = "Starting EFDC run" call write_message(message, M_INFO) @@ -184,6 +191,9 @@ function m_openda_wrapper_init_(parent_directory_c, template_directory_c)& if (ret_val == 0 ) then write(dm_general_log_handle,'(A, I2)') "integer kind: ", kind(NTC) write(dm_general_log_handle,'(A, I2)') "real kind: ", kind(TIDALP) + print*, 'TBEGIN, TCON =', TBEGIN, TCON + + TIMEDAY = TBEGIN* TCON / 86400.d0 ! store sizes of time series (the global ones are redetermined each time we do a restart) @@ -250,7 +260,8 @@ subroutine m_openda_wrapper_destroy_()& write(dm_general_log_handle,'(A)') 'EFDC destroy()' close(dm_general_log_handle) close(message_file_handle) - + + call mpi_finalize(ret_val) end subroutine m_openda_wrapper_destroy_ ! -------------------------------------------------------------------------- @@ -506,6 +517,7 @@ function m_openda_wrapper_select_instance_from_restart_files_(instance) & #endif use global, only : ISTRAN, IWQRST, IWQBEN, ISMRST, ISRESTI, TIMESEC, TIMEDAY, TBEGIN, IWQAGR, HP + use mpi ! return value @@ -530,6 +542,7 @@ function m_openda_wrapper_select_instance_from_restart_files_(instance) & call INPUT(TITLE) ! Act like this is a restart + call MPI_DECOMPOSITION ISRESTI = 1 call model_init_2 @@ -818,7 +831,7 @@ function m_openda_wrapper_get_current_time_(instance, current_time)& !current_time = dble(state(instance)%timesec) / 86400.0d0 current_time = real( dt * nint( state(instance)%timesec/ dt), c_double) / 86400.0d0 ret_val = 0 - + write(dm_outfile_handle(instance), '(A,I4,A,F14.10,A)') & 'get_current_time( instance: ', instance, ', current_time: ' , current_time, ')' call flush(dm_outfile_handle(instance)) @@ -873,7 +886,7 @@ function m_openda_wrapper_compute_(instance, from_time_stamp, to_time_stamp)& TBEGIN = state(instance)%tbegin TIMESEC = state(instance)%timesec TIMEDAY = TIMESEC/86400.0 - if (debug) write(dm_outfile_handle(instance), '(A, F8.3, A, I5)' ) & + if (debug) write(dm_outfile_handle(instance), '(A, F9.3, A, I5)' ) & "Integrating over [s] ", time_period, " #steps", nint(time_period/dt) call model_make_step(time_period) state(instance)%timesec = TIMESEC @@ -1089,7 +1102,7 @@ function m_openda_wrapper_get_times_for_ei_(instance, exchange_item_id, bc_index if (ret_val < 0) then write(dm_outfile_handle(instance),'(A,I2,A,I4,A,I4)') 'Error in get_times_for_ei: ', ret_val, ' for ', exchange_item_id else - write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A,I4,A)') 'get_times_for_ei( instance: ', instance, & + write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A,I8,A)') 'get_times_for_ei( instance: ', instance, & ', exchange_item_id: ', exchange_item_id, ', bc_index: ' , bc_index, ', values_count: ', values_count ,')' write(dm_outfile_handle(instance),*) times(1:min(9,values_count)) if ( values_count .ge. 13 ) then @@ -1278,7 +1291,7 @@ function m_openda_wrapper_set_times_for_ei_(instance, exchange_item_id, bc_index if (ret_val < 0) then write(dm_outfile_handle(instance),'(A,I2,A,I4)') 'Error in set_times_for_ei: ', ret_val, ' for ', exchange_item_id else - write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A,I4,A)') 'set_times_for_ei( instance: ', instance, & + write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A,I8,A)') 'set_times_for_ei( instance: ', instance, & ', exchange_item_id: ', exchange_item_id, ', bc_index: ' , bc_index, ', values_count: ', values_count ,')' write(dm_outfile_handle(instance),'(A,F8.4)') 'conversion_factor: ', factor write(dm_outfile_handle(instance),*) times(1:min(9,values_count)) @@ -1604,7 +1617,7 @@ function m_openda_wrapper_get_values_(instance, exchange_item_id, start_index, e exchange_item_id, ' is not configured in EFDC.' else last_index = end_index - start_index+1 - write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A)') 'get_values( exchange_item_id: ', & + write(dm_outfile_handle(instance),'(A,I4,A,I8,A,I8,A)') 'get_values( exchange_item_id: ', & exchange_item_id, ', start_index: ' , start_index, ', end_index: ', end_index, '):' write(dm_outfile_handle(instance),*) values(1:min(9,last_index)) if ( last_index .ge. 13 ) then @@ -1709,7 +1722,7 @@ function m_openda_wrapper_set_values_(instance, exchange_item_id, start_index, e exchange_item_id, ' is not configured in EFDC.' else last_index = end_index - start_index+1 - write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A)') 'set_values( exchange_item_id: ', & + write(dm_outfile_handle(instance),'(A,I4,A,I8,A,I8,A)') 'set_values( exchange_item_id: ', & exchange_item_id, ', start_index: ' , start_index, ', end_index: ', end_index, '):' write(dm_outfile_handle(instance),*) values(1:min(9,last_index)) if ( last_index .ge. 13 ) then @@ -2025,7 +2038,7 @@ function m_openda_wrapper_get_times_count_for_time_span_(instance, exchange_item elseif (ret_val < 0) then write(dm_outfile_handle(instance),'(A,I2)') 'Error in get_times_count_for_time_span: ', ret_val else - write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A,F8.2,A,F8.2,A,I4)') & + write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A,F8.2,A,F8.2,A,I8)') & 'get_times_count_for_time_span( instance: ', instance, & ', exchange_item_id: ', exchange_item_id,& ', bc_index: ', bc_index,& @@ -2207,7 +2220,7 @@ function m_openda_wrapper_get_values_for_time_span_(instance, exchange_item_id, exchange_item_id, ' not configured in EFDC.' else last_index = end_index-start_index+1 - write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A,I4,A,F8.2,A,F8.2,A,I4,A)') & + write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A,I4,A,F8.2,A,F8.2,A,I8,A)') & 'get_values_for_time_span( instance', instance, & ', exchange_item_id: ', exchange_item_id, ', bc_index: ', bc_index , & ', layer_index: ', layer_index , & @@ -2381,7 +2394,7 @@ function m_openda_wrapper_set_values_for_time_span_(instance, exchange_item_id, exchange_item_id, ' not configured in EFDC.' else last_index = end_index-start_index+1 - write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A,F8.2,A,F8.2,A,I4,A)') & + write(dm_outfile_handle(instance),'(A,I4,A,I4,A,I4,A,F8.2,A,F8.2,A,I8,A)') & 'set_values_for_time_span( instance', instance, & ', exchange_item_id: ', exchange_item_id, ', bc_index: ', bc_index , & ', start_time: ', start_time, ', end_time: ', end_time, ', values_count: ', values_count ,'):' diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/AINIT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/AINIT.for index ed88afa1b..a9a804a82 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/AINIT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/AINIT.for @@ -9,8 +9,9 @@ C C ALL ZEROING OF ARRAYS MOVED TO ZERO C USE GLOBAL + USE MPI IMPLICIT NONE - INTEGER::L,I,J,LS,LV,NT,LCHNV,IVAL,NS,K,NMD,LHOST,LCHNU,NV,NX + INTEGER::L,I,J,LS,NT,LCHNV,IVAL,NS,K,NMD,LHOST,LCHNU,NV,NX INTEGER::NTMPC,NTMPN C C ** INITIALIZE ARRAYS @@ -116,6 +117,8 @@ C SDY(L)=1. LMASKDRY(L)=.TRUE. ENDDO + IF(.NOT.ALLOCATED(MPI_IMASKDRY)) ALLOCATE(MPI_IMASKDRY(LCM)) + C C *** DSLLC BEGIN BLOCK ! *** OPEN WATER DEFAULT SETTINGS diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T3A.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T3A.for index 5e2d629f2..bc21f48ab 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T3A.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T3A.for @@ -12,7 +12,6 @@ C IMPLICIT NONE INTEGER::LD,K,L,NSX,NS,NWR,NCTL,ID,JD,KU,NT,M,JU,LU,KD,LL,NQSTMP INTEGER::IU,NCSTMP - INTEGER::LF,ithds REAL::RQWD IF(ISDYNSTP.EQ.0)THEN @@ -23,20 +22,12 @@ C C C ** ACCUMULATE INTERNAL SOURCES AND SINKS C -!$OMP PARALLEL DO PRIVATE(LF,LL) REDUCTION(-:VOLOUT,WVOLOUT) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA VOLOUT=VOLOUT-DELT*(QSUME(L)-QDWASTE(L)) -c ENDDO -c DO L=2,LA + ENDDO + DO L=2,LA WVOLOUT=WVOLOUT-DELT*(QSUME(L)-QDWASTE(L)) ENDDO -c - enddo - DO K=1,KC DO LL=1,NQSIJ L=LQS(LL) @@ -45,19 +36,11 @@ c ENDDO ENDDO IF(ISTRAN(1).GE.1)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_2_LC(1,ithds) - LL=jse_2_LC(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LC CONT(L,K)=SAL1(L,K) ENDDO ENDDO -c - enddo - DO NS=1,NQSIJ L=LQS(NS) NQSTMP=NQSERQ(NS) @@ -104,19 +87,11 @@ c ENDDO ENDIF IF(ISTRAN(3).GE.1)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_2_LC(1,ithds) - LL=jse_2_LC(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LC CONT(L,K)=DYE1(L,K) ENDDO ENDDO -c - enddo - DO NS=1,NQSIJ L=LQS(NS) NQSTMP=NQSERQ(NS) @@ -176,18 +151,11 @@ c IF(ISTRAN(5).GE.1)THEN DO NT=1,NTOX M=MSVTOX(NT) -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_2_LC(1,ithds) - LL=jse_2_LC(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LC CONT(L,K)=TOX1(L,K,NT) ENDDO ENDDO -c - enddo C C TOXOUT2T(NT) IS NET TOXIC MASS GOING OUT OF DOMAIN DUE C TO WATER COLUMN VOLUME SOURCES AND SINKS @@ -241,18 +209,11 @@ C IF(ISTRAN(6).GE.1)THEN DO NSX=1,NSED M=MSVSED(NSX) -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_2_LC(1,ithds) - LL=jse_2_LC(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LC CONT(L,K)=SED1(L,K,NSX) ENDDO ENDDO -c - enddo C C SEDOUT2T(NSX) IS IS NET COHESIVE MASS GOING OUT OF DOMAIN DUE C TO WATER COLUMN VOLUME SOURCES AND SINKS @@ -306,18 +267,11 @@ C IF(ISTRAN(7).GE.1)THEN DO NSX=1,NSND M=MSVSND(NSX) -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_2_LC(1,ithds) - LL=jse_2_LC(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LC CONT(L,K)=SND1(L,K,NSX) ENDDO ENDDO -c - enddo C C SNDOUT2T(NSX) IS NET NONCOHESIVE MASS GOING OUT OF DOMAIN DUE C TO WATER COLUMN VOLUME SOURCES AND SINKS @@ -368,7 +322,7 @@ C ENDDO ENDDO ENDIF - 800 FORMAT('N,NS,SNDFBL2T,DEL',2I5,2E14.5) +C 800 FORMAT('N,NS,SNDFBL2T,DEL',2I5,2E14.5) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T3B.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T3B.for index 0745a337b..ae4a4b4fc 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T3B.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T3B.for @@ -8,9 +8,9 @@ C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM, C ** AND ENERGY BALANCES C USE GLOBAL + USE MPI IMPLICIT NONE INTEGER::LUTMP,LDTMP,L,K,NSX,NSB,IBALSTDT,NT,M - INTEGER::LF,LL,ithds IF(ISDYNSTP.EQ.0)THEN DELT=DT ELSE @@ -20,36 +20,21 @@ C C ** ACCUMULATE INTERNAL SOURCES AND SINKS C IF(IBALSTDT.EQ.1)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) REDUCTION(-:WVOLOUT) -!$OMP& REDUCTION(+:BVOLOUT,VOLMORPH2T) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA WVOLOUT=WVOLOUT-DTSED*QMORPH(L) BVOLOUT=BVOLOUT+DTSED*QMORPH(L) VOLMORPH2T=VOLMORPH2T+DTSED*QMORPH(L) ENDDO -c - enddo ENDIF IF(ISTRAN(5).GE.1)THEN DO NT=1,NTOX M=MSVTOX(NT) - WRITE(8,*)'NT M ',NT,M -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_2_LC(1,ithds) - LL=jse_2_LC(2,ithds) -c + IF(MYRANK.EQ.0) WRITE(8,*)'NT M ',NT,M DO K=1,KC - DO L=LF,LL + DO L=2,LC CONT(L,K)=TOX(L,K,NT) ENDDO ENDDO -c - enddo C C TOXBLB2T(NT) IS NET TOXIC MASS GOING OUT OF DOMAIN DUE C DUE TO BED LOAD TRANSPORT OUT OF DOMAIN @@ -79,18 +64,11 @@ C IF(ISTRAN(6).GE.1)THEN DO NSX=1,NSED M=MSVSED(NSX) -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_2_LC(1,ithds) - LL=jse_2_LC(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LC CONT(L,K)=SED(L,K,NSX) ENDDO ENDDO -c - enddo C C SEDFLUX2T(NSX) IS IS NET COHESIVE MASS FLUX POSITIVE FROM BED C TO WATER COLUMN @@ -105,18 +83,11 @@ C IF(ISTRAN(7).GE.1)THEN DO NSX=1,NSND M=MSVSND(NSX) -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_2_LC(1,ithds) - LL=jse_2_LC(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LC CONT(L,K)=SND(L,K,NSX) ENDDO ENDDO -c - enddo C C SBLOUT2T(NSX) IS NET NONCOHESIVE SEDIMENT MASS GOING OUT OF DOMAIN DU C DUE TO BED LOAD TRANSPORT OUT OF DOMAIN @@ -148,7 +119,7 @@ C ENDIF ENDDO ENDIF - 800 FORMAT('N,NS,SNDFBL2T,DEL',2I5,2E14.5) +C 800 FORMAT('N,NS,SNDFBL2T,DEL',2I5,2E14.5) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T4.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T4.for index 0add211ba..6e398a053 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T4.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T4.for @@ -7,7 +7,7 @@ C ** AND ENERGY BALANCES C USE GLOBAL IMPLICIT NONE - INTEGER::L,LN,K,LF,LL,ithds + INTEGER::L,LN,K REAL::DUTMP,DVTMP IF(ISDYNSTP.EQ.0)THEN DELT=DT @@ -17,13 +17,7 @@ C C C ** CALCULATE MOMENTUM AND ENERGY DISSIPATION C -!$OMP PARALLEL DO PRIVATE(LF,LL,LN,DUTMP,DVTMP) -!$OMP& REDUCTION(+:UUEOUT,VVEOUT,BBEOUT) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA LN=LNC(L) UUEOUT=UUEOUT+0.5*DELT*SPB(L)*DXYP(L)*(U(L,1)*TBX(L) & +U(L+1,1)*TBX(L+1)-U(L,KC)*TSX(L)-U(L+1,KC)*TSX(L+1)) @@ -31,7 +25,7 @@ c & +V(LN,1)*TBX(LN)-V(L,KC)*TSY(L)-V(LN,KC)*TSX(LN)) ENDDO DO K=1,KS - DO L=LF,LL + DO L=2,LA LN=LNC(L) DUTMP=0.5*( U(L,K+1)+U(L+1,K+1)-U(L,K)-U(L+1,K) ) DVTMP=0.5*( V(L,K+1)+V(LN,K+1)-V(L,K)-V(LN,K) ) @@ -43,8 +37,6 @@ c & *GP*AB(L,K)*(B(L,K+1)-B(L,K)) ENDDO ENDDO -c - enddo RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T5.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T5.for index 83de0534c..39aede618 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T5.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BAL2T5.for @@ -23,6 +23,7 @@ C C**********************************************************************C C USE GLOBAL + USE MPI IMPLICIT NONE INTEGER::K,L,NS @@ -31,9 +32,9 @@ C REAL::DYEERR2T,UMOERR,VMOERR,ENEERR,RVERDE,REERDE,RVERDO REAL::RVERDO2T,RWVERDO2T,RSERDO,RDERDO,RDERDO2T,RUERDO,REERDO REAL::RDERDE,RUERDE2T,RBVERDE2T,RDERDE2T,RUMERDE,RUMERDO - REAL::RMVERDO,UUEBMO,RVMERDO,VVEBMO,PPEBMO,TMPVAL,BBEBMO,SBLOUT2TT + REAL::UUEBMO,RVMERDO,VVEBMO,PPEBMO,TMPVAL,BBEBMO,SBLOUT2TT REAL::RVERDE2T,RWVERDE2T,RSERDE,RVMERDE,VOLBMO,VMOBMO,ENEBMO - REAL::ENEBEG,ENEEND,ENEOUT,AMOEND,UUEND,VVEEND,PPEEND,BBEEND + REAL::ENEBEG,ENEEND,ENEOUT,AMOEND,VVEEND,PPEEND,BBEEND REAL::UUEEND,VMOEND,SALEND,TIME,VOLEND,VOLEND2T,BVOLEND2T REAL::WVOLEND2T,DYEEND,UMOEND INTEGER::NT,LN @@ -464,6 +465,7 @@ C ** OUTPUT BALANCE RESULTS TO FILE BAL2T.OUT C C----------------------------------------------------------------------C C + IF(MYRANK.EQ.0)THEN IF(JSBAL.EQ.1)THEN OPEN(89,FILE='BAL2T.OUT') CLOSE(89,STATUS='DELETE') @@ -731,6 +733,7 @@ C CLOSE(82) CLOSE(83) CLOSE(84) + ENDIF ! MYRANK0 C 8899 FORMAT(A18,E15.7) 950 FORMAT(I5,12E17.9) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDINIT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDINIT.for index b56aece12..0051acc25 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDINIT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDINIT.for @@ -7,6 +7,7 @@ C ADDED ADDITIONAL DIAGNOSTIC OUTPUT C MOVED TOXIC INITIALIZATIONS FROM SSEDTOX C USE GLOBAL + USE MPI IMPLICIT NONE INTEGER::K,L,NS,NX,NT,KTOPP1,IVAL,KTOPTP,IHOTSTRT @@ -1117,7 +1118,7 @@ C C C ** DIAGNOSTICS OF INITIALIZATION C - IF(ISDTXBUG.EQ.1)THEN + IF(ISDTXBUG.EQ.1.AND.MYRANK.EQ.0)THEN OPEN(2,FILE='TOXBED.DIA') CLOSE(2,STATUS='DELETE') OPEN(2,FILE='TOXBED.DIA') @@ -1251,7 +1252,7 @@ C C** WRITE DIAGNOSTIC FILES FOR BED INITIALIZATION C 1000 CONTINUE - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='BEDINIT.SED') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='BEDINIT.SED') diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDLOAD.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDLOAD.for index 407de0344..7174640a1 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDLOAD.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDLOAD.for @@ -508,8 +508,8 @@ C SNDFBLTOT=SNDFBLTOT+DXYP(L)*SNDFBL(L,NX) ENDIF ENDDO - 8999 FORMAT(' BL ',3I5,5E14.5) - 8862 FORMAT(' SNDFBLTOT,QSBLLDXY',3I5,5E14.5) +C8999 FORMAT(' BL ',3I5,5E14.5) +C8862 FORMAT(' SNDFBLTOT,QSBLLDXY',3I5,5E14.5) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDPLTH.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDPLTH.for index 5b469526c..8588aa606 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDPLTH.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BEDPLTH.for @@ -6,6 +6,7 @@ C ADD OUTPUT OF BED LOAD TRANSPORT QSBDLDX QSBDLDY C ** SUBROUTINE WRITES SEDIMENT BED PROPERTIES C USE GLOBAL + USE MPI IMPLICIT NONE INTEGER::L,K,NX,NS,NSXD,KTMP REAL::TIME @@ -29,6 +30,7 @@ C 3 WRITE NONCOHESIVE SEDIMENT (FRACTION OF TOTAL SEDIMENT+ C ISBVDR: 1 WRITE LAYER VOID RATIOS C IF(JSBPH.EQ.1)THEN + IF(MYRANK.EQ.0)THEN IF(ISBEXP.EQ.0)THEN OPEN(1,FILE='BEDSUM.OUT') CLOSE(1,STATUS='DELETE') @@ -71,6 +73,7 @@ C OPEN(1,FILE='BEDARD.OUT') WRITE(1,131) CLOSE(1) + ENDIF JSBPH=0 ENDIF C @@ -84,7 +87,7 @@ C ENDIF NSXD=NSED+NSND C - IF(ISBEXP.EQ.0)THEN + IF(ISBEXP.EQ.0.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='BEDSUM.OUT',POSITION='APPEND') WRITE(1,122)TIME DO L=2,LA @@ -186,7 +189,7 @@ C ENDDO CLOSE(1) ENDIF - 339 FORMAT(2I5,6F14.5) +C 339 FORMAT(2I5,6F14.5) 103 FORMAT(3I5,18E13.5) 101 FORMAT(2I5,18E13.5) 102 FORMAT(10X,18E13.5) @@ -197,21 +200,21 @@ C 114 FORMAT(' IL JL PORBED(K=1,KB)') 115 FORMAT(' IL JL ZBEDB HBEDT HBED(K=1,KB)') 116 FORMAT(' IL JL BDENBED(K=1,KB)') - 118 FORMAT(' IL JL SEDT(K=1,KC)') - 119 FORMAT(' IL JL SNDT(K=1,KC)') - 120 FORMAT(' IL JL QSBDLDX QSBDLDY') - 121 FORMAT(' IL JL TOXB(K=1,KB,NT) NT = ',I5) +C 118 FORMAT(' IL JL SEDT(K=1,KC)') +C 119 FORMAT(' IL JL SNDT(K=1,KC)') +C 120 FORMAT(' IL JL QSBDLDX QSBDLDY') +C 121 FORMAT(' IL JL TOXB(K=1,KB,NT) NT = ',I5) 131 FORMAT(' IL JL (SEDFDTAP SEDFDTAN)(1,NSED)', & ' (SNDFDTAP SNDFDTAN)(1,NSND)') 122 FORMAT(F12.5,' TIME OF OUTPUT') - 906 FORMAT(5E17.8) - 907 FORMAT(13E17.8) - 908 FORMAT(12I10) - 909 FORMAT(I20,4X,F12.4) - 910 FORMAT(6I5,2X,E17.8,2X,E17.8) - 911 FORMAT(2I5,2X,6E13.4) - 912 FORMAT(3I5,12F7.3) - 913 FORMAT(6I5,4F7.3) +C 906 FORMAT(5E17.8) +C 907 FORMAT(13E17.8) +C 908 FORMAT(12I10) +C 909 FORMAT(I20,4X,F12.4) +C 910 FORMAT(6I5,2X,E17.8,2X,E17.8) +C 911 FORMAT(2I5,2X,6E13.4) +C 912 FORMAT(3I5,12F7.3) +C 913 FORMAT(6I5,4F7.3) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BUDGET3.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BUDGET3.for index b8ffe75d1..35fce8a3d 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BUDGET3.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BUDGET3.for @@ -200,7 +200,7 @@ C ENDDO ENDDO ENDIF - 600 FORMAT(' VOLCON,VOLMAS = ',2E14.6) +C 600 FORMAT(' VOLCON,VOLMAS = ',2E14.6) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BUDGET5.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BUDGET5.for index fae350b70..877c407bc 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BUDGET5.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/BUDGET5.for @@ -5,6 +5,7 @@ C CHANGE RECORD C ** SUBROUTINES BUDGETN CALCULATE SEDIMENT BUDGET (TOTAL SEDIMENTS) C USE GLOBAL + USE MPI IMPLICIT NONE INTEGER::NS,L,K REAL::SEDBTMP1,SEDBTMP,SFLXTMP,BSEDERR,SSEDOUT,BSEDOUT,SSEDERE @@ -14,7 +15,7 @@ C C ** CHECK FOR END OF BALANCE PERIOD C IF(NBUD.EQ.NTSMMT)THEN - 6666 FORMAT(' ACTIVE CALL TO BUDGET5, N,NBUD = ',2I5) +C6666 FORMAT(' ACTIVE CALL TO BUDGET5, N,NBUD = ',2I5) C C ** CALCULATE ENDING SUSPENDED AND BOTTOM SEDIMENT IN THE MODEL DOMAIN C @@ -145,7 +146,7 @@ C C C ** OUTPUT BALANCE RESULTS TO FILE BUDGET.OUT C - IF(JSSBAL.EQ.1)THEN + IF(JSSBAL.EQ.1.AND.MYRANK.EQ.0)THEN OPEN(89,FILE='BUDGET.OUT',STATUS='UNKNOWN') OPEN(93,FILE='BUDGET2.OUT',STATUS='UNKNOWN') OPEN(94,FILE='BUDGET3.OUT',STATUS='UNKNOWN') @@ -190,16 +191,16 @@ C CLOSE(89) CLOSE(93) CLOSE(94) - 9510 FORMAT(//' SUS AND BED SED BUDGET ENDING AT N =',I7/) - 9511 FORMAT(' SEDIN,SEDOUT,SDFLUX = ',3E15.7/) - 9512 FORMAT(' SSEDBEG,BSEDBEG = ',2E15.7/) - 9513 FORMAT(' SSEDOUT,BSEDOUT = ',2E15.7/) - 9514 FORMAT(' SSEDBMO,BSEDBMO = ',2E15.7/) - 9515 FORMAT(' SSEDEND,BSEDEND = ',2E15.7/) - 9516 FORMAT(' SSEDERR,BSEDERR = ',2E15.7/) - 9517 FORMAT(' SSEDERE,BSEDERE = ',2E15.7/) - 9600 FORMAT(/'C ACCUMULATED SED FLUX AT N = ',I5) - 9601 FORMAT(2I5,5E15.7) +C9510 FORMAT(//' SUS AND BED SED BUDGET ENDING AT N =',I7/) +C9511 FORMAT(' SEDIN,SEDOUT,SDFLUX = ',3E15.7/) +C9512 FORMAT(' SSEDBEG,BSEDBEG = ',2E15.7/) +C9513 FORMAT(' SSEDOUT,BSEDOUT = ',2E15.7/) +C9514 FORMAT(' SSEDBMO,BSEDBMO = ',2E15.7/) +C9515 FORMAT(' SSEDEND,BSEDEND = ',2E15.7/) +C9516 FORMAT(' SSEDERR,BSEDERR = ',2E15.7/) +C9517 FORMAT(' SSEDERE,BSEDERE = ',2E15.7/) +C9600 FORMAT(/'C ACCUMULATED SED FLUX AT N = ',I5) +C9601 FORMAT(2I5,5E15.7) 888 FORMAT (6X,' SEDIMENT BUDGET CALCULATIONS'// & 6X,'SEDIMENT BUDGET OVER ',I5,' TIME STEPS'/ & 6X,'STARTING ON JULIAN DAY ',F6.2/ diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB.for index b71b2cd04..a00eaf284 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB.for @@ -9,7 +9,7 @@ C ADDED DRYCELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES C USE GLOBAL IMPLICIT NONE - INTEGER::L,K,LS,ISTL_,LF,LL,ithds + INTEGER::L,K,LS,ISTL_ REAL::QQIMAX,RIQMIN,RIQMAX,RIQ,SFAV,SFAB,ABTMP,AVTMP C C SHTOP = 0.4939 @@ -31,23 +31,14 @@ C ABMIN=10. RIQMIN=-0.023 RIQMAX=0.28 -! -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -! DO K=1,KC - DO L=LF,LL + DO L=1,LC IF(IMASKDRY(L).EQ.1)THEN AV(L,K)=AVO*HPI(L) AB(L,K)=ABO*HPI(L) ENDIF ENDDO ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO IF(ISFAVB.EQ.0)THEN DO K=1,KS DO L=2,LA @@ -85,17 +76,15 @@ C ENDDO ENDIF IF(ISFAVB.EQ.1)THEN -! -!$OMP PARALLEL DO PRIVATE(LF,LL,RIQ,SFAV,SFAB,ABTMP,AVTMP) -!$OMP& REDUCTION(max:AVMAX,ABMAX) REDUCTION(min:AVMIN,ABMIN) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN QQI(L)=1./QQ(L,K) QQI(L)=MIN(QQI(L),QQIMAX) + ENDIF + ENDDO + DO L=2,LA + IF(LMASKDRY(L))THEN RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K) & *(B(L,K+1)-B(L,K))*QQI(L) RIQ=MAX(RIQ,RIQMIN) @@ -121,9 +110,6 @@ C ENDIF ENDDO ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO ENDIF IF(ISFAVB.EQ.2)THEN DO K=1,KS @@ -159,29 +145,17 @@ C ENDIF ! *** NOW APPLY MAXIMUM, IF REQURIED IF(ISAVBMX.GE.1)THEN -! -!$OMP PARALLEL DO PRIVATE(LF,LL,ABTMP,AVTMP) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) DO K=1,KS - DO L=LF,LL + DO L=2,LA AVTMP=AVMX*HPI(L) ABTMP=ABMX*HPI(L) AV(L,K)=MIN(AV(L,K),AVTMP) AB(L,K)=MIN(AB(L,K),ABTMP) ENDDO ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO ENDIF -!$OMP PARALLEL DO PRIVATE(LF,LL,LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) DO K=1,KS - DO L=LF,LL + DO L=2,LA LS=LSC(L) c pmc AVUI(L,K)=2./(AV(L,K)+AV(L-1,K)) c pmc AVVI(L,K)=2./(AV(L,K)+AV(LS,K)) @@ -190,17 +164,14 @@ c pmc AVVI(L,K)=2./(AV(L,K)+AV(LS,K)) ENDDO ENDDO DO K=2,KS - DO L=LF,LL + DO L=2,LA AQ(L,K)=0.205*(AV(L,K-1)+AV(L,K)) ENDDO ENDDO - DO L=LF,LL + DO L=2,LA AQ(L,1)=0.205*AV(L,1) AQ(L,KC)=0.205*AV(L,KS) ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB2.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB2.for index 59ef60485..43dad61a9 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB2.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB2.for @@ -23,9 +23,9 @@ C REAL*8 TMPVAL,TMPVAL1,SBTOP,SVTOP,TMPVAL2,SVTOP2,SVBOT REAL*8 SFAV,SFAB,SBBOT,TMPVAL3 REAL*8 ATURB1,ATURB2,TURBC1 - REAL*8 AVTMP,ABTMP,BBTC,DELBSQ + REAL*8 AVTMP,ABTMP C - REAL*8 TMP1,AQTMP + REAL*8 AQTMP C INTEGER K,L,LS,ISTL_ C @@ -59,12 +59,13 @@ C IF(RITMP.GT.0.)THEN RIQ=DML(L,K)*DML(L,K)*RITMP BFUN=EXP(-3.11*RIQ) - CTURBB1(L,K)=CTURB/(BFUN+1.E-12) + CTURBB1(L,K)=REAL(CTURB/(BFUN+1.E-12),KIND(CTURBB1)) ! *** Original Code IF(BBT(L,K).GT.0.)THEN ! *** PMC BBT is never set, so this is never used TMPVAL=DELBTMP*DELBTMP/(RITMP*BBT(L,K)) - CTURBB2(L,K)=CTURB2B/(1.+0.61*(1.-BFUN)*TMPVAL) + CTURBB2(L,K)=REAL(CTURB2B/(1.+0.61*(1.-BFUN)*TMPVAL), + & KIND(CTURBB2)) ENDIF ENDIF ENDDO @@ -89,14 +90,14 @@ C AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO C IF(ISFAVB.EQ.0)THEN - AV(L,K)=AVTMP*HPI(L) - AB(L,K)=SCB(L)*ABTMP*HPI(L) + AV(L,K)=REAL(AVTMP*HPI(L),KIND(AV)) + AB(L,K)=REAL(SCB(L)*ABTMP*HPI(L),KIND(AB)) ELSEIF(ISFAVB.EQ.1)THEN - AV(L,K)=0.5*(AV(L,K)+AVTMP*HPI(L)) - AB(L,K)=SCB(L)*0.5*(AB(L,K)+ABTMP*HPI(L)) + AV(L,K)=REAL(0.5*(AV(L,K)+AVTMP*HPI(L)),KIND(AV)) + AB(L,K)=REAL(SCB(L)*0.5*(AB(L,K)+ABTMP*HPI(L)),KIND(AB)) ELSEIF(ISFAVB.EQ.2)THEN - AV(L,K)=SQRT(AV(L,K)*AVTMP*HPI(L)) - AB(L,K)=SCB(L)*SQRT(AB(L,K)*ABTMP*HPI(L)) + AV(L,K)=REAL(SQRT(AV(L,K)*AVTMP*HPI(L)),KIND(AV)) + AB(L,K)=REAL(SCB(L)*SQRT(AB(L,K)*ABTMP*HPI(L)),KIND(AB)) ENDIF ENDDO ENDDO @@ -122,8 +123,8 @@ C DO L=2,LA AVTMP=AVMX*HPI(L) ABTMP=ABMX*HPI(L) - AV(L,K)=MIN(AV(L,K),AVTMP) - AB(L,K)=MIN(AB(L,K),ABTMP) + AV(L,K)=REAL(MIN(AV(L,K),AVTMP),KIND(AV)) + AB(L,K)=REAL(MIN(AB(L,K),ABTMP),KIND(AB)) ENDDO ENDDO ENDIF @@ -150,14 +151,14 @@ C DO K=2,KS DO L=2,LA AQTMP=0.205*(AV(L,K-1)+AV(L,K)) - AQ(L,K)=AQTMP + AQ(L,K)=REAL(AQTMP,KIND(AQ)) ENDDO ENDDO DO L=2,LA AQTMP=0.205*AV(L,1) - AQ(L,1)=AQTMP + AQ(L,1)=REAL(AQTMP,KIND(AQ)) AQTMP=0.205*AV(L,KS) - AQ(L,KC)=AQTMP + AQ(L,KC)=REAL(AQTMP,KIND(AQ)) ENDDO ENDIF diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVBOLD.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVBOLD.for index b354a9a85..ca32d4838 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVBOLD.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVBOLD.for @@ -14,7 +14,6 @@ C REAL::QQIMAX,RIQMIN,RIQMAX,RIQ REAL::SFAV,SFAB,ABTMP,AVTMP INTEGER::K,L,LS,ISTL_ - INTEGER::LF,LL,ithds C SMTOP2 = 7.8464 C SMBOT1 = 34.6764 C SMBOT2 = 6.1272 @@ -32,21 +31,14 @@ C RIQMIN=-0.023 RIQMAX=0.28 IF(IDRYTBP.NE.0)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - DO K=1,KC - DO L=LF,LL + DO K=1,KC + DO L=1,LC IF(IMASKDRY(L).EQ.1)THEN AV(L,K)=AVO*HPI(L) AB(L,K)=ABO*HPI(L) ENDIF ENDDO ENDDO -c - enddo ENDIF IF(ISFAVB.EQ.0)THEN DO K=1,KS @@ -83,14 +75,8 @@ C ENDIF IF(ISFAVB.EQ.1)THEN IF(IDRYTBP.EQ.0)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL,RIQ,SFAV,SFAB,ABTMP,AVTMP) -!$OMP& REDUCTION(max:AVMAX,ABMAX) REDUCTION(min:AVMIN,ABMIN) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO K=1,KS - DO L=LF,LL + DO K=1,KS + DO L=2,LA QQI(L)=1./QQ(L,K) QQI(L)=MIN(QQI(L),QQIMAX) RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K) @@ -115,24 +101,15 @@ C ENDDO ENDDO c - enddo - ELSE - -!$OMP PARALLEL DO PRIVATE(LF,LL,RIQ,SFAV,SFAB,ABTMP,AVTMP) -!$OMP& REDUCTION(max:AVMAX,ABMAX) REDUCTION(min:AVMIN,ABMIN) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO K=1,KS - DO L=LF,LL + DO K=1,KS + DO L=2,LA IF(LMASKDRY(L))THEN QQI(L)=1./QQ(L,K) QQI(L)=MIN(QQI(L),QQIMAX) ENDIF -c ENDDO -c DO L=LF,LL + ENDDO + DO L=2,LA IF(LMASKDRY(L))THEN RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K) & *(B(L,K+1)-B(L,K))*QQI(L) @@ -156,10 +133,8 @@ C ENDIF ENDDO ENDDO -c - enddo - ENDIF - ENDIF + ENDIF + ENDIF IF(ISFAVB.EQ.2)THEN DO K=1,KS DO L=2,LA @@ -195,45 +170,31 @@ C ENDIF ! *** NOW APPLY MAXIMUM, IF REQURIED IF(ISAVBMX.GE.1)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL,ABTMP,AVTMP) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KS - DO L=LF,LL + DO L=2,LA AVTMP=AVMX*HPI(L) ABTMP=ABMX*HPI(L) AV(L,K)=MIN(AV(L,K),AVTMP) AB(L,K)=MIN(AB(L,K),ABTMP) ENDDO ENDDO -c - enddo ENDIF -!$OMP PARALLEL DO PRIVATE(LF,LL,LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KS - DO L=LF,LL + DO L=2,LA LS=LSC(L) AVUI(L,K)=2./(AV(L,K)+AV(L-1,K)) AVVI(L,K)=2./(AV(L,K)+AV(LS,K)) ENDDO ENDDO DO K=2,KS - DO L=LF,LL + DO L=2,LA AQ(L,K)=0.205*(AV(L,K-1)+AV(L,K)) ENDDO ENDDO - DO L=LF,LL + DO L=2,LA AQ(L,1)=0.205*AV(L,1) AQ(L,KC)=0.205*AV(L,KS) ENDDO -c - enddo RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVBOLD_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVBOLD_mpi.for new file mode 100644 index 000000000..9386ae2bd --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVBOLD_mpi.for @@ -0,0 +1,233 @@ + SUBROUTINE CALAVBOLD_mpi (ISTL_) +C +C *** OLD STANDARD +C +C ** SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY +C ** USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL +C ** (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H) +C ** IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES +C CHANGE RECORD +C ADDED DRYCELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES +C + USE GLOBAL + USE MPI + IMPLICIT NONE + REAL::QQIMAX,RIQMIN,RIQMAX,RIQ + REAL::SFAV,SFAB,ABTMP,AVTMP + INTEGER::K,L,LS,ISTL_ +C SMTOP2 = 7.8464 +C SMBOT1 = 34.6764 +C SMBOT2 = 6.1272 +C RLIMIT = 0.0233 +C SHMIN = 0.0934 +C SMMIN = 0.1099 +C SHMAX = 5.2073 +C SMMAX = 4.9639 +C + QQIMAX=1./QQMIN + AVMAX=AVO + ABMAX=ABO + AVMIN=10. + ABMIN=10. + RIQMIN=-0.023 + RIQMAX=0.28 + + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + IF(IMASKDRY(L).EQ.1)THEN + AV(L,K)=AVO*HPI(L) + AB(L,K)=ABO*HPI(L) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(801)=MPI_WTIMES(801)+MPI_TOC(S1TIME) + + IF(ISFAVB.EQ.0)THEN + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQI(L)=1./QQ(L,K) + QQI(L)=MIN(QQI(L),QQIMAX) + ENDIF + ENDDO +!$OMP PARALLEL DO PRIVATE(RIQ,SFAV,SFAB,AVMAX,ABMAX,AVMIN,ABMIN) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K) + & *(B(L,K+1)-B(L,K))*QQI(L) + RIQ=MAX(RIQ,RIQMIN) + RIQ=MIN(RIQ,RIQMAX) +C +C SFAV=0.4*(1.+8.*RIQ)/((1.+36.*RIQ)*(1.+6.*RIQ)) +C SFAB=0.5/(1.+36.*RIQ) +C + SFAV=0.3933*(1.+7.8464*RIQ)/((1.+34.6764*RIQ)*(1.+ + & 6.1272*RIQ)) + SFAB=0.4939/(1.+34.6764*RIQ) + AB(L,K)=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO + AV(L,K)=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO + AVMAX=MAX(AVMAX,AV(L,K)) + ABMAX=MAX(ABMAX,AB(L,K)) + AVMIN=MIN(AVMIN,AV(L,K)) + ABMIN=MIN(ABMIN,AB(L,K)) + AV(L,K)=AV(L,K)*HPI(L) + AB(L,K)=SCB(L)*AB(L,K)*HPI(L) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(802)=MPI_WTIMES(802)+MPI_TOC(S1TIME) + ENDIF + + IF(ISFAVB.EQ.1)THEN + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQI(L)=1./QQ(L,K) + QQI(L)=MIN(QQI(L),QQIMAX) + ENDIF + ENDDO +!$OMP PARALLEL DO PRIVATE(RIQ,SFAV,SFAB,ABTMP,AVTMP,AVMAX,ABMAX,AVMIN, +!$OMP+ ABMIN) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K) + & *(B(L,K+1)-B(L,K))*QQI(L) + RIQ=MAX(RIQ,RIQMIN) + RIQ=MIN(RIQ,RIQMAX) +C +C SFAV=0.4*(1.+8.*RIQ)/((1.+36.*RIQ)*(1.+6.*RIQ)) +C SFAB=0.5/(1.+36.*RIQ) +C + SFAV=0.3933*(1.+7.8464*RIQ)/((1.+34.6764*RIQ)*(1.+ + & 6.1272*RIQ)) + SFAB=0.4939/(1.+34.6764*RIQ) + ABTMP=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO + AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO + AVMAX=MAX(AVMAX,AVTMP) + ABMAX=MAX(ABMAX,ABTMP) + AVMIN=MIN(AVMIN,AVTMP) + ABMIN=MIN(ABMIN,ABTMP) + AV(L,K)=0.5*(AV(L,K)+AVTMP*HPI(L)) + AB(L,K)=SCB(L)*0.5*(AB(L,K)+ABTMP*HPI(L)) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(803)=MPI_WTIMES(803)+MPI_TOC(S1TIME) + ENDIF + IF(ISFAVB.EQ.2)THEN + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQI(L)=1./QQ(L,K) + QQI(L)=MIN(QQI(L),QQIMAX) + ENDIF + ENDDO +!$OMP PARALLEL DO PRIVATE(RIQ,SFAV,SFAB,ABTMP,AVTMP, +!$OMP+ AVMAX,ABMAX,AVMIN,ABMIN) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K) + & *(B(L,K+1)-B(L,K))*QQI(L) + RIQ=MAX(RIQ,RIQMIN) + RIQ=MIN(RIQ,RIQMAX) +C +C SFAV=0.4*(1.+8.*RIQ)/((1.+36.*RIQ)*(1.+6.*RIQ)) +C SFAB=0.5/(1.+36.*RIQ) +C + SFAV=0.3933*(1.+7.8464*RIQ)/((1.+34.6764*RIQ)*(1.+ + & 6.1272*RIQ)) + SFAB=0.4939/(1.+34.6764*RIQ) + ABTMP=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO + AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO + AVMAX=MAX(AVMAX,AVTMP) + ABMAX=MAX(ABMAX,ABTMP) + AVMIN=MIN(AVMIN,AVTMP) + ABMIN=MIN(ABMIN,ABTMP) + AV(L,K)=SQRT(AV(L,K)*AVTMP*HPI(L)) + AB(L,K)=SCB(L)*SQRT(AB(L,K)*ABTMP*HPI(L)) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(804)=MPI_WTIMES(804)+MPI_TOC(S1TIME) + ENDIF + S1TIME=MPI_TIC() + IF(ISAVBMX.GE.1)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(AVTMP,ABTMP) + DO L=LMPI2,LMPILA + AVTMP=AVMX*HPI(L) + ABTMP=ABMX*HPI(L) + AV(L,K)=MIN(AV(L,K),AVTMP) + AB(L,K)=MIN(AB(L,K),ABTMP) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(805)=MPI_WTIMES(805)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(AV,ic) + CALL broadcast_boundary_array(AB,ic) + MPI_WTIMES(809)=MPI_WTIMES(809)+MPI_TOC(S1TIME) + + if(PRINT_SUM)then + call collect_in_zero_array(B ) + call collect_in_zero_array(QQSQR ) + call collect_in_zero_array(AV ) + call collect_in_zero_array(AB ) + IF(MYRANK.EQ.0) PRINT*, 'B = ', sum(abs(dble(B))) + IF(MYRANK.EQ.0) PRINT*, 'QQSQR = ', sum(abs(dble(QQSQR))) + IF(MYRANK.EQ.0) PRINT*, 'AV = ', sum(abs(dble(AV))) + IF(MYRANK.EQ.0) PRINT*, 'AB = ', sum(abs(dble(AB))) + endif + + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + AVUI(L,K)=2./(AV(L,K)+AV(L-1,K)) + AVVI(L,K)=2./(AV(L,K)+AV(LS,K)) + ENDDO + ENDDO + MPI_WTIMES(806)=MPI_WTIMES(806)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + DO K=2,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AQ(L,K)=0.205*(AV(L,K-1)+AV(L,K)) + ENDDO + ENDDO + MPI_WTIMES(807)=MPI_WTIMES(807)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AQ(L,1)=0.205*AV(L,1) + AQ(L,KC)=0.205*AV(L,KS) + ENDDO + MPI_WTIMES(808)=MPI_WTIMES(808)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(AQ,ic) + CALL broadcast_boundary_array(AVUI,ic) + CALL broadcast_boundary_array(AVVI,ic) + MPI_WTIMES(810)=MPI_WTIMES(810)+MPI_TOC(S1TIME) + + + if(PRINT_SUM)then + call collect_in_zero_array(AVUI ) + call collect_in_zero_array(AVVI ) + IF(MYRANK.EQ.0) PRINT*, 'avb_AVUI = ', sum(abs(dble(AVUI))) + IF(MYRANK.EQ.0) PRINT*, 'avb_AVVI = ', sum(abs(dble(AVVI))) + endif + + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB_mpi.for new file mode 100644 index 000000000..46ea31b10 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALAVB_mpi.for @@ -0,0 +1,225 @@ + SUBROUTINE CALAVB_mpi (ISTL_) +C +C ** SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY +C ** USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL +C ** (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H) +C ** IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES +C CHANGE RECORD +C ADDED DRYCELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES +C + USE GLOBAL + USE MPI + IMPLICIT NONE + INTEGER::L,K,LS,ISTL_ + REAL::QQIMAX,RIQMIN,RIQMAX,RIQ,SFAV,SFAB,ABTMP,AVTMP +C +C SHTOP = 0.4939 +C SHBOT = 34.6764 +C SMTOP1 = 0.3933 +C SMTOP2 = 7.8464 +C SMBOT1 = 34.6764 +C SMBOT2 = 6.1272 +C RLIMIT = 0.0233 +C SHMIN = 0.0934 +C SMMIN = 0.1099 +C SHMAX = 5.2073 +C SMMAX = 4.9639 +C + QQIMAX=1./QQMIN + AVMAX=AVO + ABMAX=ABO + AVMIN=10. + ABMIN=10. + RIQMIN=-0.023 + RIQMAX=0.28 + + S1TIME=MPI_TIC() +C DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + IF(IMASKDRY(L).EQ.1)THEN + AV(L,1:KC)=AVO*HPI(L) + AB(L,1:KC)=ABO*HPI(L) + ENDIF + ENDDO +C ENDDO + MPI_WTIMES(801)=MPI_WTIMES(801)+MPI_TOC(S1TIME) + + IF(ISFAVB.EQ.0)THEN + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQI(L)=1./QQ(L,K) + QQI(L)=MIN(QQI(L),QQIMAX) + ENDIF + ENDDO +!$OMP PARALLEL DO PRIVATE(RIQ,SFAV,SFAB,AVMAX,ABMAX,AVMIN,ABMIN) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K) + & *(B(L,K+1)-B(L,K))*QQI(L) + RIQ=MAX(RIQ,RIQMIN) + RIQ=MIN(RIQ,RIQMAX) + SFAV=0.3920*(1.+8.6736*RIQ)/((1.+30.192*RIQ)*(1.+ + & 6.1272*RIQ)) + SFAB=0.4939/(1.+30.192*RIQ) + AB(L,K)=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO + AV(L,K)=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO + AVMAX=MAX(AVMAX,AV(L,K)) + ABMAX=MAX(ABMAX,AB(L,K)) + AVMIN=MIN(AVMIN,AV(L,K)) + ABMIN=MIN(ABMIN,AB(L,K)) + AV(L,K)=AV(L,K)*HPI(L) + AB(L,K)=SCB(L)*AB(L,K)*HPI(L) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(802)=MPI_WTIMES(802)+MPI_TOC(S1TIME) + ENDIF + + IF(ISFAVB.EQ.1)THEN + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQI(L)=1./QQ(L,K) + QQI(L)=MIN(QQI(L),QQIMAX) + ENDIF + ENDDO +!$OMP PARALLEL DO PRIVATE(RIQ,SFAV,SFAB,ABTMP,AVTMP,AVMAX, +!$OMP+ ABMAX,AVMIN,ABMIN) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K) + & *(B(L,K+1)-B(L,K))*QQI(L) + RIQ=MAX(RIQ,RIQMIN) + RIQ=MIN(RIQ,RIQMAX) + SFAV=0.3920*(1.+8.6736*RIQ)/((1.+30.192*RIQ)*(1.+ + & 6.1272*RIQ)) + SFAB=0.4939/(1.+30.192*RIQ) + ABTMP=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO + AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO + AVMAX=MAX(AVMAX,AVTMP) + ABMAX=MAX(ABMAX,ABTMP) + AVMIN=MIN(AVMIN,AVTMP) + ABMIN=MIN(ABMIN,ABTMP) + AV(L,K)=0.5*(AV(L,K)+AVTMP*HPI(L)) + AB(L,K)=SCB(L)*0.5*(AB(L,K)+ABTMP*HPI(L)) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(803)=MPI_WTIMES(803)+MPI_TOC(S1TIME) + ENDIF + IF(ISFAVB.EQ.2)THEN + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQI(L)=1./QQ(L,K) + QQI(L)=MIN(QQI(L),QQIMAX) + ENDIF + ENDDO +!$OMP PARALLEL DO PRIVATE(RIQ,SFAV,SFAB,ABTMP,AVTMP, +!$OMP+ AVMAX,ABMAX,AVMIN,ABMIN) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K) + & *(B(L,K+1)-B(L,K))*QQI(L) + RIQ=MAX(RIQ,RIQMIN) + RIQ=MIN(RIQ,RIQMAX) + SFAV=0.3920*(1.+8.6736*RIQ)/((1.+30.192*RIQ)*(1.+ + & 6.1272*RIQ)) + SFAB=0.4939/(1.+30.192*RIQ) + ABTMP=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO + AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO + AVMAX=MAX(AVMAX,AVTMP) + ABMAX=MAX(ABMAX,ABTMP) + AVMIN=MIN(AVMIN,AVTMP) + ABMIN=MIN(ABMIN,ABTMP) + AV(L,K)=SQRT(AV(L,K)*AVTMP*HPI(L)) + AB(L,K)=SCB(L)*SQRT(AB(L,K)*ABTMP*HPI(L)) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(804)=MPI_WTIMES(804)+MPI_TOC(S1TIME) + ENDIF + S1TIME=MPI_TIC() + IF(ISAVBMX.GE.1)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(AVTMP,ABTMP) + DO L=LMPI2,LMPILA + AVTMP=AVMX*HPI(L) + ABTMP=ABMX*HPI(L) + AV(L,K)=MIN(AV(L,K),AVTMP) + AB(L,K)=MIN(AB(L,K),ABTMP) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(805)=MPI_WTIMES(805)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(AV,ic) + CALL broadcast_boundary_array(AB,ic) + MPI_WTIMES(809)=MPI_WTIMES(809)+MPI_TOC(S1TIME) + + if(PRINT_SUM)then + call collect_in_zero_array(B ) + call collect_in_zero_array(QQSQR ) + call collect_in_zero_array(AV ) + call collect_in_zero_array(AB ) + IF(MYRANK.EQ.0) PRINT*, 'B = ', sum(abs(dble(B))) + IF(MYRANK.EQ.0) PRINT*, 'QQSQR = ', sum(abs(dble(QQSQR))) + IF(MYRANK.EQ.0) PRINT*, 'AV = ', sum(abs(dble(AV))) + IF(MYRANK.EQ.0) PRINT*, 'AB = ', sum(abs(dble(AB))) + endif + + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + AVUI(L,K)=(1.+SUB(L))/(AV(L,K)+SUB(L)*AV(L-1,K)) + AVVI(L,K)=(1.+SVB(L))/(AV(L,K)+SVB(L)*AV(LS,K)) + ENDDO + ENDDO + MPI_WTIMES(806)=MPI_WTIMES(806)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + DO K=2,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AQ(L,K)=0.205*(AV(L,K-1)+AV(L,K)) + ENDDO + ENDDO + MPI_WTIMES(807)=MPI_WTIMES(807)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AQ(L,1)=0.205*AV(L,1) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AQ(L,KC)=0.205*AV(L,KS) + ENDDO + MPI_WTIMES(808)=MPI_WTIMES(808)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(AQ,ic) + CALL broadcast_boundary_array(AVUI,ic) + CALL broadcast_boundary_array(AVVI,ic) + MPI_WTIMES(810)=MPI_WTIMES(810)+MPI_TOC(S1TIME) + + + if(PRINT_SUM)then + call collect_in_zero_array(AVUI ) + call collect_in_zero_array(AVVI ) + IF(MYRANK.EQ.0) PRINT*, 'avb_AVUI = ', sum(abs(dble(AVUI))) + IF(MYRANK.EQ.0) PRINT*, 'avb_AVVI = ', sum(abs(dble(AVVI))) + endif + + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBAL5.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBAL5.for index 39d8e09c0..bdd3bee41 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBAL5.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBAL5.for @@ -5,6 +5,7 @@ C ** SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM, C ** AND ENERGY BALANCES C USE GLOBAL + USE MPI IMPLICIT NONE REAL::ENEEND,ENEOUT,VOLBMO,SALBMO,DYEBMO,UMOBMO,VMOBMO,ENEBMO REAL::VOLERR,SALERR,DYEERR,UMOERR,VMOERR,ENEERR,RVERDE,RSERDE @@ -105,6 +106,7 @@ C C C ** OUTPUT BALANCE RESULTS TO FILE BAL.OUT C + IF(MYRANK.EQ.0)THEN IF(JSBAL.EQ.1)THEN OPEN(89,FILE='BAL.OUT',STATUS='UNKNOWN') CLOSE(89,STATUS='DELETE') @@ -161,6 +163,7 @@ C WRITE(89,900) WRITE(89,899) CLOSE(89) + ENDIF 890 FORMAT (' VOLUME, MASS, AND ENERGY BALANCE OVER',I5,' TIME STEPS' & ,' ENDING AT TIME STEP',I5,//) 891 FORMAT (' INITIAL VOLUME INITIAL SALT INITIAL DYE ' diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBED9.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBED9.for index 8155be236..b21d5f694 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBED9.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBED9.for @@ -9,7 +9,7 @@ C IMPLICIT NONE INTEGER::K,L,IFLAG,KK,NSB,LUTMP,NS,NX,KBTM1 REAL::TMPVAL,WDENKGM3,WDENGMM3,TMPVALK,TMPVALKP - REAL::BETTMP,VOIDCON1,HDEBTMP,TMPVALO,TMPVALN,TMPEXP,TMPTOP + REAL::BETTMP,VOIDCON1,TMPVALO,TMPVALN,TMPEXP,TMPTOP REAL::TMPBOT,FSTRSE,FDSTRSE,FHYDCN,DSTRESET,HBEDTMP REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::SNDHYDCN IF(.NOT.ALLOCATED(SNDHYDCN))THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBLAY.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBLAY.for index 03e5646a8..c30609ea6 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBLAY.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBLAY.for @@ -9,6 +9,7 @@ C INTEGER::K,NS,L,NT,NX REAL::TMPBOT2,TMPTOP1,TMPTOP2,TMPVAL,HBEDMXT,HOLDTOP,FKBTP REAL::SEDBOLD,TOXBOLD,TMPBOT1,FKBT,SNDBOLD + NS=0 C C FOR TRANSPORT OF COHESIVE SEDIMENT ONLY SET HBEDMIN TO FRACTION C OF HBEDMAX diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBUOY.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBUOY.for index 347e68f63..9a778579f 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBUOY.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBUOY.for @@ -1,4 +1,4 @@ - SUBROUTINE CALBUOY(LF,LL) + SUBROUTINE CALBUOY C C CHANGE RECORD C ** CALBUOY CALCULATES THE BUOYANCY USING MELLOR'S APPROXIMATION @@ -9,7 +9,6 @@ C IMPLICIT NONE INTEGER::NS,K,L REAL::RHOO,SSTMP,TTMP,RHTMP,PRES,CCON,TMP,TEM0 - INTEGER::LF,LL,ithds C IF(IBSC.EQ.1) GOTO 1000 ISPCOR=0 @@ -22,14 +21,14 @@ C & +6.536332E-9*TEM0*TEM0*TEM0*TEM0*TEM0 IF(ISTRAN(1).EQ.0.AND.ISTRAN(2).EQ.0)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA B(L,K)=RHOO ENDDO ENDDO ENDIF IF(ISTRAN(1).GE.1.AND.ISTRAN(2).EQ.0)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA SAL(L,K)=MAX(SAL(L,K),0.) SSTMP=SAL(L,K) TEM0=ABS(TEMO) @@ -42,7 +41,7 @@ C ENDIF IF(ISTRAN(1).EQ.0.AND.ISTRAN(2).GE.1)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA TTMP=TEM(L,K) B(L,K)=999.842594+6.793952E-2*TTMP-9.095290E-3*TTMP*TTMP & +1.001685E-4*TTMP*TTMP*TTMP-1.120083E-6*TTMP*TTMP* @@ -52,7 +51,7 @@ C ENDIF IF(ISTRAN(1).GE.1.AND.ISTRAN(2).GE.1)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA SAL(L,K)=MAX(SAL(L,K),0.) SSTMP=SAL(L,K) TTMP=TEM(L,K) @@ -71,7 +70,7 @@ C ** APPLY MELLOR'S PRESSURE CORRECTION C IF(ISPCOR.EQ.1)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA PRES=RHOO*G*HP(L)*(1.-ZZ(K))*1.E-6 CCON=1449.2+1.34*(SAL(L,K)-35.)+4.55*TEM(L,K) & -0.045*TEM(L,K)*TEM(L,K)+0.00821*PRES+15.E-9*PRES*PRES @@ -84,7 +83,7 @@ C C ** REPLACE DENSITY B(L,K) WITH BUOYANCY B(L,K) C DO K=1,KC - DO L=LF,LL + DO L=2,LA B(L,K)=(B(L,K)/RHOO)-1. ENDDO ENDDO @@ -93,7 +92,7 @@ C ** APPLY LOW SEDIMENT CONCENTRATION CORRECTION TO BUOYANCY C IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA TVAR1S(L,K)=0. TVAR1W(L,K)=0. ENDDO @@ -102,7 +101,7 @@ C IF(ISTRAN(6).GE.1)THEN DO NS=1,NSED DO K=1,KC - DO L=LF,LL + DO L=2,LA TVAR1S(L,K)=TVAR1S(L,K)+SDEN(NS)*SED(L,K,NS) TVAR1W(L,K)=TVAR1W(L,K)+(SSG(NS)-1.)*SDEN(NS)*SED(L,K,NS) ENDDO @@ -113,7 +112,7 @@ C DO NN=1,NSND NS=NN+NSED DO K=1,KC - DO L=LF,LL + DO L=2,LA TVAR1S(L,K)=TVAR1S(L,K)+SDEN(NS)*SND(L,K,NN) TVAR1W(L,K)=TVAR1W(L,K)+(SSG(NS)-1.)*SDEN(NS)*SND(L,K,NN) ENDDO @@ -122,7 +121,7 @@ C ENDIF IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA B(L,K)=B(L,K)*(1.-TVAR1S(L,K))+TVAR1W(L,K) ENDDO ENDDO @@ -134,7 +133,7 @@ C PURPOSES ONLY C 1000 CONTINUE DO K=1,KC - DO L=LF,LL + DO L=2,LA B(L,K)=0.00075*SAL(L,K) ENDDO ENDDO diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBUOY_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBUOY_mpi.for new file mode 100644 index 000000000..a045c1629 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALBUOY_mpi.for @@ -0,0 +1,202 @@ + SUBROUTINE CALBUOY_mpi +C +C CHANGE RECORD +C ** CALBUOY CALCULATES THE BUOYANCY USING MELLOR'S APPROXIMATION +C ** TO THE UNESCO EQUATION OF STATE (MELLOR, G.L., J. ATM AND OCEAN +C ** TECH, VOL 8, P 609) +C + USE GLOBAL + USE MPI + IMPLICIT NONE + INTEGER::NS,K,L + REAL::RHOO,SSTMP,TTMP,RHTMP,PRES,CCON,TMP,TEM0 +C + IF(IBSC.EQ.1) GOTO 1000 + ISPCOR=0 +C +C ** DENSITY RHOO AT P=0, S=0, AND T=TEMO +C + TEM0 = ABS(TEMO) + RHOO=999.842594+6.793952E-2*TEM0-9.095290E-3*TEM0*TEM0 + & +1.001685E-4*TEM0*TEM0*TEM0-1.120083E-6*TEM0*TEM0*TEM0*TEM0 + & +6.536332E-9*TEM0*TEM0*TEM0*TEM0*TEM0 + + S1TIME=MPI_TIC() + IF(ISTRAN(1).EQ.0.AND.ISTRAN(2).EQ.0)THEN + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + B(L,K)=RHOO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(821)=MPI_WTIMES(821)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(1).GE.1.AND.ISTRAN(2).EQ.0)THEN + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(SSTMP,TEM0) + DO L=LMPI2,LMPILA + SAL(L,K)=MAX(SAL(L,K),0.) + SSTMP=SAL(L,K) + TEM0=ABS(TEMO) + B(L,K)=RHOO+SSTMP*(0.824493-4.0899E-3*TEM0+7.6438E-5*TEM0*TEM0 + & -8.2467E-7*TEM0*TEM0*TEM0+5.3875E-9*TEM0*TEM0*TEM0*TEM0) + & +SQRT(SSTMP)*SSTMP*(-5.72466E-3+1.0227E-4*TEM0 + & -1.6546E-6*TEM0*TEM0)+4.8314E-4*SSTMP*SSTMP + ENDDO + ENDDO + ENDIF + MPI_WTIMES(822)=MPI_WTIMES(822)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(B) + IF(MYRANK.EQ.0)PRINT*, n,'BU1 = ', sum(abs(dble(B))) + ENDIF + S1TIME=MPI_TIC() + IF(ISTRAN(1).EQ.0.AND.ISTRAN(2).GE.1)THEN + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(TTMP) + DO L=LMPI2,LMPILA + TTMP=TEM(L,K) + B(L,K)=999.842594+6.793952E-2*TTMP-9.095290E-3*TTMP*TTMP + & +1.001685E-4*TTMP*TTMP*TTMP-1.120083E-6*TTMP*TTMP* + & TTMP*TTMP+6.536332E-9*TTMP*TTMP*TTMP*TTMP*TTMP + ENDDO + ENDDO + ENDIF + MPI_WTIMES(823)=MPI_WTIMES(823)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(B) + IF(MYRANK.EQ.0)PRINT*, n,'BU2 = ', sum(abs(dble(B))) + ENDIF + S1TIME=MPI_TIC() + IF(ISTRAN(1).GE.1.AND.ISTRAN(2).GE.1)THEN + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(SSTMP,TTMP,RHTMP) + DO L=LMPI2,LMPILA + SAL(L,K)=MAX(SAL(L,K),0.) + SSTMP=SAL(L,K) + TTMP=TEM(L,K) + RHTMP=999.842594+6.793952E-2*TTMP-9.095290E-3*TTMP*TTMP + & +1.001685E-4*TTMP*TTMP*TTMP-1.120083E-6*TTMP*TTMP* + & TTMP*TTMP+6.536332E-9*TTMP*TTMP*TTMP*TTMP*TTMP + B(L,K)=RHTMP+SSTMP*(0.824493-4.0899E-3*TTMP+7.6438E-5* + & TTMP*TTMP-8.2467E-7*TTMP*TTMP*TTMP+5.3875E-9*TTMP*TTMP*TTMP*TTMP) + & +SQRT(SSTMP)*SSTMP*(-5.72466E-3+1.0227E-4*TTMP + & -1.6546E-6*TTMP*TTMP)+4.8314E-4*SSTMP*SSTMP + ENDDO + ENDDO + ENDIF + MPI_WTIMES(824)=MPI_WTIMES(824)+MPI_TOC(S1TIME) +C +C ** APPLY MELLOR'S PRESSURE CORRECTION +C + S1TIME=MPI_TIC() + IF(ISPCOR.EQ.1)THEN + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(PRES,CCON,TMP) + DO L=LMPI2,LMPILA + PRES=RHOO*G*HP(L)*(1.-ZZ(K))*1.E-6 + CCON=1449.2+1.34*(SAL(L,K)-35.)+4.55*TEM(L,K) + & -0.045*TEM(L,K)*TEM(L,K)+0.00821*PRES+15.E-9*PRES*PRES + TMP=PRES/(CCON*CCON) + B(L,K)=B(L,K)+1.E+4*TMP*(1.-0.2*TMP) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(825)=MPI_WTIMES(825)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(B) + IF(MYRANK.EQ.0)PRINT*, n,'BU3 = ', sum(abs(dble(B))) + ENDIF +C +C ** REPLACE DENSITY B(L,K) WITH BUOYANCY B(L,K) +C + IF(PRINT_SUM)THEN + call collect_in_zero_array(B) + IF(MYRANK.EQ.0)PRINT*, n,'BU41 = ', sum(abs(dble(B))),RHOO + ENDIF + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + B(L,K)=(B(L,K)/RHOO)-1. + ENDDO + ENDDO + MPI_WTIMES(826)=MPI_WTIMES(826)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(B) + IF(MYRANK.EQ.0)PRINT*, n,'BU42 = ', sum(abs(dble(B))),RHOO + ENDIF +C +C ** APPLY LOW SEDIMENT CONCENTRATION CORRECTION TO BUOYANCY +C + S1TIME=MPI_TIC() + IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR1S(L,K)=0. + TVAR1W(L,K)=0. + ENDDO + ENDDO + ENDIF + MPI_WTIMES(827)=MPI_WTIMES(827)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(6).GE.1)THEN + DO NS=1,NSED + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR1S(L,K)=TVAR1S(L,K)+SDEN(NS)*SED(L,K,NS) + TVAR1W(L,K)=TVAR1W(L,K)+(SSG(NS)-1.)*SDEN(NS)*SED(L,K,NS) + ENDDO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(828)=MPI_WTIMES(828)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(7).GE.1)THEN + DO NN=1,NSND + NS=NN+NSED + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR1S(L,K)=TVAR1S(L,K)+SDEN(NS)*SND(L,K,NN) + TVAR1W(L,K)=TVAR1W(L,K)+(SSG(NS)-1.)*SDEN(NS)*SND(L,K,NN) + ENDDO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(829)=MPI_WTIMES(829)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + B(L,K)=B(L,K)*(1.-TVAR1S(L,K))+TVAR1W(L,K) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(830)=MPI_WTIMES(830)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(B) + IF(MYRANK.EQ.0)PRINT*, n,'BU5 = ', sum(abs(dble(B))) + ENDIF + GOTO 2000 +C +C DENSITY AS A LINEAR FUNCTION OF SALINITY ONLY. FOR DIAGNOSTIC +C PURPOSES ONLY +C + 1000 CONTINUE + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + B(L,K)=0.00075*SAL(L,K) + ENDDO + ENDDO + MPI_WTIMES(831)=MPI_WTIMES(831)+MPI_TOC(S1TIME) + 2000 CONTINUE + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCONC.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCONC.for index 3925fd204..c16e39a85 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCONC.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCONC.for @@ -14,10 +14,8 @@ C INTEGER::K,L,NT,NS,ND,NSID,LDATA,NLC,IWASM,NDAYA,NX INTEGER::IBALSTDT,NTMP,ISTL_,IS2TL_,M,LF,LL REAL::TTMP,RCDZKMK,CONASMOLD,SALASM, T1TMP,T2TMP - REAL::SECNDS REAL::TEMASM,DYEASM,SFLASM,RCDZKK,CCUBTMP,CCMBTMP REAL::DELTD2,CDYETMP,TMP,DAGE - INTEGER::LF_LC,LL_LC,ithds REAL,SAVE,ALLOCATABLE,DIMENSION(:)::EEB REAL,SAVE,ALLOCATABLE,DIMENSION(:)::CCLBTMP @@ -56,7 +54,7 @@ C C C ** VERTICAL DIFFUSION EXPLICIT HALF STEP CALCULATION C - 500 CONTINUE +C 500 CONTINUE C C ** 3D ADVECTI0N TRANSPORT CALCULATION-COSMIC INITIALIZATION C @@ -146,49 +144,8 @@ C ** 3D ADVECTI0N TRANSPORT CALCULATION C C ** PRESPECIFY THE UPWIND CELLS FOR 3D ADVECTION C -c t00=rtc() - IF(IDRYTBP.EQ.0)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL - IF(UHDY2(L,K).GE.0.0)THEN - LUPU(L,K)=L-1 - ELSE - LUPU(L,K)=L - END IF - IF(VHDX2(L,K).GE.0.0)THEN - LUPV(L,K)=LSC(L) - ELSE - LUPV(L,K)=L - END IF - ENDDO - ENDDO - IF(KC.GT.1)THEN - DO K=1,KS - DO L=LF,LL - IF(W2(L,K).GE.0.)THEN - KUPW(L,K)=K - ELSE - KUPW(L,K)=K+1 ! *** DSLLC SINGLE LINE CHANGE, CHANGED K-1 TO K+1 - END IF - ENDDO - ENDDO - ENDIF -c - enddo - - ELSE -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN IF(UHDY2(L,K).GE.0.0)THEN LUPU(L,K)=L-1 @@ -205,7 +162,7 @@ c ENDDO IF(KC.GT.1)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN IF(W2(L,K).GE.0.)THEN KUPW(L,K)=K @@ -216,13 +173,7 @@ c ENDDO ENDDO ENDIF -c - enddo - ENDIF -c t00=rtc()-t00 -c write(6,*) '==>001 ',t00*1d3 - - TTMP=SECNDS(0.0) + CALL CPU_TIME(TTMP) C IF(ISTRAN(1).EQ.1.AND.ISCDCA(1).LT.4) & CALL CALTRAN (ISTL_,IS2TL_,1,1,SAL,SAL1) @@ -292,7 +243,6 @@ C ENDDO ENDIF CALL CPU_TIME(T2TMP) - TSADV=TSADV+T2TMP-TTMP C C ** 3D COSMIC ADVECTI0N TRANSPORT CALCULATION @@ -426,7 +376,7 @@ C ENDDO ENDIF CALL CPU_TIME(T2TMP) - TSADV=TSADV+T2TMP-T1TMP + TSADV=TSADV+T2TMP-T1TMP ENDIF C C ** 1D ADVECTI0N TRANSPORT CALCULATION @@ -500,11 +450,11 @@ C CALL SSEDTOX(ISTL,IS2TL,1.0) IBALSTDT=1 ENDIF -C TVDIF=TVDIF+SECNDS(TTMP) +C TVDIF=TVDIF+TTMP-SECOND() ENDIF C - 888 FORMAT('N,IC,I,DTS,DT = ',3I5,2F12.8) - 889 FORMAT('N,IC,I,DTS = ',3I5,F12.8,12X,'SSEDTOX CALLED') +C 888 FORMAT('N,IC,I,DTS,DT = ',3I5,2F12.8) +C 889 FORMAT('N,IC,I,DTS = ',3I5,F12.8,12X,'SSEDTOX CALLED') C C ** OPTIONAL MASS BALANCE CALCULATION C @@ -555,13 +505,10 @@ C ** VERTICAL DIFFUSION IMPLICIT HALF STEP CALCULATION C IF(KC.EQ.1) GOTO 1500 CALL CPU_TIME(T1TMP) -!$OMP PARALLEL DO PRIVATE(LF,LL,LF_LC,LL_LC,K, -!$OMP& RCDZKMK,RCDZKK,CCUBTMP,CCMBTMP) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c RCDZKK=-DELTD2*CDZKK(1) + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 DO L=LF,LL CCUBTMP=RCDZKK*HPI(L)*AB(L,1) CCMBTMP=1.-CCUBTMP @@ -604,7 +551,10 @@ c ENDDO ENDDO ENDIF -c + ENDDO + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 DO K=2,KS RCDZKMK=-DELTD2*CDZKMK(K) RCDZKK=-DELTD2*CDZKK(K) @@ -652,10 +602,12 @@ c ENDDO ENDIF ENDDO -C + ENDDO K=KC RCDZKMK=-DELTD2*CDZKMK(K) -c + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 DO L=LF,LL CCLBTMP(L)=RCDZKMK*HPI(L)*AB(L,K-1) CCMBTMP=1.-CCLBTMP(L) @@ -697,7 +649,10 @@ c ENDDO ENDDO ENDIF -c + ENDDO + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 DO K=KC-1,1,-1 IF(ISTRAN(1).GE.1)THEN DO L=LF,LL @@ -736,52 +691,47 @@ c ENDDO ENDIF ENDDO - LF_LC=jse_LC(1,ithds) - LL_LC=jse_LC(2,ithds) -c + ENDDO DO K=1,KB - DO L=LF_LC,LL_LC + DO L=1,LC SEDBT(L,K)=0. SNDBT(L,K)=0. ENDDO ENDDO - DO NS=1,NSED + DO K=1,KC + DO L=1,LC + SEDT(L,K)=0. + SNDT(L,K)=0. + ENDDO + ENDDO DO K=1,KB - DO L=LF_LC,LL_LC + DO NS=1,NSED + DO L=1,LC SEDBT(L,K)=SEDBT(L,K)+SEDB(L,K,NS) ENDDO ENDDO ENDDO DO NS=1,NSND DO K=1,KB - DO L=LF_LC,LL_LC + DO L=1,LC SNDBT(L,K)=SNDBT(L,K)+SNDB(L,K,NS) ENDDO ENDDO ENDDO -C - DO K=1,KC - DO L=LF_LC,LL_LC - SEDT(L,K)=0. - SNDT(L,K)=0. - ENDDO - ENDDO DO NS=1,NSED DO K=1,KC - DO L=LF_LC,LL_LC + DO L=1,LC SEDT(L,K)=SEDT(L,K)+SED(L,K,NS) ENDDO ENDDO ENDDO DO NS=1,NSND DO K=1,KC - DO L=LF_LC,LL_LC + DO L=1,LC SNDT(L,K)=SNDT(L,K)+SND(L,K,NS) ENDDO ENDDO ENDDO -c - enddo CALL CPU_TIME(T2TMP) TVDIF=TVDIF+T2TMP-T1TMP 1500 CONTINUE @@ -987,7 +937,7 @@ C ENDDO ENDIF C - 6222 FORMAT(' TC,SNEW,SASSM,SOLD=',4F10.2) +C6222 FORMAT(' TC,SNEW,SASSM,SOLD='4F10.2) C IF(ISCDA(7).GT.0)THEN DO NX=1,NSND diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCONC_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCONC_mpi.for new file mode 100644 index 000000000..4fc32fae5 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCONC_mpi.for @@ -0,0 +1,1160 @@ + SUBROUTINE CALCONC_mpi(ISTL_,IS2TL_) +C +C CHANGE RECORD +C MODIFIED CALLS TO CALBAL AND BUDGET SUBROUTINES +C ADDED CALLS TO BAL2T2, BAL2T3 +C ** SUBROUTINE CALCULATES THE CONCENTRATION OF DISSOLVED AND +C ** SUSPENDED CONSTITUTENTS, INCLUDING SALINITY, TEMPERATURE, DYE AND +C ** AND SUSPENDED SEDIMENT AT TIME LEVEL (N+1). THE VALUE OF ISTL +C ** INDICATES THE NUMBER OF TIME LEVELS IN THE STEP +C + USE GLOBAL + USE MPI + + IMPLICIT NONE + INTEGER::K,L,NT,NS,ND,NSID,LDATA,NLC,IWASM,NDAYA,NX + INTEGER::IBALSTDT,NTMP,ISTL_,IS2TL_,M,LF,LL + REAL::TTMP,T1TMP,RCDZKMK,CONASMOLD,SALASM + REAL::TEMASM,DYEASM,SFLASM,RCDZKK,CCUBTMP,CCMBTMP + REAL::DELTD2,CDYETMP,TMP,DAGE + + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::EEB + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::CCLBTMP + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::EEB_2D,CCLBTMP_2D + + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TOXASM + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SEDASM + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SNDASM + + IF(.NOT.ALLOCATED(EEB))THEN + ALLOCATE(EEB(LCM)) + ALLOCATE(CCLBTMP(LCM)) + ALLOCATE(EEB_2D(LCM,KCM)) + ALLOCATE(CCLBTMP_2D(LCM,KCM)) + ALLOCATE(TOXASM(NTXM)) + ALLOCATE(SEDASM(NSCM)) + ALLOCATE(SNDASM(NSNM)) + EEB=0.0 + CCLBTMP=0.0 + EEB_2D=0.0 + CCLBTMP_2D=0.0 + TOXASM=0.0 + SEDASM=0.0 + SNDASM=0.0 + ENDIF + + DELT=DT2 + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + ELSE + DELT=DTDYN + END IF + ENDIF + DELTD2=DELT + S1TIME=MPI_TIC() + IF(IS2TIM.GE.1) THEN + IF(ISBAL.GE.1)THEN + CALL BAL2T3A + ENDIF + ENDIF + MPI_WTIMES(601)=MPI_WTIMES(601)+MPI_TOC(S1TIME) +C +C ** VERTICAL DIFFUSION EXPLICIT HALF STEP CALCULATION +C +C 500 CONTINUE +C +C ** 3D ADVECTI0N TRANSPORT CALCULATION-COSMIC INITIALIZATION +C + IF(ISCOSMIC.EQ.1)THEN + S1TIME=MPI_TIC() + DO K=1,KC + RCOSMICX(1 ,K)=0. + RCOSMICX(LC,K)=0. + RCOSMICY(1 ,K)=0. + RCOSMICY(LC,K)=0. + RCOSMICZ(1 ,K)=0. + RCOSMICZ(LC,K)=0. + COSMICXP(1 ,K)=0. + COSMICXP(LC,K)=0. + COSMICYP(1 ,K)=0. + COSMICYP(LC,K)=0. + COSMICZP(1 ,K)=0. + COSMICZP(LC,K)=0. + COSMICXN(1 ,K)=0. + COSMICXN(LC,K)=0. + COSMICYN(1 ,K)=0. + COSMICYN(LC,K)=0. + COSMICZN(1 ,K)=0. + COSMICZN(LC,K)=0. + ENDDO +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + COSMICZP(L,0)=0. + COSMICZP(L,KC)=0. + COSMICZN(L,0)=0. + COSMICZN(L,KC)=0. + ENDDO + MPI_WTIMES(602)=MPI_WTIMES(602)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(TMP) + DO L=LMPI2,LMPILA + RCOSMICX(L,K)=-1. + TMP=U2(L,K)*U2(L+1,K) + IF(TMP.LT.0.) RCOSMICX(L,K)=0. + RCOSMICY(L,K)=-1. + TMP=V2(L,K)*V2(LNC(L),K) + IF(TMP.LT.0.) RCOSMICY(L,K)=0. + RCOSMICZ(L,K)=-1. + TMP=W2(L,K)*W2(L,K-1) + IF(TMP.LT.0.) RCOSMICZ(L,K)=0. + ENDDO + ENDDO + MPI_WTIMES(603)=MPI_WTIMES(603)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + COSMICXP(L,K)=DELT*DXIU(L)*U2(L,K) + COSMICYP(L,K)=DELT*DYIV(L)*V2(L,K) + ENDDO + ENDDO + MPI_WTIMES(604)=MPI_WTIMES(604)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + COSMICXN(L,K)=MIN(COSMICXP(L,K),0.) + COSMICYN(L,K)=MIN(COSMICYP(L,K),0.) + COSMICXP(L,K)=MAX(COSMICXP(L,K),0.) + COSMICYP(L,K)=MAX(COSMICYP(L,K),0.) + ENDDO + ENDDO + MPI_WTIMES(605)=MPI_WTIMES(605)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(KC.GE.2.AND.ISTL_.EQ.3)THEN + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + COSMICZP(L,K)=DELT*DZIG(K)*W2(L,K)/H1P(L) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + COSMICZN(L,K)=MIN(COSMICZP(L,K),0.) + COSMICZP(L,K)=MAX(COSMICZP(L,K),0.) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(606)=MPI_WTIMES(606)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(KC.GE.2.AND.ISTL_.EQ.2)THEN + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + COSMICZP(L,K)=2.*DELT*DZIG(K)*W2(L,K)/(HP(L)+H1P(L)) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + COSMICZN(L,K)=MIN(COSMICZP(L,K),0.) + COSMICZP(L,K)=MAX(COSMICZP(L,K),0.) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(607)=MPI_WTIMES(607)+MPI_TOC(S1TIME) + ENDIF +C +C ** 3D ADVECTI0N TRANSPORT CALCULATION +C +C ** PRESPECIFY THE UPWIND CELLS FOR 3D ADVECTION +C + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + IF(UHDY2(L,K).GE.0.0)THEN + LUPU(L,K)=L-1 + ELSE + LUPU(L,K)=L + END IF + IF(VHDX2(L,K).GE.0.0)THEN + LUPV(L,K)=LSC(L) + ELSE + LUPV(L,K)=L + END IF + END IF + ENDDO + ENDDO + MPI_WTIMES(608)=MPI_WTIMES(608)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(KC.GT.1)THEN + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + IF(W2(L,K).GE.0.)THEN + KUPW(L,K)=K + ELSE + KUPW(L,K)=K+1 ! *** DSLLC SINGLE LINE CHANGE, CHANGED K-1 TO K+1 + END IF + END IF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(609)=MPI_WTIMES(609)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + IF(ISTRAN(1).EQ.1.AND.ISCDCA(1).LT.4) + & CALL CALTRAN_mpi (ISTL_,IS2TL_,1,1,SAL,SAL1) + MPI_WTIMES(610)=MPI_WTIMES(610)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'3TEM = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + S1TIME=MPI_TIC() + IF(ISTRAN(2).EQ.1.AND.ISCDCA(2).LT.4) + & CALL CALTRAN_mpi (ISTL_,IS2TL_,2,2,TEM,TEM1) + MPI_WTIMES(611)=MPI_WTIMES(611)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'4TEM = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + S1TIME=MPI_TIC() + IF(ISTRAN(3).EQ.1.AND.ISCDCA(3).LT.4) + & CALL CALTRAN_mpi (ISTL_,IS2TL_,3,3,DYE,DYE1) + MPI_WTIMES(612)=MPI_WTIMES(612)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(5).EQ.1.AND.ISCDCA(5).LT.4)THEN + DO NT=1,NTOX + M=MSVTOX(NT) + CALL CALTRAN_mpi (ISTL_,IS2TL_,5,M,TOX(1,1,NT),TOX1(1,1,NT)) + ENDDO + ENDIF + MPI_WTIMES(613)=MPI_WTIMES(613)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + DO NS=1,NSED + call collect_in_zero_array(SED(:,:,NS)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'SED01 = ', sum(abs(dble(SED))) + ENDIF + ENDIF + S1TIME=MPI_TIC() + IF(ISTRAN(6).EQ.1.AND.ISCDCA(6).LT.4)THEN + DO NS=1,NSED + M=MSVSED(NS) + CALL CALTRAN_mpi (ISTL_,IS2TL_,6,M,SED(1,1,NS),SED1(1,1,NS)) + ENDDO + ENDIF + MPI_WTIMES(614)=MPI_WTIMES(614)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + DO NS=1,NSED + call collect_in_zero_array(SED(:,:,NS)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'SED10 = ', sum(abs(dble(SED))) + ENDIF + ENDIF +C + S1TIME=MPI_TIC() + IF(ISTRAN(7).EQ.1.AND.ISCDCA(7).LT.4)THEN + DO NS=1,NSND + M=MSVSND(NS) + CALL CALTRAN_mpi (ISTL_,IS2TL_,6,M,SND(1,1,NS),SND1(1,1,NS)) + ENDDO + ENDIF + MPI_WTIMES(615)=MPI_WTIMES(615)+MPI_TOC(S1TIME) +C +C ** 3D COSMIC ADVECTI0N TRANSPORT CALCULATION +C + IF(ISCOSMIC.EQ.1)THEN + CALL CPU_TIME(TTMP) + S1TIME=MPI_TIC() + IF(ISTRAN(1).EQ.1.AND.ISCDCA(1).EQ.4) + & CALL COSTRANW (ISTL,IS2TL,1,1,SAL,SAL1) + MPI_WTIMES(616)=MPI_WTIMES(616)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(2).EQ.1.AND.ISCDCA(2).EQ.4) + & CALL COSTRANW (ISTL,IS2TL,2,2,TEM,TEM1) + MPI_WTIMES(617)=MPI_WTIMES(617)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(3).EQ.1.AND.ISCDCA(3).EQ.4) + & CALL COSTRANW (ISTL,IS2TL,3,3,DYE,DYE1) + MPI_WTIMES(618)=MPI_WTIMES(618)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(1).EQ.1.AND.ISCDCA(1).EQ.5) + & CALL COSTRAN (ISTL,IS2TL,1,1,SAL,SAL1) + MPI_WTIMES(619)=MPI_WTIMES(619)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(2).EQ.1.AND.ISCDCA(2).EQ.5) + & CALL COSTRAN (ISTL,IS2TL,2,2,TEM,TEM1) + MPI_WTIMES(620)=MPI_WTIMES(620)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(3).EQ.1.AND.ISCDCA(3).EQ.5) + & CALL COSTRAN (ISTL,IS2TL,3,3,DYE,DYE1) + MPI_WTIMES(621)=MPI_WTIMES(621)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(5).EQ.1.AND.ISCDCA(5).EQ.4)THEN + DO NT=1,NTOX + M=MSVTOX(NT) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + TVAR1S(L,K)=TOX1(L,K,NT) + TVAR2S(L,K)=TOX(L,K,NT) + ENDDO + ENDDO + CALL COSTRANW (ISTL,IS2TL,5,M,TVAR2S,TVAR1S) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + TOX1(L,K,NT)=TVAR1S(L,K) + TOX(L,K,NT)=TVAR2S(L,K) + ENDDO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(622)=MPI_WTIMES(622)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(5).EQ.1.AND.ISCDCA(5).EQ.5)THEN + DO NT=1,NTOX + M=MSVTOX(NT) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + TVAR1S(L,K)=TOX1(L,K,NT) + TVAR2S(L,K)=TOX(L,K,NT) + ENDDO + ENDDO + CALL COSTRAN (ISTL,IS2TL,5,M,TVAR2S,TVAR1S) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + TOX1(L,K,NT)=TVAR1S(L,K) + TOX(L,K,NT)=TVAR2S(L,K) + ENDDO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(623)=MPI_WTIMES(623)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(6).EQ.1.AND.ISCDCA(6).EQ.4)THEN + DO NS=1,NSED + M=MSVSED(NS) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + TVAR1S(L,K)=SED1(L,K,NS) + TVAR2S(L,K)=SED(L,K,NS) + ENDDO + ENDDO + CALL COSTRANW (ISTL,IS2TL,6,M,TVAR2S,TVAR1S) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SED1(L,K,NS)=TVAR1S(L,K) + SED(L,K,NS)=TVAR2S(L,K) + ENDDO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(624)=MPI_WTIMES(624)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(6).EQ.1.AND.ISCDCA(6).EQ.5)THEN + DO NS=1,NSED + M=MSVSED(NS) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + TVAR1S(L,K)=SED1(L,K,NS) + TVAR2S(L,K)=SED(L,K,NS) + ENDDO + ENDDO + CALL COSTRAN (ISTL,IS2TL,6,M,TVAR2S,TVAR1S) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SED1(L,K,NS)=TVAR1S(L,K) + SED(L,K,NS)=TVAR2S(L,K) + ENDDO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(625)=MPI_WTIMES(625)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(7).EQ.1.AND.ISCDCA(7).EQ.4)THEN + DO NS=1,NSND + M=MSVSND(NS) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + TVAR1S(L,K)=SND1(L,K,NS) + TVAR2S(L,K)=SND(L,K,NS) + ENDDO + ENDDO + CALL COSTRANW (ISTL,IS2TL,7,M,TVAR2S,TVAR1S) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SND1(L,K,NS)=TVAR1S(L,K) + SND(L,K,NS)=TVAR2S(L,K) + ENDDO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(626)=MPI_WTIMES(626)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(7).EQ.1.AND.ISCDCA(7).EQ.5)THEN + DO NS=1,NSND + M=MSVSND(NS) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + TVAR1S(L,K)=SND1(L,K,NS) + TVAR2S(L,K)=SND(L,K,NS) + ENDDO + ENDDO + CALL COSTRAN (ISTL,IS2TL,7,M,TVAR2S,TVAR1S) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SND1(L,K,NS)=TVAR1S(L,K) + SND(L,K,NS)=TVAR2S(L,K) + ENDDO + ENDDO + ENDDO + ENDIF + CALL CPU_TIME(T1TMP) + TSADV=TSADV+T1TMP-TTMP + ENDIF + MPI_WTIMES(627)=MPI_WTIMES(627)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'5TEM = ', sum(abs(dble(TEM))) + ENDIF + ENDIF +C +C ** 1D ADVECTI0N TRANSPORT CALCULATION +C +C *** REMOVED 2004-09-19 PMC +C +C ** SURFACE AND INTERNAL HEAT SOURCE-SINK CALCULATION +C + S1TIME=MPI_TIC() + IF(ISTRAN(2).GE.1) CALL CALHEAT_mpi(ISTL_) + MPI_WTIMES(628)=MPI_WTIMES(628)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'6TEM = ', sum(abs(dble(TEM))) + ENDIF + ENDIF +C +C ** FULL IMPLICIT DYE AND TOXIC CONTAMINANT DECAY/GROWTH CALCULATION +C + S1TIME=MPI_TIC() + IF(ISTRAN(3).GE.1)THEN + ! *** DSLLC BEGIN BLOCK + IF(RKDYE.EQ.1000.0)THEN + ! *** Age of Water + DAGE=DELT/86400. + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + DYE(L,K)=DYE(L,K)+DAGE + ENDDO + ENDDO + ELSE + IF(RKDYE.LT.0.0)THEN + CDYETMP=EXP(-RKDYE*DELT) + ELSE + CDYETMP=1./(1.+DELT*RKDYE) + ENDIF + + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO K=1,KC + DO L=LF,LL + DYE(L,K)=CDYETMP*DYE(L,K) + ENDDO + ENDDO + ENDDO + ENDIF + ! *** DSLLC END BLOCK + ENDIF + MPI_WTIMES(629)=MPI_WTIMES(629)+MPI_TOC(S1TIME) +C +C ** BOTTOM AND INTERNAL SEDIMENT AND TOXIC CONTAMINAT +C ** SOURCE-SINK CALCULATION +C +C +C ** SEDIMENT AND TOXICS SETTLING,DEPOSITION,RESUSPENSION,ETC +C ** FOR TWO TIME LEVEL SIMULATION +C + IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1) THEN + IF(IS2TIM.GE.1)THEN + ISEDDTC=ISEDDTC+1 + IF(ISEDDTC.EQ.1)THEN + DTSED=DELT + ELSE + DTSED=DTSED+DELT + ENDIF + IBALSTDT=0 + S1TIME=MPI_TIC() + IF(ISEDDTC.EQ.ISEDDT)THEN + CALL SSEDTOX(ISTL,IS2TL,1.0) + IBALSTDT=1 + ISEDDTC=0 + ENDIF + MPI_WTIMES(630)=MPI_WTIMES(630)+MPI_TOC(S1TIME) +C +C ** SEDIMENT AND TOXICS SETTLING,DEPOSITION,RESUSPENSION,ETC +C ** FOR THREE TIME LEVEL SIMULATION +C + ELSE ! IF(IS2TIM.EQ.0)THEN + S1TIME=MPI_TIC() + IBALSTDT=0 + DTSED=FLOAT(NTSTBC)*DT + CALL SSEDTOX(ISTL,IS2TL,1.0) + IBALSTDT=1 + MPI_WTIMES(631)=MPI_WTIMES(631)+MPI_TOC(S1TIME) + ENDIF + ENDIF +C +C 888 FORMAT('N,IC,I,DTS,DT = ',3I5,2F12.8) +C 889 FORMAT('N,IC,I,DTS = ',3I5,F12.8,12X,'SSEDTOX CALLED') + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'7TEM = ', sum(abs(dble(TEM))) + ENDIF + ENDIF +C +C ** OPTIONAL MASS BALANCE CALCULATION +C + IF(IS2TIM.EQ.0) THEN + IF(ISTL_.NE.2.AND.ISBAL.GE.1)THEN + S1TIME=MPI_TIC() + CALL CALBAL2 + CALL CALBAL3 + MPI_WTIMES(632)=MPI_WTIMES(632)+MPI_TOC(S1TIME) + NTMP=MOD(N,2) + IF(NTMP.EQ.0)THEN + S1TIME=MPI_TIC() + CALL CBALEV2 + CALL CBALEV3 + MPI_WTIMES(633)=MPI_WTIMES(633)+MPI_TOC(S1TIME) + ELSE + S1TIME=MPI_TIC() + CALL CBALOD2 + CALL CBALOD3 + MPI_WTIMES(634)=MPI_WTIMES(634)+MPI_TOC(S1TIME) + ENDIF + ENDIF + ENDIF +C +C ** CALLS TO TWO-TIME LEVEL BALANCES +C + IF(IS2TIM.GE.1) THEN + IF(ISBAL.GE.1)THEN + S1TIME=MPI_TIC() + CALL BAL2T2 + CALL BAL2T3B(IBALSTDT) + MPI_WTIMES(635)=MPI_WTIMES(635)+MPI_TOC(S1TIME) + ENDIF + ENDIF +C +C ** SEDIMENT BUDGET CALCULATION (DLK 10/15) +C + IF(IS2TIM.EQ.0) THEN + IF(ISTL_.NE.2.AND.ISSBAL.GE.1)THEN + S1TIME=MPI_TIC() + CALL BUDGET2 + CALL BUDGET3 + MPI_WTIMES(636)=MPI_WTIMES(636)+MPI_TOC(S1TIME) + ENDIF + ENDIF + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'8TEM = ', sum(abs(dble(TEM))) + ENDIF + ENDIF +C +C ** VERTICAL DIFFUSION IMPLICIT HALF STEP CALCULATION +C + IF(KC.EQ.1) GOTO 1500 + CALL CPU_TIME(TTMP) + RCDZKK=-DELTD2*CDZKK(1) + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(CCUBTMP,CCMBTMP) + DO L=LMPI2,LMPILA + CCUBTMP=RCDZKK*HPI(L)*AB(L,1) + CCMBTMP=1.-CCUBTMP + EEB(L)=1./CCMBTMP + CU1(L,1)=CCUBTMP*EEB(L) + ENDDO + IF(ISTRAN(1).GE.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SAL(L,1)=SAL(L,1)*EEB(L) + ENDDO + ENDIF + IF(ISTRAN(2).GE.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TEM(L,1)=TEM(L,1)*EEB(L) + ENDDO + ENDIF + IF(ISTRAN(3).GE.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + DYE(L,1)=DYE(L,1)*EEB(L) + ENDDO + ENDIF + IF(ISTRAN(5).GE.1)THEN + DO NT=1,NTOX +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TOX(L,1,NT)=TOX(L,1,NT)*EEB(L) + ENDDO + ENDDO + ENDIF + IF(ISTRAN(6).GE.1)THEN + DO NS=1,NSED +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SED(L,1,NS)=SED(L,1,NS)*EEB(L) + ENDDO + ENDDO + ENDIF + IF(ISTRAN(7).GE.1)THEN + DO NS=1,NSND +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SND(L,1,NS)=SND(L,1,NS)*EEB(L) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(637)=MPI_WTIMES(637)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + + DO K=2,KS + RCDZKMK=-DELTD2*CDZKMK(K) + RCDZKK=-DELTD2*CDZKK(K) +!$OMP PARALLEL DO PRIVATE(CCUBTMP,CCMBTMP) + DO L=LMPI2,LMPILA + CCLBTMP_2D(L,K)=RCDZKMK*HPI(L)*AB(L,K-1) + CCUBTMP=RCDZKK*HPI(L)*AB(L,K) + CCMBTMP=1.-CCLBTMP_2D(L,K)-CCUBTMP + EEB_2D(L,K)=1./(CCMBTMP-CCLBTMP_2D(L,K)*CU1(L,K-1)) + CU1(L,K)=CCUBTMP*EEB_2D(L,K) + ENDDO + ENDDO + + IF(ISTRAN(1).GE.1)THEN + DO K=2,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SAL(L,K)=(SAL(L,K)-CCLBTMP_2D(L,K)*SAL(L,K-1))*EEB_2D(L,K) + ENDDO + ENDDO + ENDIF + + IF(ISTRAN(2).GE.1)THEN + DO K=2,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TEM(L,K)=(TEM(L,K)-CCLBTMP_2D(L,K)*TEM(L,K-1))*EEB_2D(L,K) + ENDDO + ENDDO + ENDIF + + IF(ISTRAN(3).GE.1)THEN + DO K=2,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + DYE(L,K)=(DYE(L,K)-CCLBTMP_2D(L,K)*DYE(L,K-1))*EEB_2D(L,K) + ENDDO + ENDDO + ENDIF + IF(ISTRAN(5).GE.1)THEN + DO NT=1,NTOX + DO K=2,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TOX(L,K,NT)=(TOX(L,K,NT)-CCLBTMP_2D(L,K)*TOX(L,K-1,NT)) + & *EEB_2D(L,K) + ENDDO + ENDDO + ENDDO + ENDIF + IF(ISTRAN(6).GE.1)THEN + DO NS=1,NSED + DO K=2,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SED(L,K,NS)=(SED(L,K,NS)-CCLBTMP_2D(L,K)*SED(L,K-1,NS)) + & *EEB_2D(L,K) + ENDDO + ENDDO + ENDDO + ENDIF + IF(ISTRAN(7).GE.1)THEN + DO NS=1,NSND + DO K=2,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SND(L,K,NS)=(SND(L,K,NS)-CCLBTMP_2D(L,K)*SND(L,K-1,NS)) + & *EEB_2D(L,K) + ENDDO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(638)=MPI_WTIMES(638)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'9TEM = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + K=KC + RCDZKMK=-DELTD2*CDZKMK(K) + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(CCMBTMP) + DO L=LMPI2,LMPILA + CCLBTMP(L)=RCDZKMK*HPI(L)*AB(L,K-1) + CCMBTMP=1.-CCLBTMP(L) + EEB(L)=1./(CCMBTMP-CCLBTMP(L)*CU1(L,K-1)) + ENDDO + IF(ISTRAN(1).GE.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SAL(L,K)=(SAL(L,K)-CCLBTMP(L)*SAL(L,K-1))*EEB(L) + ENDDO + ENDIF + IF(ISTRAN(2).GE.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TEM(L,K)=(TEM(L,K)-CCLBTMP(L)*TEM(L,K-1))*EEB(L) + ENDDO + ENDIF + IF(ISTRAN(3).GE.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + DYE(L,K)=(DYE(L,K)-CCLBTMP(L)*DYE(L,K-1))*EEB(L) + ENDDO + ENDIF + IF(ISTRAN(5).GE.1)THEN + DO NT=1,NTOX +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TOX(L,K,NT)=(TOX(L,K,NT)-CCLBTMP(L)*TOX(L,K-1,NT))*EEB(L) + ENDDO + ENDDO + ENDIF + IF(ISTRAN(6).GE.1)THEN + DO NS=1,NSED +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SED(L,K,NS)=(SED(L,K,NS)-CCLBTMP(L)*SED(L,K-1,NS))*EEB(L) + ENDDO + ENDDO + ENDIF + IF(ISTRAN(7).GE.1)THEN + DO NS=1,NSND +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SND(L,K,NS)=(SND(L,K,NS)-CCLBTMP(L)*SND(L,K-1,NS))*EEB(L) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(639)=MPI_WTIMES(639)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISTRAN(1).GE.1)THEN + DO K=KC-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SAL(L,K)=SAL(L,K)-CU1(L,K)*SAL(L,K+1) + ENDDO + ENDDO + ENDIF + + IF(ISTRAN(2).GE.1)THEN + DO K=KC-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TEM(L,K)=TEM(L,K)-CU1(L,K)*TEM(L,K+1) + ENDDO + ENDDO + ENDIF + + IF(ISTRAN(3).GE.1)THEN + DO K=KC-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + DYE(L,K)=DYE(L,K)-CU1(L,K)*DYE(L,K+1) + ENDDO + ENDDO + ENDIF + IF(ISTRAN(5).GE.1)THEN + DO NT=1,NTOX + DO K=KC-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TOX(L,K,NT)=TOX(L,K,NT)-CU1(L,K)*TOX(L,K+1,NT) + ENDDO + ENDDO + ENDDO + ENDIF + IF(ISTRAN(6).GE.1)THEN + DO NS=1,NSED + DO K=KC-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SED(L,K,NS)=SED(L,K,NS)-CU1(L,K)*SED(L,K+1,NS) + ENDDO + ENDDO + ENDDO + ENDIF + IF(ISTRAN(7).GE.1)THEN + DO NS=1,NSND + DO K=KC-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SND(L,K,NS)=SND(L,K,NS)-CU1(L,K)*SND(L,K+1,NS) + ENDDO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(640)=MPI_WTIMES(640)+MPI_TOC(S1TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'ATEM = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + S1TIME=MPI_TIC() +C DO K=1,KB +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SEDBT(L,1:KB)=0. + SNDBT(L,1:KB)=0. + ENDDO +C ENDDO +C DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SEDT(L,1:KC)=0. + SNDT(L,1:KC)=0. + ENDDO +C ENDDO + DO K=1,KB + DO NS=1,NSED +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SEDBT(L,K)=SEDBT(L,K)+SEDB(L,K,NS) + ENDDO + ENDDO + ENDDO + DO NS=1,NSND + DO K=1,KB +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SNDBT(L,K)=SNDBT(L,K)+SNDB(L,K,NS) + ENDDO + ENDDO + ENDDO + DO NS=1,NSED + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SEDT(L,K)=SEDT(L,K)+SED(L,K,NS) + ENDDO + ENDDO + ENDDO + DO NS=1,NSND + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SNDT(L,K)=SNDT(L,K)+SND(L,K,NS) + ENDDO + ENDDO + ENDDO + MPI_WTIMES(641)=MPI_WTIMES(641)+MPI_TOC(S1TIME) + CALL CPU_TIME(T1TMP) + TVDIF=TVDIF+T1TMP-TTMP + 1500 CONTINUE +C +C ** DATA ASSIMILATION +C + S1TIME=MPI_TIC() + IF(NLCDA.GT.0)THEN + SALASM=0.0 + TEMASM=0.0 + DYEASM=0.0 + SFLASM=0.0 + DO NT=1,NTOX + TOXASM(NT)=0.0 + ENDDO + DO NS=1,NSED + SEDASM(NS)=0.0 + ENDDO + DO NS=1,NSND + SNDASM(NS)=0.0 + ENDDO +C + IWASM=0 +C + IF(N.EQ.1.AND.DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='CDATASM.DIA') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='CDATASM.DIA') + IWASM=1 + DO NLC=1,NLCDA + DO NDAYA=1,NTC + FSALASM(NDAYA,NLC)=0. + FVOLASM(NDAYA,NLC)=0. + FTEMASM(NDAYA,NLC)=0. + ENDDO + ENDDO + ENDIF +C + NDAYA=MOD(N,NTSPTC) + NDAYA=1+(N-NDAYA)/NTSPTC +C + IF(N.EQ.NTSPTC.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='CDATASM.DIA',POSITION='APPEND') + IWASM=1 + WRITE(1,1212)N,NDAYA + ENDIF +C + IF(ISCDA(1).GT.0)THEN + DO K=1,KC + DO NLC=1,NLCDA + L=LIJ(ICDA(NLC),JCDA(NLC)) + CONASMOLD=SAL(L,K) + NSID=NCSERA(NLC,1) + IF(IWASM.EQ.1) WRITE(1,1111)N,NLC,ICDA(NLC),JCDA(NLC),NS, + & CSERT(K,NS,1),SAL(L,K) + IF(ITPCDA(NLC).EQ.0)THEN + IF(NSID.GT.0)THEN + IF(CSERT(K,NSID,1).GT.0)THEN + FSALASM(NDAYA,NLC)=FSALASM(NDAYA,NLC)+TSCDA*DZC(K)* + & DXYP(L)*HP(L)*(CSERT(K,NSID,1)-SAL(L,K)) + FVOLASM(NDAYA,NLC)=FVOLASM(NDAYA,NLC)+TSCDA*DZC(K)* + & DXYP(L)*HP(L)*(1.0-( CSERT(K,NSID,1)/SAL(L,K) )) + SAL(L,K)=TSCDA*CSERT(K,NSID,1)+(1.-TSCDA)*SAL(L,K) + ENDIF + ENDIF + ENDIF + IF(IWASM.EQ.1) WRITE(1,1111)N,NLC,ICDA(NLC),JCDA(NLC),NS, + & CSERT(K,NS,1),SAL(L,K) + IF(ITPCDA(NLC).EQ.1)THEN + LDATA=LIJ(ICCDA(NLC),JCCDA(NLC)) + SAL(L,K)=TSCDA*SAL(LDATA,K)+(1.-TSCDA)*SAL(L,K) + ENDIF + SALASM=SALASM+HP(L)*DXYP(L)*(SAL(L,K)-CONASMOLD)*DZC(K) + ENDDO + ENDDO + ENDIF +C + IF(ISCDA(2).GT.0)THEN + DO K=1,KC + DO NLC=1,NLCDA + L=LIJ(ICDA(NLC),JCDA(NLC)) + CONASMOLD=TEM(L,K) + NSID=NCSERA(NLC,2) + IF(IWASM.EQ.1) WRITE(1,1112)N,NLC,ICDA(NLC),JCDA(NLC),NS, + & CSERT(K,NS,2),TEM(L,K) + IF(ITPCDA(NLC).EQ.0)THEN + IF(NSID.GT.0)THEN + IF(CSERT(K,NSID,2).GT.0)THEN + FTEMASM(NDAYA,NLC)=FTEMASM(NDAYA,NLC)+TSCDA*DZC(K)* + & DXYP(L)*HP(L)*(CSERT(K,NSID,2)-TEM(L,K)) + TEM(L,K)=TSCDA*CSERT(K,NSID,2)+(1.-TSCDA)*TEM(L,K) + ENDIF + ENDIF + ENDIF + IF(IWASM.EQ.1) WRITE(1,1112)N,NLC,ICDA(NLC),JCDA(NLC),NS, + & CSERT(K,NSID,2),TEM(L,K) + IF(ITPCDA(NLC).EQ.1)THEN + LDATA=LIJ(ICCDA(NLC),JCCDA(NLC)) + TEM(L,K)=TSCDA*TEM(LDATA,K)+(1.-TSCDA)*TEM(L,K) + ENDIF + TEMASM=TEMASM+HP(L)*DXYP(L)*(TEM(L,K)-CONASMOLD)*DZC(K) + ENDDO + ENDDO + ENDIF +C + IF(ISCDA(3).GT.0)THEN + DO K=1,KC + DO NLC=1,NLCDA + L=LIJ(ICDA(NLC),JCDA(NLC)) + CONASMOLD=DYE(L,K) + NSID=NCSERA(NLC,3) + IF(ITPCDA(NLC).EQ.0)THEN + IF(NS.GT.0)THEN + IF(CSERT(K,NSID,3).GT.0)THEN + DYE(L,K)=TSCDA*CSERT(K,NSID,3)+(1.-TSCDA)*DYE(L,K) + ENDIF + ENDIF + ENDIF + IF(ITPCDA(NLC).EQ.1)THEN + LDATA=LIJ(ICCDA(NLC),JCCDA(NLC)) + DYE(L,K)=TSCDA*DYE(LDATA,K)+(1.-TSCDA)*DYE(L,K) + ENDIF + DYEASM=DYEASM+HP(L)*DXYP(L)*(DYE(L,K)-CONASMOLD)*DZC(K) + ENDDO + ENDDO + ENDIF +C + IF(ISCDA(4).GT.0)THEN + DO K=1,KC + DO NLC=1,NLCDA + L=LIJ(ICDA(NLC),JCDA(NLC)) + CONASMOLD=SFL(L,K) + NSID=NCSERA(NLC,4) + IF(ITPCDA(NLC).EQ.0)THEN + IF(NSID.GT.0)THEN + IF(CSERT(K,NSID,4).GT.0)THEN + SFL(L,K)=TSCDA*CSERT(K,NSID,4)+(1.-TSCDA)*SFL(L,K) + ENDIF + ENDIF + ENDIF + IF(ITPCDA(NLC).EQ.1)THEN + LDATA=LIJ(ICCDA(NLC),JCCDA(NLC)) + SFL(L,K)=TSCDA*SFL(LDATA,K)+(1.-TSCDA)*SFL(L,K) + ENDIF + SFLASM=SFLASM+HP(L)*DXYP(L)*(SFL(L,K)-CONASMOLD)*DZC(K) + ENDDO + ENDDO + ENDIF +C + IF(ISCDA(5).GT.0)THEN + DO NT=1,NTOX + M=MSVTOX(NT) + DO K=1,KC + DO NLC=1,NLCDA + L=LIJ(ICDA(NLC),JCDA(NLC)) + CONASMOLD=TOX(L,K,NT) + NSID=NCSERA(NLC,M) + IF(ITPCDA(NLC).EQ.0)THEN + IF(NSID.GT.0)THEN + IF(CSERT(K,NSID,M).GT.0)THEN + TOX(L,K,NT)=TSCDA*CSERT(K,NSID,M)+(1.-TSCDA)* + & TOX(L,K,NT) + ENDIF + ENDIF + ENDIF + IF(ITPCDA(NLC).EQ.1)THEN + LDATA=LIJ(ICCDA(NLC),JCCDA(NLC)) + TOX(L,K,NT)=TSCDA*TOX(LDATA,K,NT)+(1.-TSCDA)*TOX(L,K,NT) + ENDIF + TOXASM(NT)=TOXASM(NT) + & +HP(L)*DXYP(L)*(TOX(L,K,NT)-CONASMOLD)*DZC(K) + ENDDO + ENDDO + ENDDO + ENDIF +C + IF(ISCDA(6).GT.0)THEN + DO NS=1,NSED + M=MSVSED(NS) + DO K=1,KC + DO NLC=1,NLCDA + L=LIJ(ICDA(NLC),JCDA(NLC)) + CONASMOLD=SED(L,K,NS) + NSID=NCSERA(NLC,M) + IF(ITPCDA(NLC).EQ.0)THEN + IF(NSID.GT.0)THEN + IF(CSERT(K,NSID,M).GT.0)THEN + SED(L,K,NS)=TSCDA*CSERT(K,NSID,M)+(1.-TSCDA)* + & SED(L,K,NS) + ENDIF + ENDIF + ENDIF + IF(ITPCDA(NLC).EQ.1)THEN + LDATA=LIJ(ICCDA(NLC),JCCDA(NLC)) + SED(L,K,NS)=TSCDA*SED(LDATA,K,NS)+(1.-TSCDA)*SED(L,K,NS) + ENDIF + SEDASM(NS)=SEDASM(NS) + & +HP(L)*DXYP(L)*(SED(L,K,NS)-CONASMOLD)*DZC(K) + ENDDO + ENDDO + ENDDO + ENDIF +C +C6222 FORMAT(' TC,SNEW,SASSM,SOLD='4F10.2) +C + IF(ISCDA(7).GT.0)THEN + DO NX=1,NSND + M=MSVSND(NX) + DO K=1,KC + DO NLC=1,NLCDA + L=LIJ(ICDA(NLC),JCDA(NLC)) + CONASMOLD=SND(L,K,NX) + NSID=NCSERA(NLC,M) + IF(ITPCDA(NLC).EQ.0)THEN + IF(NSID.GT.0)THEN + IF(CSERT(K,NSID,M).GT.0)THEN + SND(L,K,NX)=TSCDA*CSERT(K,NSID,M)+(1.-TSCDA)* + & SND(L,K,NX) + ENDIF + ENDIF + ENDIF + IF(ITPCDA(NLC).EQ.1)THEN + LDATA=LIJ(ICCDA(NLC),JCCDA(NLC)) + SND(L,K,NX)=TSCDA*SND(LDATA,K,NX)+(1.-TSCDA)*SND(L,K,NX) + ENDIF + SNDASM(NX)=SNDASM(NX) + & +HP(L)*DXYP(L)*(SND(L,K,NX)-CONASMOLD)*DZC(K) + ENDDO + ENDDO + ENDDO + ENDIF +C + IF(IWASM.EQ.1.AND.MYRANK.EQ.0)THEN + CLOSE(1) + ENDIF +C + IF(IS2TIM.GE.1) THEN + IF(ISBAL.GE.1)THEN + SALOUT=SALOUT-SALASM + DYEOUT=DYEOUT-DYEASM + DO NT=1,NTOX + TOXOUT2T(NT)=TOXOUT2T(NT)-TOXASM(NT) + ENDDO + DO NS=1,NSED + SEDOUT2T(NS)=SEDOUT2T(NS)-SEDASM(NS) + ENDDO + DO NS=1,NSND + SNDOUT2T(NS)=SNDOUT2T(NS)-SNDASM(NS) + ENDDO + ENDIF + ENDIF +C + ENDIF + MPI_WTIMES(642)=MPI_WTIMES(642)+MPI_TOC(S1TIME) +C + 1111 FORMAT(' SAL '5I5,2F10.3) + 1112 FORMAT(' TEM '5I5,2F10.3) + 1212 FORMAT(' N,NDAYA = ',2I12) +C +C ** SURFACE AND INTERNAL HEAT SOURCE-SINK CALCULATION +C ** DYE DECAY CALCULATION +C ** BOTTOM AND INTERNAL SEDIMENT SOURCE-SINK CALCULATION +C + RETURN + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCSER.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCSER.for index 98cece3fd..cd18f3595 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCSER.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCSER.for @@ -318,7 +318,7 @@ C SFNTBET=WTM1*SFNTBE(M1)+WTM2*SFNTBE(M2) SFATBTT=WTM1*SFATBT(M1)+WTM2*SFATBT(M2) 400 CONTINUE - 6000 FORMAT('N, CSERT(1),CSERT(KC) = ',I6,4X,2F12.2) +C6000 FORMAT('N, CSERT(1),CSERT(KC) = ',I6,4X,2F12.2) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCSER_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCSER_mpi.for new file mode 100644 index 000000000..4518cc970 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALCSER_mpi.for @@ -0,0 +1,358 @@ + SUBROUTINE CALCSER_mpi(ISTL_) +C +C CHANGE RECORD +C ** SUBROUTINE CALPSER UPDATES TIME VARIABLE SALINITY, TEMPERATURE +C ** DYE, SEDIMENT, AND SHELL FISH LARVAE +C ** BOUNDARY CONDITIONS AND INFLOW CONCENTRATIONS +C + USE GLOBAL + USE MPI + + IMPLICIT NONE + INTEGER::NS,K,NT,NTT,ISTL_,M1,M2,NQ + REAL::TIME,TDIFF,WTM1,WTM2 +C +C ** INITIALIZE NULL SERIES CONCENTRATIONS +C + S1TIME=MPI_TIC() + NTT=4+NTOX+NSED+NSND + DO NT=1,NTT + CQWRSERT(0,NT)=0. + DO K=1,KC + CSERT(K,0,NT)=0. + ENDDO + ENDDO + MPI_WTIMES(451)=MPI_WTIMES(451)+MPI_TOC(S1TIME) +C +C ** CONCENTRATION SERIES INTERPOLTATION, SAL,TEM,DYE,SFL +C + CSERT_TMP=0. + S1TIME=MPI_TIC() + DO NC=1,4 + IF(ISTRAN(NC).EQ.0) GOTO 200 +!!$OMP PARALLEL DO PRIVATE(TIME,M1,M2,TDIFF,WTM1,WTM2) + DO NS=1,NCSER(NC) + IF(IS_CSER(NS,NC))THEN + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N)-0.5)/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ELSE + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N-1)/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ENDIF + M1=MCTLAST(NS,NC) + 100 CONTINUE + M2=M1+1 + IF(TIME.GT.TCSER(M2,NS,NC))THEN + M1=M2 + GOTO 100 + ELSE + MCTLAST(NS,NC)=M1 + ENDIF + TDIFF=TCSER(M2,NS,NC)-TCSER(M1,NS,NC) + WTM1=(TCSER(M2,NS,NC)-TIME)/TDIFF + WTM2=(TIME-TCSER(M1,NS,NC))/TDIFF +C DO K=1,KC + CSERT(:,NS,NC)=WTM1*CSER(M1,:,NS,NC)+WTM2*CSER(M2,:,NS,NC) +C ENDDO + ENDIF + ENDDO + 200 CONTINUE + ENDDO + MPI_WTIMES(452)=MPI_WTIMES(452)+MPI_TOC(S1TIME) +C +C ** CONCENTRATION SERIES INTERPOLTATION FOR TOX +C + S1TIME=MPI_TIC() + IF(ISTRAN(5).GE.1)THEN +!!$OMP PARALLEL DO PRIVATE(NC,TIME,M1,M2,TDIFF,WTM1,WTM2) + DO NT=1,NTOX + NC=MSVTOX(NT) + DO NS=1,NCSER(NC) + IF(IS_CSER(NS,NC))THEN + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N)-0.5)/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ELSE + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N-1)/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ENDIF + M1=MCTLAST(NS,NC) + 101 CONTINUE + M2=M1+1 + IF(TIME.GT.TCSER(M2,NS,NC))THEN + M1=M2 + GOTO 101 + ELSE + MCTLAST(NS,NC)=M1 + ENDIF + TDIFF=TCSER(M2,NS,NC)-TCSER(M1,NS,NC) + WTM1=(TCSER(M2,NS,NC)-TIME)/TDIFF + WTM2=(TIME-TCSER(M1,NS,NC))/TDIFF +C DO K=1,KC + CSERT(:,NS,NC)=WTM1*CSER(M1,:,NS,NC)+WTM2*CSER(M2,:,NS,NC) +C ENDDO + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(453)=MPI_WTIMES(453)+MPI_TOC(S1TIME) +C +C ** CONCENTRATION SERIES INTERPOLTATION FOR SED +C + S1TIME=MPI_TIC() + IF(ISTRAN(6).GE.1)THEN +!!$OMP PARALLEL DO PRIVATE(NC,TIME,M1,M2,TDIFF,WTM1,WTM2) + DO NT=1,NSED + NC=MSVSED(NT) + DO NS=1,NCSER(NC) + IF(IS_CSER(NS,NC))THEN + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N)-0.5)/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ELSE + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N-1))/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ENDIF + M1=MCTLAST(NS,NC) + 102 CONTINUE + M2=M1+1 + IF(TIME.GT.TCSER(M2,NS,NC))THEN + M1=M2 + GOTO 102 + ELSE + MCTLAST(NS,NC)=M1 + ENDIF + TDIFF=TCSER(M2,NS,NC)-TCSER(M1,NS,NC) + WTM1=(TCSER(M2,NS,NC)-TIME)/TDIFF + WTM2=(TIME-TCSER(M1,NS,NC))/TDIFF +C DO K=1,KC + CSERT(:,NS,NC)=WTM1*CSER(M1,:,NS,NC)+WTM2*CSER(M2,:,NS,NC) +C ENDDO + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(454)=MPI_WTIMES(454)+MPI_TOC(S1TIME) + +C ** CONCENTRATION SERIES INTERPOLTATION FOR SND +C + S1TIME=MPI_TIC() + IF(ISTRAN(7).GE.1)THEN +!!$OMP PARALLEL DO PRIVATE(NC,TIME,M1,M2,TDIFF,WTM1,WTM2) + DO NT=1,NSND + NC=MSVSND(NT) + DO NS=1,NCSER(NC) + IF(IS_CSER(NS,NC))THEN + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N)-0.5)/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ELSE + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N-1))/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ENDIF + M1=MCTLAST(NS,NC) + 103 CONTINUE + M2=M1+1 + IF(TIME.GT.TCSER(M2,NS,NC))THEN + M1=M2 + GOTO 103 + ELSE + MCTLAST(NS,NC)=M1 + ENDIF + TDIFF=TCSER(M2,NS,NC)-TCSER(M1,NS,NC) + WTM1=(TCSER(M2,NS,NC)-TIME)/TDIFF + WTM2=(TIME-TCSER(M1,NS,NC))/TDIFF +C DO K=1,KC + CSERT(:,NS,NC)=WTM1*CSER(M1,:,NS,NC)+WTM2*CSER(M2,:,NS,NC) +C ENDDO + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(455)=MPI_WTIMES(455)+MPI_TOC(S1TIME) +C +C ** CONCENTRATION SERIES INTERPOLTATION FOR WATER QUALITY +C + IF(ISTRAN(8).GE.1)THEN ! .AND.IWQPSL.EQ.2)THEN + S1TIME=MPI_TIC() +!!$OMP PARALLEL DO PRIVATE(NC,TIME,M1,M2,TDIFF,WTM1,WTM2) + DO NQ=1,NWQV + NC=4+NTOX+NSED+NSND+NQ + DO NS=1,NCSER(NC) +C IF(IS_QSER(NS))THEN + IF(IS_CSER(NS,NC))THEN + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N)-0.5)/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ELSE + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N-1))/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ENDIF + M1=MCTLAST(NS,NC) + 104 CONTINUE + M2=M1+1 + IF(TIME.GT.TCSER(M2,NS,NC))THEN + M1=M2 + GOTO 104 + ELSE + MCTLAST(NS,NC)=M1 + ENDIF + TDIFF=TCSER(M2,NS,NC)-TCSER(M1,NS,NC) + WTM1=(TCSER(M2,NS,NC)-TIME)/TDIFF + WTM2=(TIME-TCSER(M1,NS,NC))/TDIFF +C DO K=1,KC + CSERT(:,NS,NC)=WTM1*CSER(M1,:,NS,NC)+WTM2*CSER(M2,:,NS,NC) +C ENDDO + ENDIF + ENDDO + ENDDO + MPI_WTIMES(456)=MPI_WTIMES(456)+MPI_TOC(S1TIME) +!{ GEOSR x-species. jgcho 2015.11.04 + S1TIME=MPI_TIC() +!!$OMP PARALLEL DO PRIVATE(NC,TIME,M1,M2,TDIFF,WTM1,WTM2) + DO NQ=1,NXSP + NC=4+NTOX+NSED+NSND+NWQV+NQ + DO NS=1,NCSER(NC) +C IF(IS_QSER(NS))THEN + IF(IS_CSER(NS,NC))THEN + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N)-0.5)/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ELSE + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N-1))/TCCSER(NS,NC) + & +TBEGIN*(TCON/TCCSER(NS,NC)) + ELSE + TIME=TIMESEC/TCCSER(NS,NC) + ENDIF + ENDIF + M1=MCTLAST(NS,NC) + 105 CONTINUE + M2=M1+1 + IF(TIME.GT.TCSER(M2,NS,NC))THEN + M1=M2 + GOTO 105 + ELSE + MCTLAST(NS,NC)=M1 + ENDIF + TDIFF=TCSER(M2,NS,NC)-TCSER(M1,NS,NC) + WTM1=(TCSER(M2,NS,NC)-TIME)/TDIFF + WTM2=(TIME-TCSER(M1,NS,NC))/TDIFF +C DO K=1,KC + CSERT(:,NS,NC)=WTM1*CSER(M1,:,NS,NC)+WTM2*CSER(M2,:,NS,NC) +C ENDDO + ENDIF + ENDDO + ENDDO + MPI_WTIMES(457)=MPI_WTIMES(457)+MPI_TOC(S1TIME) +!} GEOSR x-species. jgcho 2015.11.04 + ENDIF +C +C ** WRITE DIAGNOSTIC FILE FOR CSER INTERPOLTATION +C + S1TIME=MPI_TIC() + IF(ISDIQ.GE.1.AND.N.EQ.1.AND.DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='CDIAG.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='CDIAG.OUT',STATUS='UNKNOWN') + DO NC=1,NTT + WRITE(1,1001)NC + DO NS=1,NCSER(NC) + WRITE(1,1002)NS,(CSERT(K,NS,NC),K=1,KC) + ENDDO + ENDDO + CLOSE(1) + ENDIF + MPI_WTIMES(458)=MPI_WTIMES(458)+MPI_TOC(S1TIME) + 1001 FORMAT(/' TRANSPORT VARIABLE ID =',I5/) + 1002 FORMAT(I5,2X,12E12.4) +C +C ** SHELL FISH LARVAE BEHAVIOR TIME SERIES INTERPOLTATION +C + S1TIME=MPI_TIC() + IF(ISTRAN(4).EQ.0) GOTO 400 + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*(FLOAT(N)-0.5)/TCSFSER + & +TBEGIN*(TCON/TCSFSER) + ELSE + TIME=TIMESEC/TCSFSER + ENDIF + ELSE + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N-1)/TCSFSER + & +TBEGIN*(TCON/TCSFSER) + ELSE + TIME=TIMESEC/TCSFSER + ENDIF + ENDIF + M1=MSFTLST + 300 CONTINUE + M2=M1+1 + IF(TIME.GT.TSFSER(M2))THEN + M1=M2 + GOTO 300 + ELSE + MSFTLST=M1 + ENDIF + TDIFF=TSFSER(M2)-TSFSER(M1) + WTM1=(TSFSER(M2)-TIME)/TDIFF + WTM2=(TIME-TSFSER(M1))/TDIFF + RKDSFLT=WTM1*RKDSFL(M1)+WTM2*RKDSFL(M2) + WSFLSTT=WTM1*WSFLST(M1)+WTM2*WSFLST(M2) + WSFLSMT=WTM1*WSFLSM(M1)+WTM2*WSFLSM(M2) + DSFLMNT=WTM1*DSFLMN(M1)+WTM2*DSFLMN(M2) + DSFLMXT=WTM1*DSFLMX(M1)+WTM2*DSFLMX(M2) + SFNTBET=WTM1*SFNTBE(M1)+WTM2*SFNTBE(M2) + SFATBTT=WTM1*SFATBT(M1)+WTM2*SFATBT(M2) + 400 CONTINUE + MPI_WTIMES(459)=MPI_WTIMES(459)+MPI_TOC(S1TIME) +C6000 FORMAT('N, CSERT(1),CSERT(KC) = ',I6,4X,2F12.2) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDIFF_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDIFF_mpi.for new file mode 100644 index 000000000..93a913069 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDIFF_mpi.for @@ -0,0 +1,30 @@ + SUBROUTINE CALDIFF_mpi (ISTL_,M,CON1) +C +C CHANGE RECORD +C ** SUBROUTINE CALDIFF CALCULATES THE HORIZONTAL DIFFUSIVE +C ** TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO +C ** A REVISEDED VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL +C ** INDICATES THE NUMBER OF TIME LEVELS IN THE STEP +C + USE GLOBAL + USE MPI + IMPLICIT NONE + INTEGER::K,L,LS,M,ISTL_ + REAL::CON1 + DIMENSION CON1(LCM,KCM) +C +C ** HORIZONTAL DIFFUSIVE FLUX CALCULATION +C + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + FUHU(L,K)=FUHU(L,K)+0.5*SUB(L)*DYU(L)*HU(L)*(AH(L,K)+AH(L-1,K))* + & (CON1(L-1,K)-CON1(L,K))*DXIU(L) + FVHU(L,K)=FVHU(L,K)+0.5*SVB(L)*DXV(L)*HV(L)*(AH(L,K)+AH(LS,K))* + & (CON1(LS,K)-CON1(L,K))*DYIV(L) + ENDDO + ENDDO + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDISP2.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDISP2.for index 1cffce13c..e5c4942ef 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDISP2.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDISP2.for @@ -3,6 +3,7 @@ C C CHANGE RECORD C USE GLOBAL + USE MPI IMPLICIT NONE INTEGER::K,KK,KT,L,LN @@ -257,6 +258,7 @@ C C C ** WRITE OUTPUT FILES C + IF(MYRANK.EQ.0)THEN OPEN(88,FILE='DISTEN.OUT',STATUS='UNKNOWN') CLOSE(88,STATUS='DELETE') OPEN(88,FILE='DISTEN.OUT',STATUS='UNKNOWN') @@ -291,6 +293,7 @@ C WRITE(88,2013)IL(L),JL(L),(SVAL(K,L),K=1,KC) ENDDO CLOSE(88) + ENDIF 881 FORMAT(3X,'I',3X,'J',3X,'LON',9X,'LAT',9X,'DXX',10X,'DXY',10X, & 'DYX',10X,'DYY') 882 FORMAT(3X,'I',3X,'J',3X,'LON',9X,'LAT',9X,'AMCPT',8X,'AMSPT',8X, diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDISP3.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDISP3.for index 730728b21..aa161de4b 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDISP3.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALDISP3.for @@ -3,6 +3,7 @@ C C CHANGE RECORD C USE GLOBAL + USE MPI IMPLICIT NONE INTEGER::K,KK,L,LS,KT,LN @@ -236,6 +237,7 @@ C C C ** ADJUST DISPERSON TENSOR COMPONENTS C + IF(MYRANK.EQ.0)THEN OPEN(88,FILE='DISDIA.OUT',STATUS='UNKNOWN') CLOSE(88,STATUS='DELETE') OPEN(88,FILE='DISDIA.OUT',STATUS='UNKNOWN') @@ -429,6 +431,7 @@ C ENDIF ENDDO CLOSE(88) + ENDIF 8881 FORMAT(' I=',I5,2X,'J=',I5,2X,'DXX= ',E12.4) 8882 FORMAT(' I=',I5,2X,'J=',I5,2X,'DXY= ',E12.4) 8883 FORMAT(' I=',I5,2X,'J=',I5,2X,'DYX= ',E12.4) @@ -436,6 +439,7 @@ C C C ** WRITE OUTPUT FILES C + IF(MYRANK.EQ.0)THEN OPEN(88,FILE='DISTEN.OUT',STATUS='UNKNOWN') CLOSE(88,STATUS='DELETE') OPEN(88,FILE='DISTEN.OUT',STATUS='UNKNOWN') @@ -465,6 +469,7 @@ C & VELPF(L),SALLPF(L,1),SALLPF(L,KC) ENDDO CLOSE(88) + ENDIF 881 FORMAT(3X,'I',3X,'J',3X,'LON',9X,'LAT',9X,'DXX',10X,'DXY',10X, & 'DYX',10X,'DYY') 882 FORMAT(3X,'I',3X,'J',3X,'LON',9X,'LAT',9X,'AMCPT',8X,'AMSPT',8X, diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEBI.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEBI.for index 647b3228a..60d01b215 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEBI.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEBI.for @@ -1,50 +1,3 @@ - SUBROUTINE CALEBI0(LF,LL) -C -C CHANGE RECORD -C ** CALEBI CALCULATES THE EXTERNAL BUOYANCY INTEGRALS -C - USE GLOBAL - IMPLICIT NONE - INTEGER::K,L,IPMC,LLCM,LF,LL - REAL::EPSILON,DBK,DZCBK - - REAL*4 DZCB(KCM) - REAL*4 BK(KCM) - - PARAMETER(LLCM=200) - REAL*4 BI1T(LLCM) - REAL*4 BI2T(LLCM) - REAL*4 BET(LLCM) - - DO L=LF,LL - - BI1(L)=0. - BI2(L)=0. - BE(L)=0. - - DO K=1,KC - DZCB(K)=DZC(K)*B(L,K) - ENDDO - - DBK=0. - DO K=KC,1,-1 - DBK=DBK+DZCB(K) !DZC(K)*B(L,K) - BK(K)=DBK-0.5*DZCB(K) !DZC(K)*B(L,K) - ENDDO - - !Z(0)=0. - !Z(K)=Z(K-1)+DZC(K) - DO K=1,KC - BE(L) =BE(L)+DZCB(K) !DZC(K)*B(L,K) - DZCBK =DZC(K)*BK(K) - BI1(L)=BI1(L)+DZCBK - BI2(L)=BI2(L)+(DZCBK+0.5*(Z(K)+Z(K-1))*DZCB(K)) - ENDDO - - ENDDO - - RETURN - END SUBROUTINE CALEBI C C CHANGE RECORD @@ -52,16 +5,13 @@ C ** CALEBI CALCULATES THE EXTERNAL BUOYANCY INTEGRALS C USE GLOBAL IMPLICIT NONE - INTEGER::K,L,IPMC,LLCM - REAL::EPSILON,DBK,DZCBK + INTEGER::K,L,LLCM + REAL::DBK,DZCBK REAL*4 DZCB(KCM) REAL*4 BK(KCM) PARAMETER(LLCM=200) - REAL*4 BI1T(LLCM) - REAL*4 BI2T(LLCM) - REAL*4 BET(LLCM) DO L=2,LA diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEBI_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEBI_mpi.for new file mode 100644 index 000000000..0900366d2 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEBI_mpi.for @@ -0,0 +1,97 @@ + SUBROUTINE CALEBI_mpi +C +C CHANGE RECORD +C ** CALEBI CALCULATES THE EXTERNAL BUOYANCY INTEGRALS +C + USE GLOBAL + USE MPI + IMPLICIT NONE + INTEGER::K,L,LLCM + REAL::DBK,DZCBK + + REAL*4 DZCB(KCM) + REAL*4 BK(KCM) + + PARAMETER(LLCM=200) + + IF(.FALSE.)THEN + S2TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(DBK,DZCBK) + DO L=LMPI2,LMPILA + + BI1(L)=0. + BI2(L)=0. + BE(L)=0. + + DO K=1,KC + DZCB(K)=DZC(K)*B(L,K) + ENDDO + + DBK=0. + DO K=KC,1,-1 + DBK=DBK+DZCB(K) !DZC(K)*B(L,K) + BK(K)=DBK-0.5*DZCB(K) !DZC(K)*B(L,K) + ENDDO + + !Z(0)=0. + !Z(K)=Z(K-1)+DZC(K) + DO K=1,KC + BE(L) =BE(L)+DZCB(K) !DZC(K)*B(L,K) + DZCBK =DZC(K)*BK(K) + BI1(L)=BI1(L)+DZCBK + BI2(L)=BI2(L)+(DZCBK+0.5*(Z(K)+Z(K-1))*DZCB(K)) + ENDDO + + ENDDO + MPI_WTIMES(251)=MPI_WTIMES(251)+MPI_TOC(S2TIME) + + ELSE + S2TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + BI1(L)=0. + BI2(L)=0. + BE(L)=0. + ENDDO + MPI_WTIMES(251)=MPI_WTIMES(251)+MPI_TOC(S2TIME) + + S2TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + DZCB_2D(L,K)=DZC(K)*B(L,K) + ENDDO + ENDDO + MPI_WTIMES(252)=MPI_WTIMES(252)+MPI_TOC(S2TIME) + + S2TIME=MPI_TIC() + DBK_1D=0. + DO K=KC,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + DBK_1D(L)=DBK_1D(L)+DZCB_2D(L,K) + BK_2D(L,K)=DBK_1D(L)-0.5*DZCB_2D(L,K) + ENDDO + ENDDO + MPI_WTIMES(253)=MPI_WTIMES(253)+MPI_TOC(S2TIME) + + S2TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + BE(L) =BE(L)+DZCB_2D(L,K) + BI1(L)=BI1(L)+DZC(K)*BK_2D(L,K) + BI2(L)=BI2(L)+(DZC(K)*BK_2D(L,K)+ + & 0.5*(Z(K)+Z(K-1))*DZCB_2D(L,K)) + ENDDO + ENDDO + MPI_WTIMES(254)=MPI_WTIMES(254)+MPI_TOC(S2TIME) + ENDIF + + CALL broadcast_boundary(BE,ic) + CALL broadcast_boundary(BI1,ic) + CALL broadcast_boundary(BI2,ic) + + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP.for index e56b82c3d..fc5224536 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP.for @@ -446,7 +446,7 @@ C & U(L+1,K),U(L,K),DXV(LN),DXV(L),HP(L),CAC(L,K) C ENDDO C CLOSE(1) C ENDIF - 1111 FORMAT(3I5,10E13.4) +C1111 FORMAT(3I5,10E13.4) C C**********************************************************************C C @@ -960,7 +960,7 @@ C CLOSE(1) ENDIF C - 1112 FORMAT('N,NW,NS,I,J,K,NF,H,Q,QU,FUU,FVV=',/,2X,7I5,5E12.4) +C1112 FORMAT('N,NW,NS,I,J,K,NF,H,Q,QU,FUU,FVV=',/,2X,7I5,5E12.4) C C**********************************************************************C C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP2T.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP2T.for index 842868f60..fc674ac93 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP2T.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP2T.for @@ -21,7 +21,6 @@ C USE GLOBAL IMPLICIT NONE - INTEGER::LF,ithds INTEGER::L,K,LN,LS,ID,JD,KD,NWR,IU,JU,KU,LU,NS,LNW,LSE,LL INTEGER::LD,NMD,LHOST,LCHNU,LW,LE,LCHNV REAL::TMPANG,WU,WV,CACSUM,CFEFF,VEAST2,VWEST2,FCORE,FCORW @@ -89,32 +88,19 @@ C ** INITIALIZE EXTERNAL CORIOLIS-CURVATURE AND ADVECTIVE FLUX TERMS C C----------------------------------------------------------------------C C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - DO L=LF,LL + DO L=1,LC FCAXE(L)=0. FCAYE(L)=0. FXE(L)=0. FYE(L)=0. ENDDO -c - enddo C C C----------------------------------------------------------------------C C IF(IS2LMC.NE.1)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS,UHC,UHB,VHC,VHB) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) @@ -141,20 +127,10 @@ C ENDIF ENDDO ENDDO - enddo C ELSE !IF(IS2LMC.EQ.1)THEN C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS,UHC1,UHB1,VHC1,VHB1,UHC2,UHB2,VHC2,VHB2, -!$OMP& UHB1MX,UHB1MN,VHC1MX,VHC1MN,UHC1MX,UHC1MN,VHB1MX,VHB1MN, -!$OMP& UHB2MX,UHB2MN,VHC2MX,VHC2MN,UHC2MX,UHC2MN,VHB2MX,VHB2MN, -!$OMP& BOTT) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) @@ -264,7 +240,6 @@ C FVHJ(L,2)=0. ENDIF ENDDO - enddo ENDIF C C ADD RETURN FLOW MOMENTUM FLUX @@ -324,14 +299,8 @@ C----------------------------------------------------------------------C C C *** COMPUTE VERTICAL ACCELERATIONS C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LS,WU,WV) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LS=LSC(L) WU=0.5*DXYU(L)*(W(L,K)+W(L-1,K)) @@ -355,16 +324,13 @@ C ** BLOCK MOMENTUM FLUX ON LAND SIDE OF TRIANGULAR CELLS C IF(ITRICELL.GT.0)THEN DO K=1,KC - DO L=LF,LL + DO L=1,LA FUHU(L,K)=STCUV(L)*FUHU(L,K) FVHV(L,K)=STCUV(L)*FVHV(L,K) ENDDO ENDDO ENDIF -c - enddo C - C**********************************************************************C C C ** CALCULATE CORIOLIS AND CURVATURE ACCELERATION COEFFICIENTS @@ -377,14 +343,8 @@ C IF(ISDCCA.EQ.0)THEN C -!$OMP PARALLEL DO PRIVATE(LF,LL,LN) -!$OMP& REDUCTION(+:CACSUM) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LN=LNC(L) CAC(L,K)=( FCORC(L)*DXYP(L) @@ -396,9 +356,6 @@ c CACSUM=CACSUM+CAC(L,K) ENDDO ENDDO -c - enddo - C ELSE C @@ -427,7 +384,6 @@ C ENDDO CLOSE(1) ENDIF - ENDIF ! *** ENSURE FCAY & FCAX ARE RESET @@ -439,7 +395,6 @@ C FCAY(L,K)=0. ENDDO ENDDO - ENDIF ENDIF @@ -457,14 +412,8 @@ C ** STANDARD CALCULATION C IF(IS2LMC.EQ.0.AND.CACSUM.GT.1.E-7)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS,LNW,LSE) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) @@ -480,8 +429,6 @@ c ENDIF ENDDO ENDDO - enddo - C C----------------------------------------------------------------------C C @@ -527,7 +474,6 @@ C ENDIF ENDDO ENDIF - C C----------------------------------------------------------------------C C @@ -576,18 +522,11 @@ C ENDIF ENDDO ENDIF - C C----------------------------------------------------------------------C C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) @@ -603,9 +542,6 @@ c ENDIF ENDDO ENDDO -c - enddo - ! *** TREAT BC'S NEAR EDGES DO LL=1,NBCS @@ -628,7 +564,6 @@ c FY(L,K)=SAAY(L)*FY(L,K) ENDDO ENDDO - C C----------------------------------------------------------------------C C @@ -680,7 +615,6 @@ C CLOSE(1) ENDIF ENDIF - C C**********************************************************************C C @@ -734,8 +668,8 @@ C C ENDIF C - 1947 FORMAT(3I5,10E12.4) - 1948 FORMAT(15X,10E12.4) +C1947 FORMAT(3I5,10E12.4) +C1948 FORMAT(15X,10E12.4) C C**********************************************************************C C @@ -867,16 +801,10 @@ C C ** CALCULATE EXTERNAL ACCELERATIONS C C----------------------------------------------------------------------C - C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(ISDRY.GT.0)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN FCAXE(L)=FCAXE(L)+FCAX(L,K)*DZC(K) FCAYE(L)=FCAYE(L)+FCAY(L,K)*DZC(K) @@ -887,7 +815,7 @@ c ENDDO ELSE DO K=1,KC - DO L=LF,LL + DO L=2,LA FCAXE(L)=FCAXE(L)+FCAX(L,K)*DZC(K) FCAYE(L)=FCAYE(L)+FCAY(L,K)*DZC(K) FXE(L)=FXE(L)+FX(L,K)*DZC(K) @@ -904,7 +832,7 @@ C----------------------------------------------------------------------C C IF(KC.GT.1)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN FX(L,K)=FX(L,K)+SAAX(L)*(FWU(L,K)-FWU(L,K-1))*DZIC(K) FY(L,K)=FY(L,K)+SAAY(L)*(FWV(L,K)-FWV(L,K-1))*DZIC(K) @@ -922,7 +850,7 @@ C IF(MDCHH.GE.1.AND.ISCHAN.EQ.3)THEN C DO K=1,KC - DO L=LF,LL + DO L=2,LA QMCSOURX(L,K)=0. QMCSOURY(L,K)=0. QMCSINKX(L,K)=0. @@ -930,9 +858,6 @@ C ENDDO ENDDO ENDIF -c - enddo -C IF(MDCHH.GE.1.AND.ISCHAN.EQ.3)THEN C @@ -1098,13 +1023,8 @@ C IF(IINTPG.EQ.0)THEN C -!$OMP PARALLEL DO PRIVATE(LF,LL,LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KS - DO L=LF,LL + DO L=2,LA LS=LSC(L) FBBX(L,K)=SBX(L)*GP*HU(L)* & ( HU(L)*( (B(L,K+1)-B(L-1,K+1))*DZC(K+1) @@ -1118,8 +1038,6 @@ c & (BELV(L)-BELV(LS)+Z(K)*(HP(L)-HP(LS))) ) ENDDO ENDDO -c - enddo C ENDIF C @@ -1257,24 +1175,14 @@ C ** CALCULATE EXPLICIT INTERNAL U AND V SHEAR EQUATION TERMS C C----------------------------------------------------------------------C C - IF(KC.GT.1)THEN - L=1 - DU(L,KC)=0.0 - DV(L,KC)=0.0 - L=LC + DO L=1,LC DU(L,KC)=0.0 DV(L,KC)=0.0 - ENDIF -!$OMP PARALLEL DO PRIVATE(LF,LL,RCDZF) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - IF(KC.GT.1)THEN + ENDDO DO K=1,KS RCDZF=CDZF(K) - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN !DXYIU(L)=1./(DXU(L)*DYU(L)) DU(L,K)=RCDZF*( HU(L)*(U(L,K+1)-U(L,K))*DELTI @@ -1295,14 +1203,11 @@ C C IF(ISTL.EQ.2)THEN C IF(NWSER.GT.0)THEN - DO L=LF,LL + DO L=2,LA DU(L,KS)=DU(L,KS)-CDZU(KS)*TSX(L) DV(L,KS)=DV(L,KS)-CDZU(KS)*TSY(L) ENDDO ENDIF -c - enddo - C C ENDIF C @@ -1312,7 +1217,7 @@ C IF(N.LE.4)THEN C CLOSE(1) C ENDIF C - 1112 FORMAT('N,NW,NS,I,J,K,NF,H,Q,QU,FUU,FVV=',/,2X,7I5,5E12.4) +C1112 FORMAT('N,NW,NS,I,J,K,NF,H,Q,QU,FUU,FVV=',/,2X,7I5,5E12.4) C C**********************************************************************C C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP2T0.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP2T_mpi.for similarity index 79% rename from model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP2T0.for rename to model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP2T_mpi.for index b7093daba..e4cdd4951 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP2T0.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALEXP2T_mpi.for @@ -1,4 +1,4 @@ - SUBROUTINE CALEXP2T0 + SUBROUTINE CALEXP2T_mpi C C ** SUBROUTINE CALEXP2T CALCULATES EXPLICIT MOMENTUM EQUATION TERMS C ** USING A TWO TIME LEVEL SCHEME @@ -19,21 +19,20 @@ C C 2008-12 SANG YUK/PMC (DSLLC) CORRECTED THE EXPLICIT INTERNAL BUOYANCY FORCINGS C USE GLOBAL + USE MPI - IMPLICIT NONE - INTEGER::LF,ithds - INTEGER::L,K,LN,LS,ID,JD,KD,NWR,IU,JU,KU,LU,NS,LNW,LSE,LL - INTEGER::LD,NMD,LHOST,LCHNU,LW,LE,LCHNV - REAL::TMPANG,WU,WV,CACSUM,CFEFF,VEAST2,VWEST2,FCORE,FCORW - REAL::UNORT1,USOUT1,UNORT2,USOUT2,FCORN,FCORS,VTMPATU - REAL::UTMPATV,UMAGTMP,VMAGTMP,DZICK,DZICKC,DZPU,DZPV - REAL::RCDZF,TMPVAL,WVFACT,DETH,CI11H,CI12H,CI22H,DETU - REAL::CI11V,CI12V,CI21V,CI22V,CI21H,CI12U,CI21U,CI22U,DETV,CI11U - REAL::UHC,UHB,VHC,VHB,UHC1,UHB1,VHC1,VHB1,UHC2,UHB2,VHC2,VHB2 - REAL::UHB1MX,UHB1MN,VHC1MX,VHC1MN,UHC1MX,UHC1MN,VHB1MX - REAL::VHB1MN,UHB2MX,UHB2MN,VHC2MX,VHC2MN,UHC2MX,UHC2MN,VHB2MX - REAL::VHB2MN,BOTT,QMF,QUMF,VEAST1,VWEST1 - REAL::t02,t03,rtc + IMPLICIT NONE + INTEGER::L,K,LN,LS,ID,JD,KD,NWR,IU,JU,KU,LU,NS,LNW,LSE,LL + INTEGER::LD,NMD,LHOST,LCHNU,LW,LE,LCHNV + REAL::TMPANG,WU,WV,CACSUM,CFEFF,VEAST2,VWEST2,FCORE,FCORW + REAL::UNORT1,USOUT1,UNORT2,USOUT2,FCORN,FCORS,VTMPATU + REAL::UTMPATV,UMAGTMP,VMAGTMP,DZICK,DZICKC,DZPU,DZPV + REAL::RCDZF,TMPVAL,WVFACT,DETH,CI11H,CI12H,CI22H,DETU + REAL::CI11V,CI12V,CI21V,CI22V,CI21H,CI12U,CI21U,CI22U,DETV,CI11U + REAL::UHC,UHB,VHC,VHB,UHC1,UHB1,VHC1,VHB1,UHC2,UHB2,VHC2,VHB2 + REAL::UHB1MX,UHB1MN,VHC1MX,VHC1MN,UHC1MX,UHC1MN,VHB1MX + REAL::VHB1MN,UHB2MX,UHB2MN,VHC2MX,VHC2MN,UHC2MX,UHC2MN,VHB2MX + REAL::VHB2MN,BOTT,QMF,QUMF,VEAST1,VWEST1 REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::DZPC REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TMPVEC1 @@ -66,7 +65,6 @@ C DZPC=0. ENDIF C -c t02=rtc() IF(ISDYNSTP.EQ.0)THEN DELT=DT ELSE @@ -79,7 +77,7 @@ C C DELTI=1./DELT C - IF(N.EQ.1.AND.DEBUG)THEN + IF(MYRANK.EQ.0.AND.N.EQ.1.AND.DEBUG)THEN OPEN(1,FILE='MFLUX.DIA') CLOSE(1,STATUS='DELETE') ENDIF @@ -91,33 +89,26 @@ C ** INITIALIZE EXTERNAL CORIOLIS-CURVATURE AND ADVECTIVE FLUX TERMS C C----------------------------------------------------------------------C C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - DO L=LF,LL + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC FCAXE(L)=0. FCAYE(L)=0. FXE(L)=0. FYE(L)=0. ENDDO -c - enddo -C + MPI_WTIMES(301)=MPI_WTIMES(301)+MPI_TOC(S1TIME) +C C C----------------------------------------------------------------------C C + IF(IS2LMC.NE.1)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS,UHC,UHB,VHC,VHB, -!$OMP& WU,WV) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c + S1TIME=MPI_TIC() DO K=1,KC - DO L=LF,LL +!$OMP PARALLEL DO PRIVATE(LN,LS,UHC,UHB,VHC,VHB) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) @@ -128,66 +119,31 @@ c C FUHU(L,K)=MAX(UHB,0.)*U(L, K) ! *** CELL CENTERED & +MIN(UHB,0.)*U(L+1,K) -c IF(UHB.GE.0.) THEN -c FUHU(L,K)=UHB*U(L, K) -c ELSE -c FUHU(L,K)=UHB*U(L+1, K) -c ENDIF FVHU(L,K)=MAX(VHC,0.)*U(LS, K) & +MIN(VHC,0.)*U(L, K) -c IF(VHC.GE.0.) THEN -c FVHU(L,K)=VHC*U(LS, K) -c ELSE -c FVHU(L,K)=VHC*U(L, K) -c ENDIF C FVHV(L,K)=MAX(VHB,0.)*V(L, K) ! *** CELL CENTERED & +MIN(VHB,0.)*V(LN, K) -c IF(VHB.GE.0.) THEN -c FVHV(L,K)=VHB*V(L , K) -c ELSE -c FVHV(L,K)=VHB*V(LN, K) -c ENDIF FUHV(L,K)=MAX(UHC,0.)*V(L-1,K) & +MIN(UHC,0.)*V(L, K) -c IF(UHC.GE.0.) THEN -c FUHV(L,K)=UHC*V(L-1, K) -c ELSE -c FUHV(L,K)=UHC*V(L, K) -c ENDIF + ELSE + FUHU(L,K)=0. + FVHU(L,K)=0. + FVHV(L,K)=0. + FUHV(L,K)=0. + ENDIF ENDDO -c ENDDO -c -c DO K=1,KS - IF(K.LE.KS) THEN - DO L=LF,LL - LS=LSC(L) - WU=0.5*DXYU(L)*(W(L,K)+W(L-1,K)) - WV=0.5*DXYV(L)*(W(L,K)+W(LS,K)) - - FWU(L,K)=MAX(WU,0.)*U(L,K) - & +MIN(WU,0.)*U(L,K+1) - FWV(L,K)=MAX(WV,0.)*V(L,K) - & +MIN(WV,0.)*V(L,K+1) - - ENDDO - ENDIF - ENDDO - enddo + ENDDO + MPI_WTIMES(302)=MPI_WTIMES(302)+MPI_TOC(S1TIME) C ELSE !IF(IS2LMC.EQ.1)THEN C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS,UHC1,UHB1,VHC1,VHB1,UHC2,UHB2,VHC2,VHB2, -!$OMP& UHB1MX,UHB1MN,VHC1MX,VHC1MN,UHC1MX,UHC1MN,VHB1MX,VHB1MN, -!$OMP& UHB2MX,UHB2MN,VHC2MX,VHC2MN,UHC2MX,UHC2MN,VHB2MX,VHB2MN, -!$OMP& BOTT, -!$OMP& WU,WV) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LN,LS,UHC1,UHB1,VHC1,VHB1,UHC2,UHB2,VHC2,VHB2 +!$OMP+ ,UHB1MX,UHB1MN,VHC1MX,VHC1MN,VHB1MX,VHB1MN,UHB2MX,UHB2MN,VHC2MX +!$OMP+ ,VHC2MN,UHC2MX,UHC2MN,VHB2MX,VHB2MN,BOTT) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) UHC1=0.5*(UHDY(L,1)+UHDY(LS,1)) @@ -294,30 +250,14 @@ C & +VHB2MN*MIN(VHB2,0.)*V(LN,2) FUHJ(L,2)=0. FVHJ(L,2)=0. + ENDIF ENDDO -c - DO K=1,KS - DO L=LF,LL - LS=LSC(L) - WU=0.5*DXYU(L)*(W(L,K)+W(L-1,K)) - WV=0.5*DXYV(L)*(W(L,K)+W(LS,K)) - - FWU(L,K)=MAX(WU,0.)*U(L,K) - & +MIN(WU,0.)*U(L,K+1) - FWV(L,K)=MAX(WV,0.)*V(L,K) - & +MIN(WV,0.)*V(L,K+1) - - ENDDO - ENDDO -c - enddo + MPI_WTIMES(329)=MPI_WTIMES(329)+MPI_TOC(S1TIME) ENDIF -c t03=rtc()-t02 -c write(6,*) 'Timing 1----->',t03*1.e3,nthds,IS2LMC - C C ADD RETURN FLOW MOMENTUM FLUX C + S1TIME=MPI_TIC() DO NWR=1,NQWR IF(NQWRMFU(NWR).GT.0)THEN IU=IQWRU(NWR) @@ -354,64 +294,61 @@ C IF(NQWRMFD(NWR).EQ.-2) FVHJ(LD ,KD)=QUMF IF(NQWRMFD(NWR).EQ.-3) FUHJ(LD+1 ,KD)=QUMF IF(NQWRMFD(NWR).EQ.-4) FVHJ(LNC(LD),KD)=QUMF -C IF(N.LE.4.AND.DEBUG)THEN -C WRITE(1,1112)N,NWR,NS,ID,JD,KD,NQWRMFD(NWR),H1P(LD),QMF, -C & QUMF,FUHJ(LD,KD),FVHJ(LD,KD) -C ENDIF ENDIF ENDDO -c t03=rtc()-t02 -c write(6,*) 'Timing 2----->',t03*1.e3,nthds -C -C ** HARDWIRE FOR PEACH BOTTOM -C -C DO K=1,KC -C FVHV(535,K)=700./H1P(535) -C ENDDO -C -C ** END HARDWIRE FOR PEACH BOTTOM + MPI_WTIMES(330)=MPI_WTIMES(330)+MPI_TOC(S1TIME) C C----------------------------------------------------------------------C C C *** COMPUTE VERTICAL ACCELERATIONS C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LS,WU,WV) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c -c DO K=1,KS -c DO L=LF,LL -c LS=LSC(L) -c WU=0.5*DXYU(L)*(W(L,K)+W(L-1,K)) -c WV=0.5*DXYV(L)*(W(L,K)+W(LS,K)) + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LS,WU,WV) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LS=LSC(L) + WU=0.5*DXYU(L)*(W(L,K)+W(L-1,K)) + WV=0.5*DXYV(L)*(W(L,K)+W(LS,K)) -c FWU(L,K)=MAX(WU,0.)*U(L,K) -c & +MIN(WU,0.)*U(L,K+1) -c FWV(L,K)=MAX(WV,0.)*V(L,K) -c & +MIN(WV,0.)*V(L,K+1) -c -c ENDDO -c ENDDO + FWU(L,K)=MAX(WU,0.)*U(L,K) + & +MIN(WU,0.)*U(L,K+1) + FWV(L,K)=MAX(WV,0.)*V(L,K) + & +MIN(WV,0.)*V(L,K+1) + ELSE + FWU(L,K)=0. + FWV(L,K)=0. + ENDIF + + ENDDO + ENDDO + MPI_WTIMES(303)=MPI_WTIMES(303)+MPI_TOC(S1TIME) C C**********************************************************************C C C ** BLOCK MOMENTUM FLUX ON LAND SIDE OF TRIANGULAR CELLS C + S1TIME=MPI_TIC() IF(ITRICELL.GT.0)THEN DO K=1,KC - DO L=LF,LL +!$OMP PARALLEL DO + DO L=LMPI1,LMPILA FUHU(L,K)=STCUV(L)*FUHU(L,K) FVHV(L,K)=STCUV(L)*FVHV(L,K) ENDDO ENDDO ENDIF -c - enddo -C -c t03=rtc()-t02 -c write(6,*) 'Timing 3----->',t03*1.e3,nthds + MPI_WTIMES(304)=MPI_WTIMES(304)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(FUHU,ic) + CALL broadcast_boundary_array(FVHU,ic) + CALL broadcast_boundary_array(FVHV,ic) + CALL broadcast_boundary_array(FUHV,ic) + CALL broadcast_boundary_array(FWU,ic) + CALL broadcast_boundary_array(FWV,ic) + MPI_WTIMES(331)=MPI_WTIMES(331)+MPI_TOC(S1TIME) +C C**********************************************************************C C C ** CALCULATE CORIOLIS AND CURVATURE ACCELERATION COEFFICIENTS @@ -421,38 +358,38 @@ C CACSUM=0. CFMAX=CF IF(ISCURVATURE)THEN - IF(ISDCCA.EQ.0)THEN C -!$OMP PARALLEL DO PRIVATE(LF,LL,LN) -!$OMP& REDUCTION(+:CACSUM) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO K=1,KC - DO L=LF,LL + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LN) REDUCTION(+:CACSUM) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN LN=LNC(L) CAC(L,K)=( FCORC(L)*DXYP(L) & +0.5*SNLT*(V(LN,K)+V(L,K))*DYDI(L) & -0.5*SNLT*(U(L+1,K)+U(L,K))*DXDJ(L) )*HP(L) - ENDDO - ENDDO - DO K=1,KC - DO L=LF,LL + ELSE + CAC(L,K)=0.0 ! *** DSLLC SINGLE LINE + ENDIF CACSUM=CACSUM+CAC(L,K) ENDDO ENDDO -c - enddo -c t03=rtc()-t02 -c write(6,*) 'Timing 40---->',t03*1.e3,nthds + MPI_WTIMES(305)=MPI_WTIMES(305)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(CAC,ic) + CALL MPI_ALLREDUCE(CACSUM,MPI_R4,1,MPI_REAL,MPI_SUM, + & MPI_COMM_WORLD,IERR) + CACSUM=MPI_R4 + MPI_WTIMES(332)=MPI_WTIMES(332)+MPI_TOC(S1TIME) C ELSE -C C DO K=1,KC - DO L=2,LA +!$OMP PARALLEL DO PRIVATE(LN,CFEFF) REDUCTION(+:CACSUM) +!$OMP+ REDUCTION(MAX:CFMAX) + DO L=LMPI2,LMPILA LN=LNC(L) CAC(L,K)=( FCORC(L)*DXYP(L) & +0.5*SNLT*(V(LN,K)+V(L,K))*DYDI(L) @@ -462,8 +399,14 @@ C CACSUM=CACSUM+CAC(L,K) ENDDO ENDDO -C - IF(N.EQ.NTS.AND.DEBUG)THEN + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(CAC,ic) + CALL MPI_ALLREDUCE(CACSUM,MPI_R4,1,MPI_REAL,MPI_SUM, + & MPI_COMM_WORLD,IERR) + CACSUM=MPI_R4 + MPI_WTIMES(333)=MPI_WTIMES(333)+MPI_TOC(S1TIME) +C + IF(MYRANK.EQ.0.AND.N.EQ.NTS.AND.DEBUG)THEN OPEN(1,FILE='CORC1.DIA') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='CORC1.DIA') @@ -475,23 +418,22 @@ C ENDDO CLOSE(1) ENDIF -c t03=rtc()-t02 -c write(6,*) 'Timing 4----->',t03*1.e3,nthds + ENDIF ! *** ENSURE FCAY & FCAX ARE RESET + S1TIME=MPI_TIC() CACSUM=ABS(CACSUM) IF(CACSUM.LT.1.E-7)THEN DO K=1,KC - DO L=2,LA +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA FCAX(L,K)=0. FCAY(L,K)=0. ENDDO ENDDO -c t03=rtc()-t02 -c write(6,*) 'Timing 5----->',t03*1.e3,nthds ENDIF - + MPI_WTIMES(306)=MPI_WTIMES(306)+MPI_TOC(S1TIME) ENDIF C 1111 FORMAT(3I5,10E13.4) @@ -507,14 +449,11 @@ C ** STANDARD CALCULATION C IF(IS2LMC.EQ.0.AND.CACSUM.GT.1.E-7)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS,LNW,LSE) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c + S1TIME=MPI_TIC() DO K=1,KC - DO L=LF,LL +!$OMP PARALLEL DO PRIVATE(LN,LS,LNW,LSE) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) LNW=LNWC(L) @@ -523,22 +462,26 @@ c & +CAC(L-1,K)*(V(LNW,K)+V(L-1,K))) FCAY(L,K)=0.25*SCAY(L)*(CAC(L,K)*(U(L+1,K)+U(L,K)) & +CAC(LS,K)*(U(LSE,K)+U(LS,K))) + ELSE + FCAX(L,K)=0. + FCAY(L,K)=0. + ENDIF ENDDO ENDDO - enddo -c t03=rtc()-t02 -c write(6,*) 'Timing 6----->',t03*1.e3,nthds -C + MPI_WTIMES(307)=MPI_WTIMES(307)+MPI_TOC(S1TIME) +C C----------------------------------------------------------------------C C C ** MODIFICATION FOR TYPE 2 OPEN BOUNDARIES C - DO K=1,KC + S1TIME=MPI_TIC() DO LL=1,NPBW IF(ISPBW(LL).EQ.2)THEN L=LPBW(LL)+1 LN=LNC(L) + DO K=1,KC FCAX(L,K)=0.5*SCAX(L)*CAC(L,K)*(V(LN,K)+V(L,K)) + ENDDO ENDIF ENDDO C @@ -546,14 +489,18 @@ C IF(ISPBE(LL).EQ.2)THEN L=LPBE(LL) LNW=LNWC(L) + DO K=1,KC FCAX(L,K)=0.5*SCAX(L)*CAC(L-1,K)*(V(LNW,K)+V(L-1,K)) + ENDDO ENDIF ENDDO C DO LL=1,NPBS IF(ISPBS(LL).EQ.2)THEN L=LNC(LPBS(LL)) + DO K=1,KC FCAY(L,K)=0.5*SCAY(L)*CAC(L,K)*(U(L+1,K)+U(L,K)) + ENDDO ENDIF ENDDO C @@ -562,13 +509,14 @@ C L=LPBN(LL) LS=LSC(L) LSE=LSEC(L) + DO K=1,KC FCAY(L,K)=0.5*SCAY(L)*CAC(LS,K)*(U(LSE,K)+U(LS,K)) + ENDDO ENDIF ENDDO - ENDDO + MPI_WTIMES(308)=MPI_WTIMES(308)+MPI_TOC(S1TIME) + ENDIF -c t03=rtc()-t02 -c write(6,*) 'Timing 7----->',t03*1.e3,nthds C C----------------------------------------------------------------------C C @@ -577,7 +525,11 @@ C *** PMC - USED TO BE ONLY FOR 2 LAYERS, JH ALLOWED ANY # OF LAYERS C IF(IS2LMC.EQ.1.AND.CACSUM.GT.1.E-7)THEN CJH IF(KC.EQ.2)THEN - DO L=2,LA + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LN,LS,LNW,LSE,VEAST1,VWEST1,VEAST2,VWEST2, +!$OMP+ FCORE,FCORW,UNORT1,USOUT1,UNORT2,USOUT2,FCORN,FCORS) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) LNW=LNWC(L) @@ -613,66 +565,63 @@ C & CAC(L,2)*UNORT2+FCORN & +CAC(LS,2)*USOUT2+FCORS) C + ENDIF ENDDO -c t03=rtc()-t02 -c write(6,*) 'Timing 8----->',t03*1.e3,nthds + MPI_WTIMES(309)=MPI_WTIMES(309)+MPI_TOC(S1TIME) ENDIF C C----------------------------------------------------------------------C C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c + S1TIME=MPI_TIC() DO K=1,KC - DO L=LF,LL +!$OMP PARALLEL DO PRIVATE(LN,LS) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) - !HRUO(L)=SUBO(L)*DYU(L)*DXIU(L) - !HRXYU(L)=DXU(L)/DYU(L) ! PMC - NOT USED FX(L,K)=(FUHU(L,K)-FUHU(L-1,K)+FVHU(LN,K)-FVHU(L,K) & +FUHJ(L,K) ) FY(L,K)=(FUHV(L+1,K)-FUHV(L,K)+FVHV(L,K)-FVHV(LS,K) & +FVHJ(L,K) ) + ELSE + FX(L,K)=0. + FY(L,K)=0. + ENDIF ENDDO ENDDO -c - enddo -c t03=rtc()-t02 -c write(6,*) 'Timing 9----->',t03*1.e3,nthds - + MPI_WTIMES(310)=MPI_WTIMES(310)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() ! *** TREAT BC'S NEAR EDGES DO LL=1,NBCS ! *** BC CELL L=LBCS(LL) - DO K=1,KC - FX(L,K)=SAAX(L)*FX(L,K) - FY(L,K)=SAAY(L)*FY(L,K) - ENDDO + !DO K=1,KC + FX(L,1:KC)=SAAX(L)*FX(L,1:KC) + FY(L,1:KC)=SAAY(L)*FY(L,1:KC) + !ENDDO ! *** EAST/WEST ADJACENT CELL L=LBERC(LL) - DO K=1,KC - FX(L,K)=SAAX(L)*FX(L,K) - ENDDO + !DO K=1,KC + FX(L,1:KC)=SAAX(L)*FX(L,1:KC) + !ENDDO ! *** NORTH/SOUTH ADJACENT CELL L=LBNRC(LL) - DO K=1,KC - FY(L,K)=SAAY(L)*FY(L,K) - ENDDO + !DO K=1,KC + FY(L,1:KC)=SAAY(L)*FY(L,1:KC) + !ENDDO ENDDO -c t03=rtc()-t02 -c write(6,*) 'Timing 10---->',t03*1.e3,nthds + MPI_WTIMES(311)=MPI_WTIMES(311)+MPI_TOC(S1TIME) C C----------------------------------------------------------------------C C C ** CORIOLIS-CURVATURE DIAGNOSTICS C + S1TIME=MPI_TIC() IF(ISDCCA.EQ.1.AND.DEBUG)THEN - IF(N.EQ.NTS)THEN + IF(MYRANK.EQ.0.AND.N.EQ.NTS)THEN OPEN(1,FILE='CORC2.DIA') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='CORC2.DIA') @@ -688,7 +637,7 @@ C CLOSE(1) ENDIF C - IF(N.EQ.NTS)THEN + IF(MYRANK.EQ.0.AND.N.EQ.NTS)THEN OPEN(1,FILE='CORC3.DIA') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='CORC3.DIA') @@ -704,7 +653,7 @@ C CLOSE(1) ENDIF C - IF(N.EQ.NTS)THEN + IF(MYRANK.EQ.0.AND.N.EQ.NTS)THEN OPEN(1,FILE='CORC4.DIA') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='CORC4.DIA') @@ -717,8 +666,7 @@ C CLOSE(1) ENDIF ENDIF -c t03=rtc()-t02 -c write(6,*) 'Timing 11---->',t03*1.e3,nthds,ISVEG,ISHDMF + MPI_WTIMES(312)=MPI_WTIMES(312)+MPI_TOC(S1TIME) C C**********************************************************************C C @@ -726,15 +674,20 @@ C ** ADD VEGETATION DRAG TO HORIZONTAL ADVECTIVE ACCELERATIONS C C----------------------------------------------------------------------C C + S1TIME=MPI_TIC() IF(ISVEG.GE.1)THEN C - DO L=1,LC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC FXVEGE(L)=0. FYVEGE(L)=0. ENDDO C DO K=1,KC - DO L=2,LA +!$OMP PARALLEL DO PRIVATE(LW,LE,LS,LN,LNW,LSE, +!$OMP+ VTMPATU,UTMPATV,UMAGTMP,VMAGTMP) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN LW=L-1 LE=L+1 LS=LSC(L) @@ -749,27 +702,33 @@ C FYVEG(L,K)=VMAGTMP*SVB(L)*DXYV(L)*FYVEG(L,K) FXVEGE(L)=FXVEGE(L)+FXVEG(L,K)*DZC(K) FYVEGE(L)=FYVEGE(L)+FYVEG(L,K)*DZC(K) + ENDIF ENDDO ENDDO C DO K=1,KC - DO L=2,LA +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN FXVEG(L,K)=FXVEG(L,K)*U(L,K) FYVEG(L,K)=FYVEG(L,K)*V(L,K) FX(L,K)=FX(L,K)+FXVEG(L,K)-FXVEGE(L)*U(L,K) FY(L,K)=FY(L,K)+FYVEG(L,K)-FYVEGE(L)*V(L,K) + ENDIF ENDDO ENDDO C - DO L=2,LA +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA FXVEGE(L)=DXYIU(L)*FXVEGE(L)/HU(L) FYVEGE(L)=DXYIV(L)*FYVEGE(L)/HV(L) ENDDO C ENDIF + MPI_WTIMES(313)=MPI_WTIMES(313)+MPI_TOC(S1TIME) C - 1947 FORMAT(3I5,10E12.4) - 1948 FORMAT(15X,10E12.4) +C1947 FORMAT(3I5,10E12.4) +C1948 FORMAT(15X,10E12.4) C C**********************************************************************C C @@ -777,16 +736,21 @@ C ** ADD HORIZONTAL MOMENTUM DIFFUSION TO ADVECTIVE ACCELERATIONS C C----------------------------------------------------------------------C C + S1TIME=MPI_TIC() IF(ISHDMF.GE.1)THEN C DO K=1,KC - DO L=2,LA +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN FX(L,K)=FX(L,K)-(FMDUX(L,K)+FMDUY(L,K)) FY(L,K)=FY(L,K)-(FMDVX(L,K)+FMDVY(L,K)) + ENDIF ENDDO ENDDO C ENDIF + MPI_WTIMES(314)=MPI_WTIMES(314)+MPI_TOC(S1TIME) C C**********************************************************************C C @@ -796,55 +760,66 @@ C ** DISTRIBUTE OVER SURFACE LAYER IF ISBODYF=2 C C----------------------------------------------------------------------C C + S1TIME=MPI_TIC() IF(ISBODYF.EQ.1)THEN C DO K=1,KC DZICK=1./DZC(K) - DO L=2,LA +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA FX(L,K)=FX(L,K)-DYU(L)*HU(L)*FBODYFX(L) FY(L,K)=FY(L,K)-DXV(L)*HV(L)*FBODYFY(L) ENDDO ENDDO C ENDIF + MPI_WTIMES(315)=MPI_WTIMES(315)+MPI_TOC(S1TIME) C + S1TIME=MPI_TIC() IF(ISBODYF.EQ.2)THEN C DZICKC=1./DZC(KC) - DO L=2,LA +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA FX(L,KC)=FX(L,KC)-DZICKC*DYU(L)*HU(L)*FBODYFX(L) FY(L,KC)=FY(L,KC)-DZICKC*DXV(L)*HV(L)*FBODYFY(L) ENDDO C ENDIF + MPI_WTIMES(316)=MPI_WTIMES(316)+MPI_TOC(S1TIME) C C**********************************************************************C C C ** ADD EXPLICIT NONHYDROSTATIC PRESSURE C + S1TIME=MPI_TIC() IF(KC.GT.1.AND.ISPNHYDS.GE.1) THEN C TMPVAL=2./(DZC(1)+DZC(2)) - DO L=2,LA +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA DZPC(L,1)=TMPVAL*(PNHYDS(L,2)-PNHYDS(L,1)) ENDDO C TMPVAL=2./(DZC(KC)+DZC(KC-1)) - DO L=2,LA +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA DZPC(L,KC)=TMPVAL*(PNHYDS(L,KC)-PNHYDS(L,KC-1)) ENDDO IF(KC.GE.3)THEN DO K=2,KS TMPVAL=2./(DZC(K+1)+2.*DZC(K)+DZC(K-1)) - DO L=2,LA +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA DZPC(L,K)=TMPVAL*(PNHYDS(L,K+1)-PNHYDS(L,K-1)) ENDDO ENDDO ENDIF C DO K=1,KC - DO L=2,LA +!$OMP PARALLEL DO PRIVATE(LS,DZPU,DZPV) + DO L=LMPI2,LMPILA LS=LSC(L) DZPU=0.5*(DZPC(L,K)+DZPC(L-1,K)) DZPV=0.5*(DZPC(L,K)+DZPC(LS ,K)) @@ -858,12 +833,14 @@ C ENDDO C ENDIF + MPI_WTIMES(317)=MPI_WTIMES(317)+MPI_TOC(S1TIME) C C----------------------------------------------------------------------C C C ** ADD NET WAVE REYNOLDS STRESSES TO EXTERNAL ADVECTIVE ACCEL. C C *** DSLLC BEGIN BLOCK + S1TIME=MPI_TIC() IF(ISWAVE.EQ.2)THEN C IF(N.LT.NTSWV)THEN @@ -873,14 +850,28 @@ C WVFACT=1.0 ENDIF C + IF(ISDRY.GT.0)THEN DO K=1,KC - DO L=2,LA +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN FX(L,K)=FX(L,K)+WVFACT*SAAX(L)*FXWAVE(L,K) FY(L,K)=FY(L,K)+WVFACT*SAAY(L)*FYWAVE(L,K) + ENDIF + ENDDO + ENDDO + ELSE + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FX(L,K)=FX(L,K)+WVFACT*SAAX(L)*FXWAVE(L,K) + FY(L,K)=FY(L,K)+WVFACT*SAAY(L)*FYWAVE(L,K) ENDDO ENDDO + ENDIF C ENDIF + MPI_WTIMES(318)=MPI_WTIMES(318)+MPI_TOC(S1TIME) C *** DSLLC END BLOCK C C**********************************************************************C @@ -888,66 +879,71 @@ C C ** CALCULATE EXTERNAL ACCELERATIONS C C----------------------------------------------------------------------C -c t03=rtc()-t02 -c write(6,*) 'Timing 12---->',t03*1.e3,nthds -C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - IF(KC.GT.1)THEN -C -C**********************************************************************C -C -C ** COMPLETE CALCULATION OF INTERNAL ADVECTIVE ACCELERATIONS -C -C----------------------------------------------------------------------C C + S1TIME=MPI_TIC() + IF(ISDRY.GT.0)THEN !! ISDRY = 99 DO K=1,KC - DO L=LF,LL +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN FCAXE(L)=FCAXE(L)+FCAX(L,K)*DZC(K) FCAYE(L)=FCAYE(L)+FCAY(L,K)*DZC(K) FXE(L)=FXE(L)+FX(L,K)*DZC(K) FYE(L)=FYE(L)+FY(L,K)*DZC(K) - FX(L,K)=FX(L,K)+SAAX(L)*(FWU(L,K)-FWU(L,K-1))*DZIC(K) - FY(L,K)=FY(L,K)+SAAY(L)*(FWV(L,K)-FWV(L,K-1))*DZIC(K) + ENDIF ENDDO ENDDO ELSE DO K=1,KC - DO L=LF,LL - FCAXE(L)=FCAXE(L)+FCAX(L,K)*DZC(K) - FCAYE(L)=FCAYE(L)+FCAY(L,K)*DZC(K) - FXE(L)=FXE(L)+FX(L,K)*DZC(K) - FYE(L)=FYE(L)+FY(L,K)*DZC(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FCAXE(L)=FCAXE(L)+FCAX(L,K)*DZC(K) + FCAYE(L)=FCAYE(L)+FCAY(L,K)*DZC(K) + FXE(L)=FXE(L)+FX(L,K)*DZC(K) + FYE(L)=FYE(L)+FY(L,K)*DZC(K) ENDDO - ENDDO + ENDDO ENDIF + MPI_WTIMES(319)=MPI_WTIMES(319)+MPI_TOC(S1TIME) C C**********************************************************************C C +C ** COMPLETE CALCULATION OF INTERNAL ADVECTIVE ACCELERATIONS +C +C----------------------------------------------------------------------C +C + S1TIME=MPI_TIC() + IF(KC.GT.1)THEN + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + FX(L,K)=FX(L,K)+SAAX(L)*(FWU(L,K)-FWU(L,K-1))*DZIC(K) + FY(L,K)=FY(L,K)+SAAY(L)*(FWV(L,K)-FWV(L,K-1))*DZIC(K) + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(320)=MPI_WTIMES(320)+MPI_TOC(S1TIME) +C +C**********************************************************************C +C C ** ADD SUBGRID SCALE CHANNEL VIRTURAL MOMENTUM SOURCES AND SINKS C C----------------------------------------------------------------------C C + S1TIME=MPI_TIC() IF(MDCHH.GE.1.AND.ISCHAN.EQ.3)THEN C DO K=1,KC - DO L=LF,LL +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA QMCSOURX(L,K)=0. QMCSOURY(L,K)=0. QMCSINKX(L,K)=0. QMCSINKY(L,K)=0. ENDDO ENDDO - ENDIF -c - enddo -C -c t03=rtc()-t02 -c write(6,*) 'Timing 13---->',t03*1.e3,nthds - IF(MDCHH.GE.1.AND.ISCHAN.EQ.3)THEN C DO NMD=1,MDCHH C @@ -1062,7 +1058,8 @@ C ENDDO C DO K=1,KC - DO L=2,LA +!$OMP PARALLEL DO PRIVATE(LN,TMPVAL) + DO L=LMPI2,LMPILA IF(QMCSOURX(L,K).NE.0.0)THEN TMPVAL=SUB(L)+SUB(L+1) TMPVAL=MAX(TMPVAL,1.0) @@ -1092,9 +1089,8 @@ C ENDDO ENDDO C -c t03=rtc()-t02 -c write(6,*) 'Timing 20---->',t03*1.e3,nthds,BSC,IINTPG ENDIF + MPI_WTIMES(321)=MPI_WTIMES(321)+MPI_TOC(S1TIME) C C**********************************************************************C C @@ -1108,17 +1104,20 @@ c IINTPG=0 C C ORIGINAL C + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(B,ic) + CALL broadcast_boundary(BELV,ic) + CALL broadcast_boundary(HP,ic) + MPI_WTIMES(334)=MPI_WTIMES(334)+MPI_TOC(S1TIME) +C IF(BSC.GT.1.E-6)THEN - + + S1TIME=MPI_TIC() IF(IINTPG.EQ.0)THEN C -!$OMP PARALLEL DO PRIVATE(LF,LL,LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KS - DO L=LF,LL +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA LS=LSC(L) FBBX(L,K)=SBX(L)*GP*HU(L)* & ( HU(L)*( (B(L,K+1)-B(L-1,K+1))*DZC(K+1) @@ -1132,16 +1131,17 @@ c & (BELV(L)-BELV(LS)+Z(K)*(HP(L)-HP(LS))) ) ENDDO ENDDO -c - enddo C ENDIF -C + MPI_WTIMES(322)=MPI_WTIMES(322)+MPI_TOC(S1TIME) +C C *** JACOBIAN C IF(IINTPG.EQ.1.)THEN K=1 - DO L=2,LA + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA LS=LSC(L) FBBX(L,K)=SBX(L)*GP*HU(L)* & ( 0.5*HU(L)*( (B(L,K+2)-B(L-1,K+2))*DZC(K+2) @@ -1163,10 +1163,13 @@ C & -0.5*(B(L,K )-B(L,K )+B(LS ,K )-B(LS ,K ))* & (BELV(L)-BELV(LS )+Z(K-1)*(HP(L)-HP(LS ))) ) ENDDO -C + MPI_WTIMES(323)=MPI_WTIMES(323)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() IF(KC.GT.2)THEN K=KS - DO L=2,LA +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA LS=LSC(L) FBBX(L,K)=SBX(L)*GP*HU(L)* & ( 0.5*HU(L)*( (B(L,K+1)-B(L-1,K+1))*DZC(K+1) @@ -1188,10 +1191,13 @@ C & (BELV(L)-BELV(LS )+Z(K-1)*(HP(L)-HP(LS ))) ) ENDDO ENDIF -C + MPI_WTIMES(324)=MPI_WTIMES(324)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() IF(KC.GT.3)THEN DO K=1,KS - DO L=2,LA +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA LS=LSC(L) FBBX(L,K)=SBX(L)*GP*HU(L)* & ( 0.5*HU(L)*( (B(L,K+2)-B(L-1,K+2))*DZC(K+2) @@ -1214,15 +1220,18 @@ C ENDDO ENDDO ENDIF + MPI_WTIMES(325)=MPI_WTIMES(325)+MPI_TOC(S1TIME) C - ENDIF + ENDIF C C FINITE VOLUME C IF(IINTPG.EQ.2)THEN C + S1TIME=MPI_TIC() DO K=1,KS - DO L=2,LA +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA LS=LSC(L) FBBX(L,K)=SBX(L)*GP*HU(L)* & ( ( HP(L)*B(L,K+1)-HP(L-1)*B(L-1,K+1) )*DZC(K+1) @@ -1244,10 +1253,9 @@ C & +HP(LS)*ZZ(K+1)*B(LS ,K+1)-HP(LS)*ZZ(K)*B(LS ,K) ) ENDDO ENDDO + MPI_WTIMES(326)=MPI_WTIMES(326)+MPI_TOC(S1TIME) C ENDIF -c t03=rtc()-t02 -c write(6,*) 'Timing 41---->',t03*1.e3,nthds ENDIF ! *** END OF BOUYANCY C C IF(N.EQ.1)THEN @@ -1273,23 +1281,18 @@ C ** CALCULATE EXPLICIT INTERNAL U AND V SHEAR EQUATION TERMS C C----------------------------------------------------------------------C C + S1TIME=MPI_TIC() IF(KC.GT.1)THEN - L=1 +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC DU(L,KC)=0.0 DV(L,KC)=0.0 - L=LC - DU(L,KC)=0.0 - DV(L,KC)=0.0 - ENDIF -!$OMP PARALLEL DO PRIVATE(LF,LL,RCDZF) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - IF(KC.GT.1)THEN + ENDDO DO K=1,KS RCDZF=CDZF(K) - DO L=LF,LL +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN !DXYIU(L)=1./(DXU(L)*DYU(L)) DU(L,K)=RCDZF*( HU(L)*(U(L,K+1)-U(L,K))*DELTI & +DXYIU(L)*(FCAX(L,K+1)-FCAX(L,K)+FBBX(L,K) @@ -1297,22 +1300,27 @@ c DV(L,K)=RCDZF*( HV(L)*(V(L,K+1)-V(L,K))*DELTI & +DXYIV(L)*(FCAY(L,K)-FCAY(L,K+1)+FBBY(L,K) & +SNLT*(FY(L,K)-FY(L,K+1))) ) + ELSE + ! *** TEMPORARY VARIABLE, SO MUST BE INITIALIZED + DU(L,K)=0.0 + DV(L,K)=0.0 + ENDIF ENDDO ENDDO ENDIF + MPI_WTIMES(327)=MPI_WTIMES(327)+MPI_TOC(S1TIME) C C IF(ISTL.EQ.2)THEN C + S1TIME=MPI_TIC() IF(NWSER.GT.0)THEN - DO L=LF,LL +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA DU(L,KS)=DU(L,KS)-CDZU(KS)*TSX(L) DV(L,KS)=DV(L,KS)-CDZU(KS)*TSY(L) ENDDO ENDIF -c - enddo -c t03=rtc()-t02 -c write(6,*) 'Timing 4----->',t03*1.e3,nthds + MPI_WTIMES(328)=MPI_WTIMES(328)+MPI_TOC(S1TIME) C C ENDIF C @@ -1322,7 +1330,7 @@ C IF(N.LE.4)THEN C CLOSE(1) C ENDIF C - 1112 FORMAT('N,NW,NS,I,J,K,NF,H,Q,QU,FUU,FVV=',/,2X,7I5,5E12.4) +C1112 FORMAT('N,NW,NS,I,J,K,NF,H,Q,QU,FUU,FVV=',/,2X,7I5,5E12.4) C C**********************************************************************C C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALFQC.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALFQC.for index a0dfffa8b..412ad8f04 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALFQC.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALFQC.for @@ -1,5 +1,5 @@ - SUBROUTINE CALFQC(ISTL_,IS2TL_,MVAR,MO,CON,CON1,FQCPAD,QSUMPAD, - & QSUMNAD) + SUBROUTINE CALFQC(ISTL_,IS2TL_,MVAR,MO,CON,CON1)!,FQCPAD,QSUMPAD, +! & QSUMNAD) C C CHANGE RECORD C ** SUBROUTINE CALFQC CALCULATES MASS SOURCES AND SINKS ASSOCIATED @@ -7,16 +7,28 @@ C ** WITH CONSTANT AND TIME SERIES INFLOWS AND OUTFLOWS; CONTROL C ** STRUCTURE INFLOWS AND OUTLOWS; WITHDRAWAL AND RETURN STRUCTURE C ** OUTFLOWS; AND EMBEDED CHANNEL INFLOWS AND OUTFLOWS C - USE GLOBAL + USE GLOBAL + IMPLICIT NONE - INTEGER::L,K,LN,LS,ID,JD,KD,NWR,IU,JU,KU,LU,NS,LNW,LSE,LL - INTEGER::LD,NMD,LHOST,LCHNU,LW,LE,NJP - REAL::TMPVAL + INTEGER::L,K,ID,JD,KD,NWR,IU,JU,KU,LU,NS + INTEGER::LD,NMD,NJP - DIMENSION CON(LCM,KCM),CON1(LCM,KCM),FQCPAD(0:LCM1,KCM), - & QSUMNAD(0:LCM1,KCM),QSUMPAD(0:LCM1,KCM) + INTEGER::M,MO,MVAR + INTEGER::ISTL_,IS2TL_ + INTEGER::NCTL,LJP,KTMP,NQSTMP,NCSTMP + INTEGER::LMDCHHT,LMDCHUT,LMDCHVT + + REAL::CON(LCM,KCM),CON1(LCM,KCM)!,FQCPAD(0:LCM1,KCM), +! & QSUMNAD(0:LCM1,KCM),QSUMPAD(0:LCM1,KCM) REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::CONQ + REAL::QVKTMP,QUKTMP,QVJPTMP,QCJPTMP,QVJPENT + REAL::CONUP,RPORTS,RQWD + + L = 0 + QVKTMP = 0.0 + QUKTMP = 0.0 + IF(.NOT.ALLOCATED(CONQ))THEN ALLOCATE(CONQ(LCM,KCM)) CONQ=0.0 @@ -26,41 +38,33 @@ C ! *** SELECTIVE ZEROING IF(KC.GT.1)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - IF(NGWSER.GT.0.OR.ISGWIT.NE.0)THEN - DO L=LF,LL + DO L=1,LC FQC(L,1)=0. ENDDO ENDIF ! *** ZERO EVAP/RAINFALL IF(MVAR.EQ.2)THEN - DO L=LF,LL + DO L=1,LC FQC(L,KC)=0. ENDDO IF(ISADAC(MVAR).GE.2)THEN - DO L=LF,LL + DO L=1,LC FQCPAD(L,KC)=0. ENDDO ENDIF IF(ISADAC(MVAR).GT.0)THEN - DO L=LF,LL + DO L=1,LC QSUMPAD(L,KC)=0. ENDDO ENDIF ENDIF -c - enddo ! *** ZERO ALL DEFINED BC'S - DO K=1,KC DO NS=1,NBCS L=LBCS(NS) + DO K=1,KC FQC(L,K)=0. FQCPAD(L,K)=0 QSUMPAD(L,K)=0. @@ -130,30 +134,23 @@ C ! *** 2TL STANDARD IF(ISTL_.EQ.2.AND.IS2TL_.EQ.1)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c IF(NGWSER.GT.0.OR.ISGWIT.NE.0)THEN - DO L=LF,LL + DO L=1,LC CONQ(L,1)=0.5*(3.*CON(L,1)-CON1(L,1)) ENDDO ENDIF ! *** ZERO EVAP/RAINFALL IF(MVAR.EQ.2)THEN - DO L=LF,LL + DO L=1,LC CONQ(L,KC)=0.5*(3.*CON(L,KC)-CON1(L,KC)) ENDDO ENDIF -c - enddo ! *** INITIALIZE ALL DEFINED BC'S - DO K=1,KC DO NS=1,NBCS L=LBCS(NS) + DO K=1,KC CONQ(L,K)=0.5*(3.*CON(L,K)-CON1(L,K)) ENDDO ENDDO @@ -354,20 +351,15 @@ C & -(QWR(NWR)+QWRSERT(NQSTMP)) ENDIF ! *** GROUNDWATER, EVAP, RAINFALL (2TL) -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(ISGWIE.NE.0)THEN - DO L=LF,LL + DO L=2,LA FQC(L,1)=FQC(L,1)-RIFTR(L)*CONQ(L,1) ENDDO ENDIF ! *** ZONED SEEPAGE (2TL) IF(ISGWIT.EQ.3)THEN - DO L=LF,LL + DO L=2,LA IF(H1P(L).GT.HDRY)THEN FQC(L,1)=FQC(L,1)-RIFTR(L)*CONQ(L,1) ENDIF @@ -378,12 +370,12 @@ c IF(M.EQ.2)THEN IF(ISTOPT(2).EQ.0.OR.ISTOPT(2).EQ.3)THEN - DO L=LF,LL + DO L=2,LA FQC(L,KC)=FQC(L,KC)+RAINT(L)*TEMO*DXYP(L) ENDDO ENDIF IF(ISTOPT(2).EQ.1.OR.ISTOPT(2).EQ.2.OR.ISTOPT(2).EQ.4)THEN - DO L=LF,LL + DO L=2,LA FQC(L,KC)=FQC(L,KC)+RAINT(L)*TATMT(L)*DXYP(L) FQCPAD(L,KC)=FQCPAD(L,KC)+RAINT(L)*TATMT(L)*DXYP(L) QSUMPAD(L,KC)=QSUMPAD(L,KC)+RAINT(L)*DXYP(L) @@ -392,13 +384,11 @@ c ENDIF IF(M.EQ.2)THEN IF(ISTOPT(2).EQ.0)THEN - DO L=LF,LL + DO L=2,LA FQC(L,KC)=FQC(L,KC)-EVAPSW(L)*CONQ(L,KC) ENDDO ENDIF ENDIF -c - enddo ENDIF C C *********************************************************************C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALFQC_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALFQC_mpi.for new file mode 100644 index 000000000..9d4820246 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALFQC_mpi.for @@ -0,0 +1,1336 @@ + SUBROUTINE CALFQC_mpi(ISTL_,IS2TL_,MVAR,MO,CON,CON1)!,FQCPAD,QSUMPAD, +! & QSUMNAD) +C +C CHANGE RECORD +C ** SUBROUTINE CALFQC CALCULATES MASS SOURCES AND SINKS ASSOCIATED +C ** WITH CONSTANT AND TIME SERIES INFLOWS AND OUTFLOWS; CONTROL +C ** STRUCTURE INFLOWS AND OUTLOWS; WITHDRAWAL AND RETURN STRUCTURE +C ** OUTFLOWS; AND EMBEDED CHANNEL INFLOWS AND OUTFLOWS +C + USE GLOBAL + USE MPI + IMPLICIT NONE + + INTEGER::L,K,ID,JD,KD,NWR,IU,JU,KU,LU,NS + INTEGER::LD,NMD,NJP + + INTEGER::M,MO,MVAR + INTEGER::ISTL_,IS2TL_ + INTEGER::NCTL,LJP,KTMP,NQSTMP,NCSTMP + INTEGER::LMDCHHT,LMDCHUT,LMDCHVT + + REAL::CON(LCM,KCM),CON1(LCM,KCM)!,FQCPAD(LCM,KCM), +! & QSUMNAD(LCM,KCM),QSUMPAD(LCM,KCM) + + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::CONQ + REAL::QVKTMP,QUKTMP,QVJPTMP,QCJPTMP,QVJPENT + REAL::CONUP,RPORTS,RQWD + + QVKTMP=0.0 + QUKTMP=0.0 + L=0 + IF(.NOT.ALLOCATED(CONQ))THEN + ALLOCATE(CONQ(LCM,KCM)) + CONQ=0.0 + ENDIF +C + M=MO +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FQCPAD ) + call collect_in_zero_array(QSUMPAD ) + call collect_in_zero_array(QSUMNAD ) + call collect_in_zero_array(FQC ) + if(myrank.eq.0) print*, n,'0FQC = ', sum(abs(dble(FQC ))) + if(myrank.eq.0) print*, n,'0FQCPAD = ', sum(abs(dble(FQCPAD ))) + if(myrank.eq.0) print*, n,'0QSUMPAD = ', sum(abs(dble(QSUMPAD))) + if(myrank.eq.0) print*, n,'0QSUMNAD = ', sum(abs(dble(QSUMNAD))) + endif +C + ! *** SELECTIVE ZEROING + S4TIME=MPI_TIC() + IF(KC.GT.1)THEN + IF(NGWSER.GT.0.OR.ISGWIT.NE.0)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + FQC(L,1)=0. + ENDDO + ENDIF + + ! *** ZERO EVAP/RAINFALL + IF(MVAR.EQ.2)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + FQC(L,KC)=0. + ENDDO + IF(ISADAC(MVAR).GE.2)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + FQCPAD(L,KC)=0. + ENDDO + ENDIF + IF(ISADAC(MVAR).GT.0)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + QSUMPAD(L,KC)=0. + ENDDO + ENDIF + ENDIF + + ! *** ZERO ALL DEFINED BC'S +!$OMP PARALLEL DO PRIVATE(L) + DO NS=1,NBCS + L=LBCS(NS) + IF(ISDOMAIN(L))THEN + FQC(L,1:KC)=0. + FQCPAD(L,1:KC)=0 + QSUMPAD(L,1:KC)=0. + ENDIF + ENDDO + + ELSE + FQC=0. + IF(ISADAC(MVAR).GE.2)FQCPAD=0. + QSUMPAD=0. + !QSUMNAD=0. + ENDIF +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FQCPAD ) + call collect_in_zero_array(QSUMPAD ) + call collect_in_zero_array(QSUMNAD ) + call collect_in_zero_array(FQC ) + if(myrank.eq.0) print*, n,'0FQC = ', sum(abs(dble(FQC ))) + if(myrank.eq.0) print*, n,'0FQCPAD = ', sum(abs(dble(FQCPAD ))) + if(myrank.eq.0) print*, n,'0QSUMPAD = ', sum(abs(dble(QSUMPAD))) + if(myrank.eq.0) print*, n,'0QSUMNAD = ', sum(abs(dble(QSUMNAD))) + endif + + MPI_WTIMES(1101)=MPI_WTIMES(1101)+MPI_TOC(S4TIME) +C + IF(MVAR.EQ.8.AND.IWQPSL.NE.2) GOTO 1500 +C +C ** INITIALIZE VOLUMETRIC SOURCE-SINK FLUXES AND AUXILLARY VARIABLES +C +C + S4TIME=MPI_TIC() + ! *** 3TL STANDARD & WATER QUALITY + IF(ISTL_.EQ.3.OR.MVAR.EQ.8)THEN + IF(NGWSER.GT.0.OR.ISGWIT.NE.0)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + CONQ(L,1)=CON(L,1) + ENDDO + ENDIF + + ! *** ZERO EVAP/RAINFALL + IF(MVAR.EQ.2)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + CONQ(L,KC)=CON(L,KC) + ENDDO + ENDIF + + ! *** INITIALIZE ALL DEFINED BC'S +!$OMP PARALLEL DO PRIVATE(L) + DO NS=1,NBCS + L=LBCS(NS) + IF(ISDOMAIN(L))THEN + CONQ(L,1:KC)=CON(L,1:KC) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(1102)=MPI_WTIMES(1102)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** 3TL CORRECTION STEP + IF(ISTL_.EQ.2.AND.IS2TL_.EQ.0)THEN + IF(NGWSER.GT.0.OR.ISGWIT.NE.0)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + CONQ(L,1)=0.5*(CON(L,1)+CON1(L,1)) + ENDDO + ENDIF + + ! *** ZERO EVAP/RAINFALL + IF(MVAR.EQ.2)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + CONQ(L,KC)=0.5*(CON(L,KC)+CON1(L,KC)) + ENDDO + ENDIF + + ! *** INITIALIZE ALL DEFINED BC'S +!$OMP PARALLEL DO PRIVATE(L) + DO NS=1,NBCS + L=LBCS(NS) + IF(ISDOMAIN(L))THEN + CONQ(L,1:KC)=0.5*(CON(L,1:KC)+CON1(L,1:KC)) + ENDIF + ENDDO + + ENDIF + + ! *** 2TL STANDARD + IF(ISTL_.EQ.2.AND.IS2TL_.EQ.1)THEN + IF(NGWSER.GT.0.OR.ISGWIT.NE.0)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + CONQ(L,1)=0.5*(3.*CON(L,1)-CON1(L,1)) + ENDDO + ENDIF + + ! *** ZERO EVAP/RAINFALL + IF(MVAR.EQ.2)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + CONQ(L,KC)=0.5*(3.*CON(L,KC)-CON1(L,KC)) + ENDDO + ENDIF + + ! *** INITIALIZE ALL DEFINED BC'S +!$OMP PARALLEL DO PRIVATE(L) + DO NS=1,NBCS + L=LBCS(NS) + IF(ISDOMAIN(L))THEN + CONQ(L,1:KC)=0.5*(3.*CON(L,1:KC)-CON1(L,1:KC)) + ENDIF + ENDDO + + ENDIF + MPI_WTIMES(1103)=MPI_WTIMES(1103)+MPI_TOC(S4TIME) +C + IF(MVAR.EQ.4) GOTO 1000 +C + IF(MVAR.EQ.8)THEN + M=4+NTOX+NSED+NSND+MO + ENDIF +C +C *********************************************************************C +C +C *** STANDARD VOLUMETRICS SOURCE SINK LOCATIONS (2TL) +C + IF(ISTL_.EQ.2.AND.IS2TL_.EQ.1)THEN +C + S4TIME=MPI_TIC() + ! *** FLOW BOUNDARY CELLS (2TL) +CC!$OMP PARALLEL DO PRIVATE(L,NQSTMP,NCSTMP) + DO NS=1,NQSIJ + L=LQS(NS) + NQSTMP=NQSERQ(NS) + NCSTMP=NCSERQ(NS,M) + IF(ISDOMAIN(LQS(NS)))THEN + DO K=1,KC + FQC(L,K)=FQC(L,K) + & +MAX(QSS(K,NS),0.)*CQS(K,NS,M) + & +MIN(QSS(K,NS),0.)*CONQ(L,K) + & +MAX(QSERCELL(K,NS),0.)*CSERT(K,NCSTMP,M) + & +MIN(QSERCELL(K,NS),0.)*CONQ(L,K) + FQCPAD(L,K)=FQCPAD(L,K) + & +MAX(QSS(K,NS),0.)*CQS(K,NS,M) + & +MAX(QSERCELL(K,NS),0.)*CSERT(K,NCSTMP,M) + QSUMPAD(L,K)=QSUMPAD(L,K) + & +MAX(QSS(K,NS),0.)+MAX(QSERCELL(K,NS),0.) +C QSUMNAD(L,K)=QSUMNAD(L,K) +C & +MIN(QSS(K,NS),0.)+MIN(QSERCELL(K,NS),0.) + ENDDO + ENDIF + ENDDO + MPI_WTIMES(1104)=MPI_WTIMES(1104)+MPI_TOC(S4TIME) +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FQCPAD ) + call collect_in_zero_array(QSUMPAD ) + call collect_in_zero_array(QSUMNAD ) + call collect_in_zero_array(FQC ) + if(myrank.eq.0) print*, n,'11FQC = ', sum(abs(dble(FQC ))) + if(myrank.eq.0) print*, n,'11FQCD = ', sum(abs(dble(FQCPAD ))) + if(myrank.eq.0) print*, n,'11QSUAD = ', sum(abs(dble(QSUMPAD))) + if(myrank.eq.0) print*, n,'11QSUAD = ', sum(abs(dble(QSUMNAD))) + endif +C + S4TIME=MPI_TIC() + ! *** JET-PLUME VOLUMETRICS SOURCE SINK LOCATIONS (2TL) + IF(NQJPIJ.GT.0)THEN + CALL broadcast_boundary_array(FQC,ic) + DO NJP=1,NQJPIJ + IF(ICALJP(NJP).EQ.1)THEN + RPORTS=FLOAT(NPORTJP(NJP)) + LJP=LIJ(IQJP(NJP),JQJP(NJP)) + KTMP=KEFFJP(NJP) + ! *** QVJPTMP=TIME SERIES DISCHARGE FROM JET-PLUME + QVJPTMP=0. + DO K=1,KC + QVJPTMP=QVJPTMP+QSERT(K,NQSERJP(NJP)) + ENDDO + + ! QCJPTMP=ENTRAINMENT FLUX + QCJPTMP=0. + QVJPENT=0. + ! REMOVE ENTRAINMENT FLUX AND CALCULATE TOTAL ENTRAIMENT FLUX + DO K=1,KC + FQC(LJP,K)=FQC(LJP,K)-RPORTS*QJPENT(K,NJP)*CONQ(LJP,K) + QCJPTMP=QCJPTMP+QJPENT(K,NJP)*CONQ(LJP,K) + QVJPENT=QVJPENT+QJPENT(K,NJP) +C QSUMNAD(LJP,K)=QSUMNAD(LJP,K)-RPORTS*QJPENT(K,NJP) + ENDDO + + ! PLACE JET FLUX AND ENTRAINMENT FLUX IS EFFECTIVE LAYER + FQC(LJP,KTMP)=FQC(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QQCJP(NJP)*CQCJP(1,NJP,M) + & +RPORTS*QVJPTMP*CSERT(1,NCSERJP(NJP,M),M) + FQCPAD(LJP,KTMP)=FQCPAD(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QQCJP(NJP)*CQCJP(1,NJP,M) + & +RPORTS*QVJPTMP*CSERT(1,NCSERJP(NJP,M),M) + QSUMPAD(LJP,KTMP)=QSUMPAD(LJP,KTMP)+RPORTS*QVJPENT + & +RPORTS*QQCJP(NJP)+RPORTS*QVJPTMP + ENDIF + CALL broadcast_boundary_array(CONQ,ic) + CALL broadcast_boundary_array(FQC,ic) + CALL broadcast_boundary_array(FQCPAD,ic) + CALL broadcast_boundary_array(QSUMPAD,ic) + IF(ICALJP(NJP).EQ.2)THEN + RPORTS=FLOAT(NPORTJP(NJP)) + LJP=LIJ(IQJP(NJP),JQJP(NJP)) + KTMP=KEFFJP(NJP) + NS=NQWRSERJP(NJP) + LU=LIJ(IUPCJP(NJP),JUPCJP(NJP)) + KU=KUPCJP(NJP) + CONUP=CONQ(LU,KU) + QCJPTMP=0. + QVJPENT=0. + + ! REMOVE ENTRAIMENT FLUX AND CALCULATE TOTAL ENTRAINMENT + DO K=1,KC + FQC(LJP,K)=FQC(LJP,K)-RPORTS*QJPENT(K,NJP)*CONQ(LJP,K) + QCJPTMP=QCJPTMP+QJPENT(K,NJP)*CONQ(LJP,K) + QVJPENT=QVJPENT+QJPENT(K,NJP) +C QSUMNAD(LJP,K)=QSUMNAD(LJP,K)-RPORTS*QJPENT(K,NJP) + ENDDO + + ! PLACE ENTRAINMENT, CONSTANT AND TIME SERIES FLUXES IN EFFECTIVE CELL + FQC(LJP,KTMP)=FQC(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QWRCJP(NJP)*(CWRCJP(NJP,M)+CONUP) + & +RPORTS*QWRSERT(NS)*(CQWRSERT(NS,M)+CONUP) + FQCPAD(LJP,KTMP)=FQCPAD(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QWRCJP(NJP)*(CWRCJP(NJP,M)+CONUP) + & +RPORTS*QWRSERT(NS)*(CQWRSERT(NS,M)+CONUP) + QSUMPAD(LJP,KTMP)=QSUMPAD(LJP,KTMP)+RPORTS*QVJPENT + & +RPORTS*QWRCJP(NJP)+RPORTS*QWRSERT(NS) + + ! REMOVAL WITHDRAWAL FROM UPSTREAM CELL + FQC(LU,KU)=FQC(LU,KU) + & -RPORTS*QWRCJP(NJP)*CONUP + & -RPORTS*QWRSERT(NS)*CONUP +C QSUMNAD(LU,KU)=QSUMNAD(LU,KU) +C & -RPORTS*QWRCJP(NJP)-RPORTS*QWRSERT(NS) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(1105)=MPI_WTIMES(1105)+MPI_TOC(S4TIME) +C + + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FQCPAD ) + call collect_in_zero_array(QSUMPAD ) + call collect_in_zero_array(QSUMNAD ) + call collect_in_zero_array(FQC ) + if(myrank.eq.0) print*, n,'12FQC = ', sum(abs(dble(FQC ))) + if(myrank.eq.0) print*, n,'12FQD = ', sum(abs(dble(FQCPAD ))) + if(myrank.eq.0) print*, n,'12QSAD = ', sum(abs(dble(QSUMPAD))) + if(myrank.eq.0) print*, n,'12QSAD = ', sum(abs(dble(QSUMNAD))) + endif + + S4TIME=MPI_TIC() + ! *** CONTROL STRUCTURES (2TL) + CALL broadcast_boundary_array(CONQ,ic) + CALL broadcast_boundary_array(FQC,ic) + CALL broadcast_boundary_array(FQCPAD,ic) + CALL broadcast_boundary_array(QSUMPAD,ic) +C!$OMP PARALLEL DO PRIVATE(RQWD,IU,JU,LU,ID,JD,LD) + DO NCTL=1,NQCTL + RQWD=1. + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + LU=LIJ(IU,JU) + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + IF(ID.EQ.0.AND.JD.EQ.0)THEN + LD=LC + RQWD=0. + ELSE + LD=LIJ(ID,JD) + ENDIF + DO K=1,KC + FQC(LU,K)=FQC(LU,K) + & -QCTLT(K,NCTL)*CONQ(LU,K) + FQC(LD,K)=FQC(LD,K) + & +RQWD*QCTLT(K,NCTL)*CONQ(LU,K) + FQCPAD(LD,K)=FQCPAD(LD,K) + & +RQWD*QCTLT(K,NCTL)*CONQ(LU,K) + QSUMPAD(LD,K)=QSUMPAD(LD,K) + & +RQWD*QCTLT(K,NCTL) +C QSUMNAD(L,K)=QSUMNAD(L,K) +C & -QCTLT(K,NCTL) + ENDDO + ENDDO + MPI_WTIMES(1106)=MPI_WTIMES(1106)+MPI_TOC(S4TIME) +C + CALL broadcast_boundary_array(CONQ,ic) + CALL broadcast_boundary_array(FQC,ic) + CALL broadcast_boundary_array(FQCPAD,ic) + CALL broadcast_boundary_array(QSUMPAD,ic) + S4TIME=MPI_TIC() + ! *** WITHDRAWAL CONCENTRATION RISE RETURN (2TL) + DO NWR=1,NQWR + IU=IQWRU(NWR) + JU=JQWRU(NWR) + KU=KQWRU(NWR) + ID=IQWRD(NWR) + JD=JQWRD(NWR) + KD=KQWRD(NWR) + LU=LIJ(IU,JU) + LD=LIJ(ID,JD) + NQSTMP=NQWRSERQ(NWR) + NCSTMP=NQWRSERQ(NWR) + FQC(LU,KU)=FQC(LU,KU) + & -(QWR(NWR)+QWRSERT(NQSTMP))*CONQ(LU,KU) + FQC(LD,KD)=FQC(LD,KD) + & +QWR(NWR)*(CONQ(LU,KU)+CQWR(NWR,M)) + & +QWRSERT(NQSTMP)*(CONQ(LU,KU)+CQWRSERT(NCSTMP,M)) + FQCPAD(LD,KD)=FQCPAD(LD,KD) + & +QWR(NWR)*(CONQ(LU,KU)+CQWR(NWR,M)) + & +QWRSERT(NQSTMP)*(CONQ(LU,KU)+CQWRSERT(NCSTMP,M)) + QSUMPAD(LD,KD)=QSUMPAD(LD,KD) + & +QWR(NWR)+QWRSERT(NQSTMP) +C QSUMNAD(LU,KU)=QSUMNAD(LU,KU) +C & -(QWR(NWR)+QWRSERT(NQSTMP)) + ENDDO + MPI_WTIMES(1107)=MPI_WTIMES(1107)+MPI_TOC(S4TIME) +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FQCPAD ) + call collect_in_zero_array(QSUMPAD ) + call collect_in_zero_array(QSUMNAD ) + if(myrank.eq.0) print*, n,'13FQCPAD = ', sum(abs(dble(FQCPAD ))) + if(myrank.eq.0) print*, n,'13QSUMPAD= ', sum(abs(dble(QSUMPAD))) + if(myrank.eq.0) print*, n,'13QSUMNAD= ', sum(abs(dble(QSUMNAD))) + if(myrank.eq.0) print*, n,'13QSUMNAD= ', nqwr,NQCTL + DO NWR=1,NQWR + IU=IQWRU(NWR) + JU=JQWRU(NWR) + KU=KQWRU(NWR) + ID=IQWRD(NWR) + JD=JQWRD(NWR) + KD=KQWRD(NWR) + LU=LIJ(IU,JU) + LD=LIJ(ID,JD) + if(myrank.eq.0) print*, qsumpad(ld,kd) + enddo + endif +c + S4TIME=MPI_TIC() + ! *** SUBGRID SCALE CHANNEL EXCHANGE (2TL) + IF(MDCHH.GE.1)THEN + DO K=1,KC + DO NMD=1,MDCHH + LMDCHHT=LMDCHH(NMD) + LMDCHUT=LMDCHU(NMD) + LMDCHVT=LMDCHV(NMD) + IF(MDCHTYP(NMD).EQ.1)THEN + QUKTMP=QCHANU(NMD)*DZC(K) + QVKTMP=0. + ENDIF + IF(MDCHTYP(NMD).EQ.2)THEN + QVKTMP=QCHANV(NMD)*DZC(K) + QUKTMP=0. + ENDIF + IF(MDCHTYP(NMD).EQ.3)THEN + QUKTMP=QCHANU(NMD)*DZC(K) + QVKTMP=QCHANV(NMD)*DZC(K) + ENDIF + FQC(LMDCHHT,K)=FQC(LMDCHHT,K) + & +MAX(QUKTMP,0.)*CONQ(LMDCHUT,K) + & +MIN(QUKTMP,0.)*CONQ(LMDCHHT,K) + & +MAX(QVKTMP,0.)*CONQ(LMDCHVT,K) + & +MIN(QVKTMP,0.)*CONQ(LMDCHHT,K) + FQC(LMDCHUT,K)=FQC(LMDCHUT,K) + & -MAX(QUKTMP,0.)*CONQ(LMDCHUT,K) + & -MIN(QUKTMP,0.)*CONQ(LMDCHHT,K) + FQC(LMDCHVT,K)=FQC(LMDCHVT,K) + & -MAX(QVKTMP,0.)*CONQ(LMDCHVT,K) + & -MIN(QVKTMP,0.)*CONQ(LMDCHHT,K) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(1108)=MPI_WTIMES(1108)+MPI_TOC(S4TIME) +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FQCPAD ) + call collect_in_zero_array(QSUMPAD ) + call collect_in_zero_array(QSUMNAD ) + call collect_in_zero_array(FQC ) + if(myrank.eq.0) print*, n,'15FQC = ', sum(abs(dble(FQC ))) + if(myrank.eq.0) print*, n,'15FQD = ', sum(abs(dble(FQCPAD ))) + if(myrank.eq.0) print*, n,'15QSAD = ', sum(abs(dble(QSUMPAD))) + if(myrank.eq.0) print*, n,'15QSAD = ', sum(abs(dble(QSUMNAD))) + endif +C + S4TIME=MPI_TIC() + ! *** GROUNDWATER, EVAP, RAINFALL (2TL) + IF(ISGWIE.NE.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,1)=FQC(L,1)-RIFTR(L)*CONQ(L,1) + ENDDO + ENDIF + MPI_WTIMES(1109)=MPI_WTIMES(1109)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** ZONED SEEPAGE (2TL) + IF(ISGWIT.EQ.3)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(H1P(L).GT.HDRY)THEN + FQC(L,1)=FQC(L,1)-RIFTR(L)*CONQ(L,1) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(1110)=MPI_WTIMES(1110)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** TEMPERATURE ADJUSTMENTS FOR RAINFALL & EVAPORATION + IF(M.EQ.2)THEN + IF(ISTOPT(2).EQ.0.OR.ISTOPT(2).EQ.3)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,KC)=FQC(L,KC)+RAINT(L)*TEMO*DXYP(L) + ENDDO + ENDIF + IF(ISTOPT(2).EQ.1.OR.ISTOPT(2).EQ.2.OR.ISTOPT(2).EQ.4)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,KC)=FQC(L,KC)+RAINT(L)*TATMT(L)*DXYP(L) + FQCPAD(L,KC)=FQCPAD(L,KC)+RAINT(L)*TATMT(L)*DXYP(L) + QSUMPAD(L,KC)=QSUMPAD(L,KC)+RAINT(L)*DXYP(L) + ENDDO + ENDIF + ENDIF + IF(M.EQ.2)THEN + IF(ISTOPT(2).EQ.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,KC)=FQC(L,KC)-EVAPSW(L)*CONQ(L,KC) + ENDDO + ENDIF + ENDIF + MPI_WTIMES(1111)=MPI_WTIMES(1111)+MPI_TOC(S4TIME) + ENDIF +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FQCPAD ) + call collect_in_zero_array(QSUMPAD ) + call collect_in_zero_array(QSUMNAD ) + call collect_in_zero_array(FQC ) + if(myrank.eq.0) print*, n,'2FQC = ', sum(abs(dble(FQC ))) + if(myrank.eq.0) print*, n,'2FQCPAD = ', sum(abs(dble(FQCPAD ))) + if(myrank.eq.0) print*, n,'2QSUMPAD = ', sum(abs(dble(QSUMPAD))) + if(myrank.eq.0) print*, n,'2QSUMNAD = ', sum(abs(dble(QSUMNAD))) + endif + +C *********************************************************************C +C +C *** 3TL CORRECTOR VOLUMETRICS SOURCE SINK LOCATIONS +C + IF(ISTL_.EQ.2.AND.IS2TL_.EQ.0)THEN +C + S4TIME=MPI_TIC() + ! *** FLOW BOUNDARY CELLS (3TL CORRECTOR) + DO NS=1,NQSIJ + L=LQS(NS) + NQSTMP=NQSERQ(NS) + NCSTMP=NCSERQ(NS,M) + IF(ISDOMAIN(LQS(NS)))THEN + DO K=1,KC + FQC(L,K)=FQC(L,K) + & +MAX(QSS(K,NS),0.)*CQS(K,NS,M) + & +MIN(QSS(K,NS),0.)*CONQ(L,K) + & +MAX(QSERCELL(K,NS),0.)*CSERT(K,NCSTMP,M) + & +MIN(QSERCELL(K,NS),0.)*CONQ(L,K) + FQCPAD(L,K)=FQCPAD(L,K) + & +MAX(QSS(K,NS),0.)*CQS(K,NS,M) + & +MAX(QSERCELL(K,NS),0.)*CSERT(K,NCSTMP,M) + QSUMPAD(L,K)=QSUMPAD(L,K) + & +MAX(QSS(K,NS),0.)+MAX(QSERCELL(K,NS),0.) +C QSUMNAD(L,K)=QSUMNAD(L,K) +C & +MIN(QSS(K,NS),0.)+MIN(QSERCELL(K,NS),0.) + ENDDO + ENDIF + ENDDO + MPI_WTIMES(1112)=MPI_WTIMES(1112)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + CALL broadcast_boundary_array(CONQ,ic) + CALL broadcast_boundary_array(FQC,ic) + CALL broadcast_boundary_array(FQCPAD,ic) + CALL broadcast_boundary_array(QSUMPAD,ic) + ! *** JET-PLUME VOLUMETRICS SOURCE SINK LOCATIONS (3TL CORRECTOR) + IF(NQJPIJ.GT.0)THEN + DO NJP=1,NQJPIJ + IF(ICALJP(NJP).EQ.1)THEN + RPORTS=FLOAT(NPORTJP(NJP)) + LJP=LIJ(IQJP(NJP),JQJP(NJP)) + KTMP=KEFFJP(NJP) + + ! QVJPTMP=TIME SERIES DISCHARGE FROM JET-PLUME + QVJPTMP=0. + DO K=1,KC + QVJPTMP=QVJPTMP+QSERT(K,NQSERJP(NJP)) + ENDDO + + ! QCJPTMP=ENTRAINMENT FLUX + QCJPTMP=0. + QVJPENT=0. + + ! REMOVE ENTRAINMENT FLUX AND CALCULATE TOTAL ENTRAIMENT FLUX + DO K=1,KC + FQC(LJP,K)=FQC(LJP,K)-RPORTS*QJPENT(K,NJP)*CONQ(LJP,K) + QCJPTMP=QCJPTMP+QJPENT(K,NJP)*CONQ(LJP,K) + QVJPENT=QVJPENT+QJPENT(K,NJP) +C QSUMNAD(LJP,K)=QSUMNAD(LJP,K)-RPORTS*QJPENT(K,NJP) + ENDDO + + ! PLACE JET FLUX AND ENTRAINMENT FLUX IS EFFECTIVE LAYER + FQC(LJP,KTMP)=FQC(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QQCJP(NJP)*CQCJP(1,NJP,M) + & +RPORTS*QVJPTMP*CSERT(1,NCSERJP(NJP,M),M) + FQCPAD(LJP,KTMP)=FQCPAD(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QQCJP(NJP)*CQCJP(1,NJP,M) + & +RPORTS*QVJPTMP*CSERT(1,NCSERJP(NJP,M),M) + QSUMPAD(LJP,KTMP)=QSUMPAD(LJP,KTMP)+RPORTS*QVJPENT + & +RPORTS*QQCJP(NJP)+RPORTS*QVJPTMP + ENDIF + IF(ICALJP(NJP).EQ.2)THEN + RPORTS=FLOAT(NPORTJP(NJP)) + LJP=LIJ(IQJP(NJP),JQJP(NJP)) + KTMP=KEFFJP(NJP) + NS=NQWRSERJP(NJP) + LU=LIJ(IUPCJP(NJP),JUPCJP(NJP)) + KU=KUPCJP(NJP) + CONUP=CONQ(LU,KU) + QCJPTMP=0. + QVJPENT=0. + + ! REMOVE ENTRAIMENT FLUX AND CALCULATE TOTAL ENTRAINMENT + DO K=1,KC + FQC(LJP,K)=FQC(LJP,K)-RPORTS*QJPENT(K,NJP)*CONQ(LJP,K) + QCJPTMP=QCJPTMP+QJPENT(K,NJP)*CONQ(LJP,K) + QVJPENT=QVJPENT+QJPENT(K,NJP) +C QSUMNAD(LJP,K)=QSUMNAD(LJP,K)-RPORTS*QJPENT(K,NJP) + ENDDO + + ! PLACE ENTRAINMENT, CONSTANT AND TIME SERIES FLUXES IN EFFECTIVE CELL + FQC(LJP,KTMP)=FQC(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QWRCJP(NJP)*(CWRCJP(NJP,M)+CONUP) + & +RPORTS*QWRSERT(NS)*(CQWRSERT(NS,M)+CONUP) + FQCPAD(LJP,KTMP)=FQCPAD(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QWRCJP(NJP)*(CWRCJP(NJP,M)+CONUP) + & +RPORTS*QWRSERT(NS)*(CQWRSERT(NS,M)+CONUP) + QSUMPAD(LJP,KTMP)=QSUMPAD(LJP,KTMP)+RPORTS*QVJPENT + & +RPORTS*QWRCJP(NJP)+RPORTS*QWRSERT(NS) + + ! REMOVAL WITHDRAWAL FROM UPSTREAM CELL + FQC(LU,KU)=FQC(LU,KU) + & -RPORTS*QWRCJP(NJP)*CONUP + & -RPORTS*QWRSERT(NS)*CONUP +C QSUMNAD(LU,KU)=QSUMNAD(LU,KU) +C & -RPORTS*QWRCJP(NJP)-RPORTS*QWRSERT(NS) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(1113)=MPI_WTIMES(1113)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + CALL broadcast_boundary_array(CONQ,ic) + CALL broadcast_boundary_array(FQC,ic) + CALL broadcast_boundary_array(FQCPAD,ic) + CALL broadcast_boundary_array(QSUMPAD,ic) + ! *** CONTROL STRUCTURES (3TL CORRECTOR) + DO NCTL=1,NQCTL + RQWD=1. + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + LU=LIJ(IU,JU) + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + IF(ID.EQ.0.AND.JD.EQ.0)THEN + LD=LC + RQWD=0. + ELSE + LD=LIJ(ID,JD) + ENDIF + DO K=1,KC + FQC(LU,K)=FQC(LU,K) + & -QCTLT(K,NCTL)*CONQ(LU,K) + FQC(LD,K)=FQC(LD,K) + & +RQWD*QCTLT(K,NCTL)*CONQ(LU,K) + FQCPAD(LD,K)=FQCPAD(LD,K) + & +RQWD*QCTLT(K,NCTL)*CONQ(LU,K) + QSUMPAD(L,K)=QSUMPAD(L,K) + & +RQWD*QCTLT(K,NCTL) +C QSUMNAD(L,K)=QSUMNAD(L,K) +C & -QCTLT(K,NCTL) + ENDDO + ENDDO + MPI_WTIMES(1114)=MPI_WTIMES(1114)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + CALL broadcast_boundary_array(CONQ,ic) + CALL broadcast_boundary_array(FQC,ic) + CALL broadcast_boundary_array(FQCPAD,ic) + CALL broadcast_boundary_array(QSUMPAD,ic) + ! *** WITHDRAWAL CONCENTRATION RISE RETURN (3TL CORRECTOR) + DO NWR=1,NQWR + IU=IQWRU(NWR) + JU=JQWRU(NWR) + KU=KQWRU(NWR) + ID=IQWRD(NWR) + JD=JQWRD(NWR) + KD=KQWRD(NWR) + LU=LIJ(IU,JU) + LD=LIJ(ID,JD) + NQSTMP=NQWRSERQ(NWR) + NCSTMP=NQWRSERQ(NWR) + FQC(LU,KU)=FQC(LU,KU) + & -(QWR(NWR)+QWRSERT(NQSTMP))*CONQ(LU,KU) + FQC(LD,KD)=FQC(LD,KD) + & +QWR(NWR)*(CONQ(LU,KU)+CQWR(NWR,M)) + & +QWRSERT(NQSTMP)*(CONQ(LU,KU)+CQWRSERT(NCSTMP,M)) + FQCPAD(LD,KD)=FQCPAD(LD,KD) + & +QWR(NWR)*(CONQ(LU,KU)+CQWR(NWR,M)) + & +QWRSERT(NQSTMP)*(CONQ(LU,KU)+CQWRSERT(NCSTMP,M)) + QSUMPAD(LD,KD)=QSUMPAD(LD,KD) + & +QWR(NWR)+QWRSERT(NQSTMP) +C QSUMNAD(LU,KU)=QSUMNAD(LU,KU) +C & -(QWR(NWR)+QWRSERT(NQSTMP)) + ENDDO + MPI_WTIMES(1115)=MPI_WTIMES(1115)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** SUBGRID SCALE CHANNEL EXCHANGE (3TL CORRECTOR) + IF(MDCHH.GE.1)THEN + DO K=1,KC + DO NMD=1,MDCHH + LMDCHHT=LMDCHH(NMD) + LMDCHUT=LMDCHU(NMD) + LMDCHVT=LMDCHV(NMD) + IF(MDCHTYP(NMD).EQ.1)THEN + QUKTMP=QCHANU(NMD)*DZC(K) + QVKTMP=0. + ENDIF + IF(MDCHTYP(NMD).EQ.2)THEN + QVKTMP=QCHANV(NMD)*DZC(K) + QUKTMP=0. + ENDIF + IF(MDCHTYP(NMD).EQ.3)THEN + QUKTMP=QCHANU(NMD)*DZC(K) + QVKTMP=QCHANV(NMD)*DZC(K) + ENDIF + FQC(LMDCHHT,K)=FQC(LMDCHHT,K) + & +MAX(QUKTMP,0.)*CONQ(LMDCHUT,K) + & +MIN(QUKTMP,0.)*CONQ(LMDCHHT,K) + & +MAX(QVKTMP,0.)*CONQ(LMDCHVT,K) + & +MIN(QVKTMP,0.)*CONQ(LMDCHHT,K) + FQC(LMDCHUT,K)=FQC(LMDCHUT,K) + & -MAX(QUKTMP,0.)*CONQ(LMDCHUT,K) + & -MIN(QUKTMP,0.)*CONQ(LMDCHHT,K) + FQC(LMDCHVT,K)=FQC(LMDCHVT,K) + & -MAX(QVKTMP,0.)*CONQ(LMDCHVT,K) + & -MIN(QVKTMP,0.)*CONQ(LMDCHHT,K) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(1116)=MPI_WTIMES(1116)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** GROUNDWATER, EVAP, RAINFALL (3TL CORRECTOR) + IF(ISGWIE.NE.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,1)=FQC(L,1)-RIFTR(L)*CONQ(L,1) + ENDDO + ENDIF + MPI_WTIMES(1117)=MPI_WTIMES(1117)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** ZONED SEEPAGE (3TL) + IF(ISGWIT.EQ.3)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(H1P(L).GT.HDRY)THEN + FQC(L,1)=FQC(L,1)-RIFTR(L)*CONQ(L,1) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(1118)=MPI_WTIMES(1118)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** TEMPERATURE ADJUSTMENTS FOR RAINFALL & EVAPORATION + IF(M.EQ.2)THEN + IF(ISTOPT(2).EQ.0.OR.ISTOPT(2).EQ.3)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,KC)=FQC(L,KC)+RAINT(L)*TEMO*DXYP(L) + ENDDO + ENDIF + IF(ISTOPT(2).EQ.1.OR.ISTOPT(2).EQ.2.OR.ISTOPT(2).EQ.4)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,KC)=FQC(L,KC)+RAINT(L)*TATMT(L)*DXYP(L) + FQCPAD(L,KC)=FQCPAD(L,KC)+RAINT(L)*TATMT(L)*DXYP(L) + QSUMPAD(L,KC)=QSUMPAD(L,KC)+RAINT(L)*DXYP(L) + ENDDO + ENDIF + ENDIF + IF(M.EQ.2)THEN + IF(ISTOPT(2).EQ.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,KC)=FQC(L,KC)-EVAPSW(L)*CONQ(L,KC) + ENDDO + ENDIF + ENDIF + MPI_WTIMES(1119)=MPI_WTIMES(1119)+MPI_TOC(S4TIME) +C + ENDIF + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FQCPAD ) + call collect_in_zero_array(QSUMPAD ) + call collect_in_zero_array(QSUMNAD ) + if(myrank.eq.0) print*, n,'3FQCPAD = ', sum(abs(dble(FQCPAD ))) + if(myrank.eq.0) print*, n,'3QSUMPAD = ', sum(abs(dble(QSUMPAD))) + if(myrank.eq.0) print*, n,'3QSUMNAD = ', sum(abs(dble(QSUMNAD))) + endif + +C *********************************************************************C +C +C ** STANDARD VOLUMETRICS SOURCE SINK LOCATIONS (3TL) +C + IF(ISTL_.EQ.3)THEN +C + S4TIME=MPI_TIC() + ! *** FLOW BOUNDARY CELLS (3TL) + DO NS=1,NQSIJ + L=LQS(NS) + NQSTMP=NQSERQ(NS) + NCSTMP=NCSERQ(NS,M) + IF(ISDOMAIN(LQS(NS)))THEN + DO K=1,KC + FQC(L,K)=FQC(L,K) + & +MAX(QSS(K,NS),0.)*CQS(K,NS,M) + & +MIN(QSS(K,NS),0.)*CONQ(L,K) + & +MAX(QSERCELL(K,NS),0.)*CSERT(K,NCSTMP,M) + & +MIN(QSERCELL(K,NS),0.)*CONQ(L,K) + FQCPAD(L,K)=FQCPAD(L,K) + & +MAX(QSS(K,NS),0.)*CQS(K,NS,M) + & +MAX(QSERCELL(K,NS),0.)*CSERT(K,NCSTMP,M) + QSUMPAD(L,K)=QSUMPAD(L,K) + & +MAX(QSS(K,NS),0.)+MAX(QSERCELL(K,NS),0.) +C QSUMNAD(L,K)=QSUMNAD(L,K) +C & +MIN(QSS(K,NS),0.)+MIN(QSERCELL(K,NS),0.) + ENDDO + ENDIF + ENDDO + MPI_WTIMES(1120)=MPI_WTIMES(1120)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** JET-PLUME VOLUMETRICS SOURCE SINK LOCATIONS (3TL) + IF(NQJPIJ.GT.0)THEN + DO NJP=1,NQJPIJ + IF(ICALJP(NJP).EQ.1)THEN + RPORTS=FLOAT(NPORTJP(NJP)) + LJP=LIJ(IQJP(NJP),JQJP(NJP)) + KTMP=KEFFJP(NJP) + + ! QVJPTMP=TIME SERIES DISCHARGE FROM JET-PLUME + QVJPTMP=0. + DO K=1,KC + QVJPTMP=QVJPTMP+QSERT(K,NQSERJP(NJP)) + ENDDO + + ! QCJPTMP=ENTRAINMENT FLUX + QCJPTMP=0. + QVJPENT=0. + + ! REMOVE ENTRAINMENT FLUX AND CALCULATE TOTAL ENTRAIMENT FLUX + DO K=1,KC + FQC(LJP,K)=FQC(LJP,K)-RPORTS*QJPENT(K,NJP)*CONQ(LJP,K) + QCJPTMP=QCJPTMP+QJPENT(K,NJP)*CONQ(LJP,K) + QVJPENT=QVJPENT+QJPENT(K,NJP) +C QSUMNAD(LJP,K)=QSUMNAD(LJP,K)-RPORTS*QJPENT(K,NJP) + ENDDO + + ! PLACE JET FLUX AND ENTRAINMENT FLUX IS EFFECTIVE LAYER + FQC(LJP,KTMP)=FQC(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QQCJP(NJP)*CQCJP(1,NJP,M) + & +RPORTS*QVJPTMP*CSERT(1,NCSERJP(NJP,M),M) + FQCPAD(LJP,KTMP)=FQCPAD(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QQCJP(NJP)*CQCJP(1,NJP,M) + & +RPORTS*QVJPTMP*CSERT(1,NCSERJP(NJP,M),M) + QSUMPAD(LJP,KTMP)=QSUMPAD(LJP,KTMP)+RPORTS*QVJPENT + & +RPORTS*QQCJP(NJP)+RPORTS*QVJPTMP + ENDIF + IF(ICALJP(NJP).EQ.2)THEN + RPORTS=FLOAT(NPORTJP(NJP)) + LJP=LIJ(IQJP(NJP),JQJP(NJP)) + KTMP=KEFFJP(NJP) + NS=NQWRSERJP(NJP) + LU=LIJ(IUPCJP(NJP),JUPCJP(NJP)) + KU=KUPCJP(NJP) + CONUP=CONQ(LU,KU) + QCJPTMP=0. + QVJPENT=0. + + ! REMOVE ENTRAIMENT FLUX AND CALCULATE TOTAL ENTRAINMENT + DO K=1,KC + FQC(LJP,K)=FQC(LJP,K)-RPORTS*QJPENT(K,NJP)*CONQ(LJP,K) + QCJPTMP=QCJPTMP+QJPENT(K,NJP)*CONQ(LJP,K) + QVJPENT=QVJPENT+QJPENT(K,NJP) +C QSUMNAD(LJP,K)=QSUMNAD(LJP,K)-RPORTS*QJPENT(K,NJP) + ENDDO + + ! PLACE ENTRAINMENT, CONSTANT AND TIME SERIES FLUXES IN EFFECTIVE CELL + FQC(LJP,KTMP)=FQC(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QWRCJP(NJP)*(CWRCJP(NJP,M)+CONUP) + & +RPORTS*QWRSERT(NS)*(CQWRSERT(NS,M)+CONUP) + FQCPAD(LJP,KTMP)=FQCPAD(LJP,KTMP)+RPORTS*QCJPTMP + & +RPORTS*QWRCJP(NJP)*(CWRCJP(NJP,M)+CONUP) + & +RPORTS*QWRSERT(NS)*(CQWRSERT(NS,M)+CONUP) + QSUMPAD(LJP,KTMP)=QSUMPAD(LJP,KTMP)+RPORTS*QVJPENT + & +RPORTS*QWRCJP(NJP)+RPORTS*QWRSERT(NS) + + ! REMOVAL WITHDRAWAL FROM UPSTREAM CELL + FQC(LU,KU)=FQC(LU,KU) + & -RPORTS*QWRCJP(NJP)*CONUP + & -RPORTS*QWRSERT(NS)*CONUP +C QSUMNAD(LU,KU)=QSUMNAD(LU,KU) +C & -RPORTS*QWRCJP(NJP)-RPORTS*QWRSERT(NS) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(1121)=MPI_WTIMES(1121)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** CONTROL STRUCTURES (3TL) + DO NCTL=1,NQCTL + RQWD=1. + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + LU=LIJ(IU,JU) + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + IF(ID.EQ.0.AND.JD.EQ.0)THEN + LD=LC + RQWD=0. + ELSE + LD=LIJ(ID,JD) + ENDIF + DO K=1,KC + FQC(LU,K)=FQC(LU,K) + & -QCTLT(K,NCTL)*CONQ(LU,K) + FQC(LD,K)=FQC(LD,K) + & +RQWD*QCTLT(K,NCTL)*CONQ(LU,K) + FQCPAD(LD,K)=FQCPAD(LD,K) + & +RQWD*QCTLT(K,NCTL)*CONQ(LU,K) + QSUMPAD(L,K)=QSUMPAD(L,K) + & +RQWD*QCTLT(K,NCTL) +C QSUMNAD(L,K)=QSUMNAD(L,K) +C & -QCTLT(K,NCTL) + ENDDO + ENDDO + MPI_WTIMES(1122)=MPI_WTIMES(1122)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** WITHDRAWAL CONCENTRATION RISE RETURN (3TL) + DO NWR=1,NQWR + IU=IQWRU(NWR) + JU=JQWRU(NWR) + KU=KQWRU(NWR) + ID=IQWRD(NWR) + JD=JQWRD(NWR) + KD=KQWRD(NWR) + LU=LIJ(IU,JU) + LD=LIJ(ID,JD) + NQSTMP=NQWRSERQ(NWR) + NCSTMP=NQWRSERQ(NWR) + FQC(LU,KU)=FQC(LU,KU) + & -(QWR(NWR)+QWRSERT(NQSTMP))*CONQ(LU,KU) + FQC(LD,KD)=FQC(LD,KD) + & +QWR(NWR)*(CONQ(LU,KU)+CQWR(NWR,M)) + & +QWRSERT(NQSTMP)*(CONQ(LU,KU)+CQWRSERT(NCSTMP,M)) + FQCPAD(LD,KD)=FQCPAD(LD,KD) + & +QWR(NWR)*(CONQ(LU,KU)+CQWR(NWR,M)) + & +QWRSERT(NQSTMP)*(CONQ(LU,KU)+CQWRSERT(NCSTMP,M)) + QSUMPAD(LD,KD)=QSUMPAD(LD,KD) + & +QWR(NWR)+QWRSERT(NQSTMP) +C QSUMNAD(LU,KU)=QSUMNAD(LU,KU) +C & -(QWR(NWR)+QWRSERT(NQSTMP)) + ENDDO + MPI_WTIMES(1123)=MPI_WTIMES(1123)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** SUBGRID SCALE CHANNEL EXCHANGE (3TL) + IF(MDCHH.GE.1)THEN + DO K=1,KC + DO NMD=1,MDCHH + LMDCHHT=LMDCHH(NMD) + LMDCHUT=LMDCHU(NMD) + LMDCHVT=LMDCHV(NMD) + IF(MDCHTYP(NMD).EQ.1)THEN + QUKTMP=QCHANU(NMD)*DZC(K) + QVKTMP=0. + ENDIF + IF(MDCHTYP(NMD).EQ.2)THEN + QVKTMP=QCHANV(NMD)*DZC(K) + QUKTMP=0. + ENDIF + IF(MDCHTYP(NMD).EQ.3)THEN + QUKTMP=QCHANU(NMD)*DZC(K) + QVKTMP=QCHANV(NMD)*DZC(K) + ENDIF + FQC(LMDCHHT,K)=FQC(LMDCHHT,K) + & +MAX(QUKTMP,0.)*CONQ(LMDCHUT,K) + & +MIN(QUKTMP,0.)*CONQ(LMDCHHT,K) + & +MAX(QVKTMP,0.)*CONQ(LMDCHVT,K) + & +MIN(QVKTMP,0.)*CONQ(LMDCHHT,K) + FQC(LMDCHUT,K)=FQC(LMDCHUT,K) + & -MAX(QUKTMP,0.)*CONQ(LMDCHUT,K) + & -MIN(QUKTMP,0.)*CONQ(LMDCHHT,K) + FQC(LMDCHVT,K)=FQC(LMDCHVT,K) + & -MAX(QVKTMP,0.)*CONQ(LMDCHVT,K) + & -MIN(QVKTMP,0.)*CONQ(LMDCHHT,K) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(1124)=MPI_WTIMES(1124)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** GROUNDWATER, EVAP, RAINFALL (3TL) + IF(ISGWIE.NE.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,1)=FQC(L,1)-RIFTR(L)*CONQ(L,1) + ENDDO + ENDIF + MPI_WTIMES(1125)=MPI_WTIMES(1125)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** ZONED SEEPAGE (3TL) + IF(ISGWIT.EQ.3)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(H1P(L).GT.HDRY)THEN + FQC(L,1)=FQC(L,1)-RIFTR(L)*CONQ(L,1) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(1126)=MPI_WTIMES(1126)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** TEMPERATURE ADJUSTMENTS FOR RAINFALL & EVAPORATION + IF(M.EQ.2)THEN + IF(ISTOPT(2).EQ.0.OR.ISTOPT(2).EQ.3)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,KC)=FQC(L,KC)+RAINT(L)*TEMO*DXYP(L) + ENDDO + ENDIF + IF(ISTOPT(2).EQ.1.OR.ISTOPT(2).EQ.2.OR.ISTOPT(2).EQ.4)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,KC)=FQC(L,KC)+RAINT(L)*TATMT(L)*DXYP(L) + FQCPAD(L,KC)=FQCPAD(L,KC)+RAINT(L)*TATMT(L)*DXYP(L) + QSUMPAD(L,KC)=QSUMPAD(L,KC)+RAINT(L)*DXYP(L) + ENDDO + ENDIF + ENDIF + IF(M.EQ.2)THEN + IF(ISTOPT(2).EQ.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,KC)=FQC(L,KC)-EVAPSW(L)*CONQ(L,KC) + ENDDO + ENDIF + ENDIF + ENDIF + MPI_WTIMES(1127)=MPI_WTIMES(1127)+MPI_TOC(S4TIME) +C + GOTO 2000 +C +C *** SHELL FISH LARVAE SECTION +C + 1000 CONTINUE +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FQCPAD ) + call collect_in_zero_array(QSUMPAD ) + call collect_in_zero_array(QSUMNAD ) + if(myrank.eq.0) print*, n,'4FQCPAD = ', sum(abs(dble(FQCPAD ))) + if(myrank.eq.0) print*, n,'4QSUMPAD = ', sum(abs(dble(QSUMPAD))) + if(myrank.eq.0) print*, n,'4QSUMNAD = ', sum(abs(dble(QSUMNAD))) + endif + + S4TIME=MPI_TIC() + DO NS=1,NQSIJ + L=LQS(NS) + NQSTMP=NQSERQ(NS) + NCSTMP=NCSERQ(NS,M) + IF(ISDOMAIN(LQS(NS)))THEN + DO K=1,KC + FQC(L,K)=FQC(L,K) + & +MAX(QSS(K,NS),0.)*CQS(K,NS,M) + & +MIN(QSS(K,NS),0.)*CONQ(L,K) + & +MAX(QSERCELL(K,NS),0.)*CSERT(K,NCSTMP,M) + & +MIN(QSERCELL(K,NS),0.)*CONQ(L,K) + ENDDO + ENDIF + ENDDO + MPI_WTIMES(1128)=MPI_WTIMES(1128)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + DO NCTL=1,NQCTL + RQWD=1. + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + LU=LIJ(IU,JU) + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + IF(ID.EQ.0.AND.JD.EQ.0)THEN + LD=LC + RQWD=0. + ELSE + LD=LIJ(ID,JD) + ENDIF + DO K=1,KC + FQC(LU,K)=FQC(LU,K) + & -QCTLT(K,NCTL)*CONQ(LU,K) + FQC(LD,K)=FQC(LD,K) + & +RQWD*QCTLT(K,NCTL)*CONQ(LU,K) + ENDDO + ENDDO + MPI_WTIMES(1129)=MPI_WTIMES(1129)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + DO NWR=1,NQWR + IU=IQWRU(NWR) + JU=JQWRU(NWR) + KU=KQWRU(NWR) + ID=IQWRD(NWR) + JD=JQWRD(NWR) + KD=KQWRD(NWR) + LU=LIJ(IU,JU) + LD=LIJ(ID,JD) + NQSTMP=NQWRSERQ(NWR) + NCSTMP=NQWRSERQ(NWR) + FQC(LU,KU)=FQC(LU,KU) + & -(QWR(NWR)+QWRSERT(NQSTMP))*CONQ(LU,KU) + FQC(LD,KD)=FQC(LD,KD) + & +QWR(NWR)*(SFLKILL*CONQ(LU,KU)+CQWR(NWR,M)) + & +QWRSERT(NQSTMP)*(SFLKILL*CONQ(LU,KU) + & +CQWRSERT(NCSTMP,M)) + ENDDO + MPI_WTIMES(1130)=MPI_WTIMES(1130)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + IF(MDCHH.GE.1)THEN + DO K=1,KC + DO NMD=1,MDCHH + LMDCHHT=LMDCHH(NMD) + LMDCHUT=LMDCHU(NMD) + LMDCHVT=LMDCHV(NMD) + IF(MDCHTYP(NMD).EQ.1)THEN + QUKTMP=QCHANU(NMD)*DZC(K) + QVKTMP=0. + ENDIF + IF(MDCHTYP(NMD).EQ.2)THEN + QVKTMP=QCHANV(NMD)*DZC(K) + QUKTMP=0. + ENDIF + IF(MDCHTYP(NMD).EQ.3)THEN + QUKTMP=QCHANU(NMD)*DZC(K) + QVKTMP=QCHANV(NMD)*DZC(K) + ENDIF + FQC(LMDCHHT,K)=FQC(LMDCHHT,K) + & +MAX(QUKTMP,0.)*CONQ(LMDCHUT,K) + & +MIN(QUKTMP,0.)*CONQ(LMDCHHT,K) + & +MAX(QVKTMP,0.)*CONQ(LMDCHVT,K) + & +MIN(QVKTMP,0.)*CONQ(LMDCHHT,K) + FQC(LMDCHUT,K)=FQC(LMDCHUT,K) + & -MAX(QUKTMP,0.)*CONQ(LMDCHUT,K) + & -MIN(QUKTMP,0.)*CONQ(LMDCHHT,K) + FQC(LMDCHVT,K)=FQC(LMDCHVT,K) + & -MAX(QVKTMP,0.)*CONQ(LMDCHVT,K) + & -MIN(QVKTMP,0.)*CONQ(LMDCHHT,K) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(1131)=MPI_WTIMES(1131)+MPI_TOC(S4TIME) +C + GOTO 2000 +C +C *** WATER QUALITY ONLY (IWQPSL=1,0) +C + 1500 CONTINUE +C + S4TIME=MPI_TIC() + ! *** FLOW BOUNDARIES + DO NS=1,NQSIJ + L=LQS(NS) + NQSTMP=NQSERQ(NS) + DO K=1,KC + FQC(L,K)=FQC(L,K) + & +MIN(QSS(K,NS),0.)*CON1(L,K) + & +MIN(QSERCELL(K,NS),0.)*CON1(L,K) + QSUMPAD(L,K)=QSUMPAD(L,K) + & +MAX(QSS(K,NS),0.)+MAX(QSERCELL(K,NS),0.) +C QSUMNAD(L,K)=QSUMNAD(L,K) +C & +MIN(QSS(K,NS),0.)+MIN(QSERCELL(K,NS),0.) + ENDDO + ENDDO + MPI_WTIMES(1132)=MPI_WTIMES(1132)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** HYDRAULIC STRUCTURES + DO NCTL=1,NQCTL + RQWD=1. + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + LU=LIJ(IU,JU) + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + IF(ID.EQ.0.AND.JD.EQ.0)THEN + LD=LC + RQWD=0. + ELSE + LD=LIJ(ID,JD) + ENDIF + DO K=1,KC + FQC(LU,K)=FQC(LU,K) + & -QCTLT(K,NCTL)*CON1(LU,K) + FQC(LD,K)=FQC(LD,K) + & +RQWD*QCTLT(K,NCTL)*CON1(LU,K) + FQCPAD(LD,K)=FQCPAD(LD,K) + & +RQWD*QCTLT(K,NCTL)*CON1(LU,K) + QSUMPAD(L,K)=QSUMPAD(L,K) + & +RQWD*QCTLT(K,NCTL) +C QSUMNAD(L,K)=QSUMNAD(L,K) +C & -QCTLT(K,NCTL) + ENDDO + ENDDO + MPI_WTIMES(1133)=MPI_WTIMES(1133)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** WITHDRAWAL/RETURN + IF(MVAR.EQ.8)THEN + M=4+NTOX+NSED+NSND+MO + ELSE + M=MO + ENDIF + DO NWR=1,NQWR + IU=IQWRU(NWR) + JU=JQWRU(NWR) + KU=KQWRU(NWR) + ID=IQWRD(NWR) + JD=JQWRD(NWR) + KD=KQWRD(NWR) + LU=LIJ(IU,JU) + LD=LIJ(ID,JD) + NQSTMP=NQWRSERQ(NWR) + NCSTMP=NQWRSERQ(NWR) + FQC(LU,KU)=FQC(LU,KU) + & -(QWR(NWR)+QWRSERT(NQSTMP))*CON1(LU,KU) + FQC(LD,KD)=FQC(LD,KD) + & +QWR(NWR)*(CON1(LU,KU)+CQWR(NWR,M)) + & +QWRSERT(NQSTMP)*(CON1(LU,KU)+CQWRSERT(NCSTMP,M)) + FQCPAD(LD,KD)=FQCPAD(LD,KD) + & +QWR(NWR)*(CON1(LU,KU)+CQWR(NWR,M)) + & +QWRSERT(NQSTMP)*(CON1(LU,KU)+CQWRSERT(NCSTMP,M)) + QSUMPAD(LD,KD)=QSUMPAD(LD,KD) + & +QWR(NWR)+QWRSERT(NQSTMP) +C QSUMNAD(LU,KU)=QSUMNAD(LU,KU) +C & -(QWR(NWR)+QWRSERT(NQSTMP)) + ENDDO + MPI_WTIMES(1134)=MPI_WTIMES(1134)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** SUBGRID CHANNEL INTERACTIONS + IF(MDCHH.GE.1)THEN + DO K=1,KC + DO NMD=1,MDCHH + LMDCHHT=LMDCHH(NMD) + LMDCHUT=LMDCHU(NMD) + LMDCHVT=LMDCHV(NMD) + IF(MDCHTYP(NMD).EQ.1)THEN + QUKTMP=QCHANU(NMD)*DZC(K) + QVKTMP=0. + ENDIF + IF(MDCHTYP(NMD).EQ.2)THEN + QVKTMP=QCHANV(NMD)*DZC(K) + QUKTMP=0. + ENDIF + IF(MDCHTYP(NMD).EQ.3)THEN + QUKTMP=QCHANU(NMD)*DZC(K) + QVKTMP=QCHANV(NMD)*DZC(K) + ENDIF + FQC(LMDCHHT,K)=FQC(LMDCHHT,K) + & +MAX(QUKTMP,0.)*CON1(LMDCHUT,K) + & +MIN(QUKTMP,0.)*CON1(LMDCHHT,K) + & +MAX(QVKTMP,0.)*CON1(LMDCHVT,K) + & +MIN(QVKTMP,0.)*CON1(LMDCHHT,K) + FQC(LMDCHUT,K)=FQC(LMDCHUT,K) + & -MAX(QUKTMP,0.)*CON1(LMDCHUT,K) + & -MIN(QUKTMP,0.)*CON1(LMDCHHT,K) + FQC(LMDCHVT,K)=FQC(LMDCHVT,K) + & -MAX(QVKTMP,0.)*CON1(LMDCHVT,K) + & -MIN(QVKTMP,0.)*CON1(LMDCHHT,K) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(1135)=MPI_WTIMES(1135)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** GROUNDWATER, EVAP, RAINFALL (2TL) + IF(ISGWIE.NE.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FQC(L,1)=FQC(L,1)-RIFTR(L)*CONQ(L,1) + ENDDO + ENDIF + MPI_WTIMES(1136)=MPI_WTIMES(1136)+MPI_TOC(S4TIME) +C + S4TIME=MPI_TIC() + ! *** ZONED SEEPAGE (2TL) + IF(ISGWIT.EQ.3)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(H1P(L).GT.HDRY)THEN + FQC(L,1)=FQC(L,1)-RIFTR(L)*CON1(L,1) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(1137)=MPI_WTIMES(1137)+MPI_TOC(S4TIME) +C + 2000 CONTINUE + + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FQCPAD ) + call collect_in_zero_array(QSUMPAD ) + call collect_in_zero_array(QSUMNAD ) + if(myrank.eq.0) print*, n,'5FQCPAD = ', sum(abs(dble(FQCPAD ))) + if(myrank.eq.0) print*, n,'5QSUMPAD = ', sum(abs(dble(QSUMPAD))) + if(myrank.eq.0) print*, n,'5QSUMNAD = ', sum(abs(dble(QSUMNAD))) + endif + + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHDMF.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHDMF.for index 8bcfb943a..687a8561f 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHDMF.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHDMF.for @@ -12,9 +12,9 @@ C 2008-10 SANG YUK (DSLLC) CORRECTED THE DIFFUSIVE MOMENTUM FLUXES COMPUTAT C USE GLOBAL IMPLICIT NONE - INTEGER::L,LN,LS,LE,LW,K,LL,J,I,ithds,LF ! ithds,LF GEOSR jgcho 151118 + INTEGER::L,LN,LS,LW,K,LL,J,I REAL::SLIPCO,DY2DZBR,DX2DZBR,CSDRAG,SLIPFAC,TMPVAL,DSQR,WVFACT - REAL::DTMPH,DTMPX,AHWVX,SXYLN,SXYEE,PMC + REAL::DTMPH,DTMPX,AHWVX,SXYLN,SXYEE REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::AHEE REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::AHNN REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::SXY @@ -38,6 +38,7 @@ C SXY2NN=0.0 HMC=0.0 ENDIF + SLIPCO=0.0 C AHMAX=AHO C @@ -71,25 +72,19 @@ C IF(AHD.GT.0.0)THEN SLIPCO=0.5/SQRT(AHD) ENDIF -! -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS,DY2DZBR,CSDRAG,SLIPFAC, -!$OMP& LW,DX2DZBR) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -! DO K=1,KC - DO L=LF,LL + DO L=2,LA LN=LNC(L) ! *** DXU1 = dU/dX, UNITS: 1/S DXU1(L,K)=SUB(L+1)*(U(L+1,K)-U(L,K))/DXP(L) ! *** DYV1 = dV/dY, UNITS: 1/S DYV1(L,K)=SVB(LN )*(V(LN,K)-V(L,K))/DYP(L) ENDDO + ENDDO C ! *** DYU1 = dU/dY - DO L=LF,LL + DO K=1,KC + DO L=2,LA LS=LSC(L) IF(ICORDYU(L).EQ.1)THEN DYU1(L,K)=2.*SVB(L)*(U(L,K)-U(LS,K))/(DYU(L)+DYU(LS)) @@ -112,9 +107,11 @@ C ENDIF ENDIF ENDDO + ENDDO C ! *** DXV1 = dV/dX - DO L=LF,LL + DO K=1,KC + DO L=2,LA LW=L-1 IF(ICORDXV(L).EQ.1)THEN DXV1(L,K)=2.*SUB(L)*(V(L,K)-V(LW,K))/(DXV(L)+DXV(LW)) @@ -137,15 +134,14 @@ C ENDIF ENDIF ENDDO + ENDDO C ! *** SXY = dU/dY + dV/dX - DO L=LF,LL + DO K=1,KC + DO L=2,LA SXY(L,K)=DYU1(L,K)+DXV1(L,K) ENDDO ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO C C DO K=1,KC C DO L=2,LA @@ -163,39 +159,21 @@ C ENDDO C IF(AHD.GT.0.0)THEN ! *** CALCULATE SMAGORINSKY HORIZONTAL VISCOSITY -! -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& TMPVAL,DSQR) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) DO K=1,KC - DO L=LF,LL + DO L=2,LA TMPVAL=AHD*DXP(L)*DYP(L) DSQR=DXU1(L,K)*DXU1(L,K)+DYV1(L,K)*DYV1(L,K)+ & SXY(L,K)*SXY(L,K)/4 AH(L,K)=AHO+TMPVAL*SQRT(DSQR) ENDDO ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO ELSEIF(N.LT.10)THEN ! *** ONLY NEED TO ASSIGN INITIALLY -! -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& TMPVAL,DSQR) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) DO K=1,KC - DO L=LF,LL + DO L=2,LA AH(L,K)=AHO ENDDO ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO ENDIF C C *** DSLLC BEGIN BLOCK @@ -248,14 +226,8 @@ C C C ** CALCULATE DIFFUSIVE MOMENTUM FLUXES C -! -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LS,LN) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) DO K=1,KC - DO L=LF,LL + DO L=2,LA LS=LSC(L) LN=LNC(L) ! SANG'S CORRECTION @@ -277,20 +249,10 @@ C ENDDO ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO C ! *** TREAT THE NORTH & WEST WALL SLIPPAGE IF(ISHDMF.EQ.2)THEN -! -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,DY2DZBR,CSDRAG,SLIPFAC, -!$OMP& SXYLN,DX2DZBR,SXYEE) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) - DO L=LF,LL + DO L=2,LA LN=LNC(L) IF(SVBO(LN).LT.0.5)THEN DO K=1,KC @@ -311,9 +273,6 @@ C ENDDO ENDIF ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO ENDIF ! *** ZERO BOUNDARY CELL MOMENTUM DIFFUSION diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHDMF_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHDMF_mpi.for new file mode 100644 index 000000000..aa195cf31 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHDMF_mpi.for @@ -0,0 +1,342 @@ + SUBROUTINE CALHDMF_mpi +C +C *** CALDMF CALCULATES THE HORIZONTAL VISCOSITY AND +C *** DIFFUSIVE MOMENTUM FLUXES. THE VISCOSITY, AH IS CALCULATED USING +C *** SMAGORINSKY'S SUBGRID SCALE FORMULATION PLUS A CONSTANT AHO +C +C *** ONLY VALID FOR ISHDMF.GE.1 +C +C CHANGE RECORD +C REWRITTEN BY PAUL M. CRAIG NOV/DEC 2004 +C 2008-10 SANG YUK (DSLLC) CORRECTED THE DIFFUSIVE MOMENTUM FLUXES COMPUTATION +C + USE GLOBAL + USE MPI + IMPLICIT NONE + INTEGER::L,LN,LS,LW,K,LL,J,I + REAL::SLIPCO,DY2DZBR,DX2DZBR,CSDRAG,SLIPFAC,TMPVAL,DSQR,WVFACT + REAL::DTMPH,DTMPX,AHWVX,SXYLN,SXYEE + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::AHEE + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::AHNN + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::SXY + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::SXY2CC + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::SXY2EE + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::SXY2NN + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::HMC + IF(.NOT.ALLOCATED(AHEE))THEN + ALLOCATE(AHEE(LCM,KCM)) + ALLOCATE(AHNN(LCM,KCM)) + ALLOCATE(SXY(LCM,KCM)) + ALLOCATE(SXY2CC(LCM,KCM)) + ALLOCATE(SXY2EE(LCM,KCM)) + ALLOCATE(SXY2NN(LCM,KCM)) + ALLOCATE(HMC(LCM)) + AHEE=0.0 + AHNN=0.0 + SXY=0.0 + SXY2CC=0.0 + SXY2EE=0.0 + SXY2NN=0.0 + HMC=0.0 + ENDIF + SLIPCO=0.0 +C + AHMAX=AHO +C +C ** CALCUATE TYPE FLAGS +C + S1TIME=MPI_TIC() + IF(ISDRY.GE.1.OR.N.LT.5)THEN + ! *** ICORDYU +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + IF(SUB(L).LT.0.5.AND.SUB(LS).LT.0.5) ICORDYU(L)=0 + IF(SUB(L).GT.0.5.AND.SUB(LS).GT.0.5) ICORDYU(L)=1 + IF(SUB(L).LT.0.5.AND.SUB(LS).GT.0.5) ICORDYU(L)=2 + IF(SUB(L).GT.0.5.AND.SUB(LS).LT.0.5) ICORDYU(L)=3 + ENDDO + ! *** ICORDXV +!$OMP PARALLEL DO PRIVATE(LW) + DO L=LMPI2,LMPILA + LW=L-1 + IF(SVB(L).LT.0.5.AND.SVB(LW).LT.0.5) ICORDXV(L)=0 + IF(SVB(L).GT.0.5.AND.SVB(LW).GT.0.5)THEN + ICORDXV(L)=1 + IF(SUB(L).LT.0.5) ICORDXV(L)=3 + ENDIF + IF(SVB(L).LT.0.5.AND.SVB(LW).GT.0.5) ICORDXV(L)=2 + IF(SVB(L).GT.0.5.AND.SVB(LW).LT.0.5) ICORDXV(L)=3 + ENDDO + ENDIF + MPI_WTIMES(401)=MPI_WTIMES(401)+MPI_TOC(S1TIME) +C +C ** CALCULATE HORIZONTAL VELOCITY SHEARS +C + ! *** SXX+SYY DEFINED AT CELL CENTERS AND STORED IN DXU1(L,K) + S1TIME=MPI_TIC() + IF(AHD.GT.0.0)THEN + SLIPCO=0.5/SQRT(AHD) + ENDIF + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + LN=LNC(L) + ! *** DXU1 = dU/dX, UNITS: 1/S + DXU1(L,K)=SUB(L+1)*(U(L+1,K)-U(L,K))/DXP(L) + ! *** DYV1 = dV/dY, UNITS: 1/S + DYV1(L,K)=SVB(LN )*(V(LN,K)-V(L,K))/DYP(L) + ENDDO + ENDDO + MPI_WTIMES(402)=MPI_WTIMES(402)+MPI_TOC(S1TIME) +C + ! *** DYU1 = dU/dY + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LS,DY2DZBR,CSDRAG,SLIPFAC) + DO L=LMPI2,LMPILA + LS=LSC(L) + IF(ICORDYU(L).EQ.1)THEN + DYU1(L,K)=2.*SVB(L)*(U(L,K)-U(LS,K))/(DYU(L)+DYU(LS)) + ELSE + DYU1(L,K)=0. + ENDIF + IF(ISHDMF.EQ.2)THEN + ! *** HMD WITH WALL EFFECTS + IF(ICORDYU(L).EQ.2)THEN + DY2DZBR=1.+0.5*DYU(LS)/ZBRWALL + CSDRAG=0.16/((LOG(DY2DZBR))**2) + SLIPFAC=SLIPCO*SQRT(CSDRAG) + DYU1(L,K)=-2.*SLIPFAC*U(LS,K)/DYU(LS) + ENDIF + IF(ICORDYU(L).EQ.3)THEN + DY2DZBR=1.+0.5*DYU(L)/ZBRWALL + CSDRAG=0.16/((LOG(DY2DZBR))**2) + SLIPFAC=SLIPCO*SQRT(CSDRAG) + DYU1(L,K)=2.*SLIPFAC*U(L,K)/DYU(L) + ENDIF + ENDIF + ENDDO + ENDDO + MPI_WTIMES(403)=MPI_WTIMES(403)+MPI_TOC(S1TIME) +C + ! *** DXV1 = dV/dX + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LW,DX2DZBR,CSDRAG,SLIPFAC) + DO L=LMPI2,LMPILA + LW=L-1 + IF(ICORDXV(L).EQ.1)THEN + DXV1(L,K)=2.*SUB(L)*(V(L,K)-V(LW,K))/(DXV(L)+DXV(LW)) + ELSE + DXV1(L,K)=0. + ENDIF + IF(ISHDMF.EQ.2)THEN + ! *** WALL EFFECTS + IF(ICORDXV(L).EQ.2)THEN + DX2DZBR=1.+0.5*DXV(LW)/ZBRWALL + CSDRAG=0.16/((LOG(DX2DZBR))**2) + SLIPFAC=SLIPCO*SQRT(CSDRAG) + DXV1(L,K)=-2.*SLIPFAC*V(LW,K)/DXV(LW) + ENDIF + IF(ICORDXV(L).EQ.3)THEN + DX2DZBR=1.+0.5*DXV(L)/ZBRWALL + CSDRAG=0.16/((LOG(DX2DZBR))**2) + SLIPFAC=SLIPCO*SQRT(CSDRAG) + DXV1(L,K)=2.*SLIPFAC*V(L,K)/DXV(L) + ENDIF + ENDIF + ENDDO + ENDDO + MPI_WTIMES(404)=MPI_WTIMES(404)+MPI_TOC(S1TIME) +C + ! *** SXY = dU/dY + dV/dX + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SXY(L,K)=DYU1(L,K)+DXV1(L,K) + ENDDO + ENDDO + MPI_WTIMES(405)=MPI_WTIMES(405)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(AHD.GT.0.0)THEN + ! *** CALCULATE SMAGORINSKY HORIZONTAL VISCOSITY + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(TMPVAL,DSQR) + DO L=LMPI2,LMPILA + TMPVAL=AHD*DXP(L)*DYP(L) + DSQR=DXU1(L,K)*DXU1(L,K)+DYV1(L,K)*DYV1(L,K)+ + & SXY(L,K)*SXY(L,K)/4 + AH(L,K)=AHO+TMPVAL*SQRT(DSQR) + ENDDO + ENDDO + ELSEIF(N.LT.10)THEN + ! *** ONLY NEED TO ASSIGN INITIALLY + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AH(L,K)=AHO + ENDDO + ENDDO + ENDIF + MPI_WTIMES(406)=MPI_WTIMES(406)+MPI_TOC(S1TIME) +C +C *** DSLLC BEGIN BLOCK +C ** CALCULATE HORIZONTAL DIFFUSION DUE TO WAVE BREAKING +C + S1TIME=MPI_TIC() + IF(ISWAVE.EQ.2)THEN + IF(WVLSH.GT.0.0.OR.WVLSX.GT.0.0)THEN + IF(N.LT.NTSWV)THEN + TMPVAL=FLOAT(N)/FLOAT(NTSWV) + WVFACT=0.5-0.5*COS(PI*TMPVAL) + ELSE + WVFACT=1.0 + ENDIF + AHWVX=WVLSX*WVPRD*WVPRD + IF(ISDRY.GT.0)THEN + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(DTMPH,DTMPX) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + DTMPH=WVDISP(L,K)**0.3333 + DTMPX=WVDISP(L,K)/HP(L) ! *** PMC HMP-->HP + AH(L,K)=AH(L,K)+WVFACT*(WVLSH*DTMPH*HP(L) + & +AHWVX*DTMPX) + ENDIF + ENDDO + ENDDO + ELSE + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(DTMPH,DTMPX) + DO L=LMPI2,LMPILA + DTMPH=WVDISP(L,K)**0.3333 + DTMPX=WVDISP(L,K)/HP(L) ! *** PMC HMP-->HP + AH(L,K)=AH(L,K)+WVFACT*(WVLSH*DTMPH*HP(L)+AHWVX*DTMPX) + ENDDO + ENDDO + ENDIF + ENDIF + ENDIF + MPI_WTIMES(407)=MPI_WTIMES(407)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) + MPI_WTIMES(416)=MPI_WTIMES(416)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(DXU1,ic) + MPI_WTIMES(412)=MPI_WTIMES(412)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(DYV1,ic) + MPI_WTIMES(413)=MPI_WTIMES(413)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(SXY,ic) + MPI_WTIMES(414)=MPI_WTIMES(414)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(AH,ic) + MPI_WTIMES(415)=MPI_WTIMES(415)+MPI_TOC(S1TIME) +C +C *** DSLLC END BLOCK +C + IF(N.EQ.2.AND.ISLOG.GT.0.AND.DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='AHDIFF.DIA') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='AHDIFF.DIA') + DO L=2,LA + WRITE(1,1112)IL(L),JL(L),AH(L,KC) + ENDDO + CLOSE(1) + ENDIF +C +C ** CALCULATE DIFFUSIVE MOMENTUM FLUXES +C + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LS,LN) + DO L=LMPI2,LMPILA + LS=LSC(L) + LN=LNC(L) + ! SANG'S CORRECTION + FMDUX(L,K)=2.0*SUB(L)* + & (HP(L)*AH(L,K)*DXU1(L,K)*DYP(L)- + & HP(L-1)*AH(L-1,K)*DXU1(L-1,K)*DYP(L-1)) + + FMDUY(L,K)=SVB(LN)* + & (DXU(LN)*HU(LN)*AH(LN,K)*SXY(LN,K)- + & DXU(l)*HU(L)*AH(L,K)*SXY(L,K)) + + FMDVY(L,K)=2.0*SVB(L)* + & (DXP(L)*HP(L)*AH(L,K)*DYV1(L,K)- + & DXP(LS)*HP(LS)*AH(LS,K)*DYV1(LS,K)) + + FMDVX(L,K)=SUB(L+1)* + & (DYV(L+1)*HV(L+1)*AH(L+1,K)*SXY(L+1,K)- + & DYV(L)*HV(L)*AH(L,K)*SXY(L,K)) + + ENDDO + ENDDO + MPI_WTIMES(408)=MPI_WTIMES(408)+MPI_TOC(S1TIME) +C + ! *** TREAT THE NORTH & WEST WALL SLIPPAGE + S1TIME=MPI_TIC() + IF(ISHDMF.EQ.2)THEN +!$OMP PARALLEL DO PRIVATE(LN,DY2DZBR,CSDRAG,SLIPFAC,SXYLN,DX2DZBR,SXYEE) + DO L=LMPI2,LMPILA + LN=LNC(L) + IF(SVBO(LN).LT.0.5)THEN + DO K=1,KC + DY2DZBR=1.+0.5*DYU(L)/ZBRWALL + CSDRAG=0.16/((LOG(DY2DZBR))**2) + SLIPFAC=SLIPCO*SQRT(CSDRAG) + SXYLN=-2.*SLIPFAC*U(L,K)/DYU(L) + FMDUY(L,K)=DXU(L)*HP(L)*AH(L,K)*(SXYLN-SXY(L ,K)) + ENDDO + ENDIF + IF(SUBO(L+1).LT.0.5)THEN + DO K=1,KC + DX2DZBR=1.+0.5*DXV(L)/ZBRWALL + CSDRAG=0.16/((LOG(DX2DZBR))**2) + SLIPFAC=SLIPCO*SQRT(CSDRAG) + SXYEE=-2.*SLIPFAC*V(L,K)/DXV(L) + FMDVX(L,K)=DYV(L)*HP(L)*AH(L,K)*(SXYEE-SXY(L,K)) + ENDDO + ENDIF + ENDDO + ENDIF + MPI_WTIMES(409)=MPI_WTIMES(409)+MPI_TOC(S1TIME) + + ! *** ZERO BOUNDARY CELL MOMENTUM DIFFUSION + S1TIME=MPI_TIC() + DO LL=1,NBCS + L=LBCS(LL) + DO K=1,KC + FMDUX(L,K)=0.0 + FMDUY(L,K)=0.0 + FMDVY(L,K)=0.0 + FMDVX(L,K)=0.0 + ENDDO + ENDDO + MPI_WTIMES(410)=MPI_WTIMES(410)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + IF(N.EQ.2.AND.DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='AHD2.DIA') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='AHD2.DIA') + DO L=2,LA + I=IL(L) + J=JL(L) + DO K=1,KC + WRITE(1,1111)N,I,J,K,FMDUX(L,K),FMDVY(L,K),FMDUY(L,K), + & FMDVX(L,K),AH(L,K),DYU1(L,K),DYV1(L,K) + ENDDO + ENDDO + CLOSE(1) + ENDIF + MPI_WTIMES(411)=MPI_WTIMES(411)+MPI_TOC(S1TIME) + 1111 FORMAT(4I5,7E13.4) + 1112 FORMAT(2I5,8E13.4) + RETURN + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHEAT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHEAT.for index d59a42aef..fe9475c1e 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHEAT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHEAT.for @@ -76,7 +76,30 @@ C CHANGE RECORD C ** SUBROUTINE CALHEAT CALCULATES SURFACE AND INTERNAL HEAT SOURCES C ** AND SINKS IN THE HEAT (TEM) TRANSPORT EQUATION C - USE GLOBAL + USE GLOBAL + IMPLICIT NONE + + INTEGER::I,J,K,L,L1,IS,ND + INTEGER::LL,LF + INTEGER::ISTL_ + REAL::C1,C2 + REAL::RB,RC,RE,ET,FW + REAL::TMPVAL,TMPKC + REAL::USPD,UBED,VBED + REAL::CLDFAC + REAL::TFAST,TFAST1,TSLOW,TSLOW1 + REAL::T1,T2 + REAL::BOT,TOP,EXPTOP,EXPBOT + REAL::GAMMA + REAL::TIMTMP + REAL::NDUM + REAL::SHDAY,SHDDAY,PSHADE0,PSHADE_OLD,NDATASHD + REAL::SRO,SRON,SVPW + REAL::RAN,RSN + REAL::DTHEQT + REAL::THICK,TFLUX + REAL::TSS_ABOVE,WQCHL_ABOVE,POM_ABOVE + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::NETRAD REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TBEDTHK REAL,SAVE,ALLOCATABLE,DIMENSION(:)::HDEP @@ -85,6 +108,15 @@ C !REAL,SAVE :: PTIME !REAL,SAVE :: PMCTOL REAL K_ABOVE + REAL WQCHLS_ABOVE + REAL TSSS_ABOVE + REAL POMS_ABOVE + REAL CSHE + WQCHLS_ABOVE = 0.0 + TSSS_ABOVE = 0.0 + POMS_ABOVE = 0.0 + EXPBOT = 0.0 + CSHE = 0.0 C IF(.NOT.ALLOCATED(NETRAD))THEN ALLOCATE(NETRAD(LCM,KCM)) @@ -260,22 +292,14 @@ CPMC DELT=DT2 IF(ISTOPT(2).EQ.1)THEN ! *** FULL HEAT BALANCE WITH ATMOSPHERIC LINKAGE -! -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& SVPW,CLDFAC,RAN,FW,RE,RC, -!$OMP& RB,TFAST,TFAST1,TSLOW,TSLOW1, -!$OMP& RSN,C2,UBED,VBED,USPD,TMPVAL, -!$OMP& C1) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) - ! NET HEAT FLUX = RSN+RAN-RB-RE-RC (WATT/M2) - DO L=LF,LL - ! *** SET UP MIN DEPTH + ! *** SET UP MIN DEPTH + DO L=2,LA HDEP(L)=MAX(HP(L),0.) + ENDDO - + ! NET HEAT FLUX = RSN+RAN-RB-RE-RC (WATT/M2) + DO L=2,LA SVPW=(10.**((0.7859+0.03477*TEM(L,KC))/ & (1.+0.00412*TEM(L,KC)))) @@ -315,14 +339,14 @@ CPMC DELT=DT2 TSLOW=SWRATNS*(Z(KC)-1.) TSLOW1=SWRATNS*(Z(KC-1)-1.) IF(FSWRATF.LT.1.)THEN - DO L=LF,LL + DO L=2,LA RSN=SOLSWRT(L)* & ( FSWRATF*(EXP(TFAST*HDEP(L))-EXP(TFAST1*HDEP(L))) & +(1.-FSWRATF)*(EXP(TSLOW*HDEP(L))-EXP(TSLOW1*HDEP(L)))) NETRAD(L,KC)=NETRAD(L,KC)+RSN ENDDO ELSE - DO L=LF,LL + DO L=2,LA RSN=SOLSWRT(L)*(1.-EXP(TFAST1*HDEP(L))) NETRAD(L,KC)=NETRAD(L,KC)+RSN ENDDO @@ -337,14 +361,14 @@ CPMC DELT=DT2 IF(FSWRATF.LT.1.)THEN TSLOW=SWRATNS*(Z(K)-1.) TSLOW1=SWRATNS*(Z(K-1)-1.) - DO L=LF,LL + DO L=2,LA RSN=SOLSWRT(L)* & ( FSWRATF*(EXP(TFAST*HDEP(L))-EXP(TFAST1*HDEP(L))) & +(1.-FSWRATF)*(EXP(TSLOW*HDEP(L))-EXP(TSLOW1*HDEP(L)))) NETRAD(L,K)=RSN ENDDO ELSE - DO L=LF,LL + DO L=2,LA RSN=SOLSWRT(L)* & (EXP(TFAST*HDEP(L))-EXP(TFAST1*HDEP(L))) NETRAD(L,K)=RSN @@ -357,7 +381,7 @@ CPMC DELT=DT2 TFAST=SWRATNF*(Z(0)-1.) IF(FSWRATF.LT.1.)THEN TSLOW=SWRATNS*(Z(0)-1.) - DO L=LF,LL + DO L=2,LA UBED=0.5*( U(L,1)+U(L+1,1) ) VBED=0.5*( V(L,1)+V(LNC(L),1) ) USPD=SQRT( UBED*UBED+VBED*VBED ) @@ -372,7 +396,7 @@ CPMC DELT=DT2 ENDIF ENDDO ELSE - DO L=LF,LL + DO L=2,LA UBED=0.5*( U(L,1)+U(L+1,1) ) VBED=0.5*( V(L,1)+V(LNC(L),1) ) USPD=SQRT( UBED*UBED+VBED*VBED ) @@ -393,48 +417,47 @@ CPMC DELT=DT2 ! *** CP = 4179.0 Specific Heat (J / kg / degC) ! *** 0.2393E-6 = 1/RHO/CP C1=DELT*DZIC(K)*0.2393E-6 - DO L=LF,LL + DO L=2,LA TEM(L,K)=TEM(L,K)+HPI(L)*C1*NETRAD(L,K) ENDDO ENDDO IF(ISDRY.GT.0.AND.ISTOPT(2).EQ.1)THEN - DO L=LF,LL + DO L=2,LA IF(IMASKDRY(L).EQ.1.) TEMB(L)=TATMT(L) ENDDO ENDIF ELSE ! IF(IASWRAD.EQ.1)THEN - C1=DELT*DZIC(KC)*0.2393E-6 - DO L=LF,LL - ! *** ADSORB SW SOLR RAD TO TO SURFACE LAYER + ! *** ADSORB SW SOLR RAD TO TO SURFACE LAYER + DO L=2,LA NETRAD(L,KC)=NETRAD(L,KC)+SOLSWRT(L) - ! *** NOW FINALIZE THE TEMPERATURE + ENDDO + + ! *** NOW FINALIZE THE TEMPERATURE + C1=DELT*DZIC(KC)*0.2393E-6 + DO L=2,LA TEM(L,KC)=TEM(L,KC)+HPI(L)*C1*NETRAD(L,KC) ENDDO ENDIF -! - enddo -!$OMP END PARALLEL DO + ELSEIF(ISTOPT(2).EQ.2)THEN ! *** IMPLEMENT EXTERNALLY SPECIFIED EQUILIBRIUM TEMPERATURE FORMULATION TMPKC=DELT/DZC(KC) -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 DO L=LF,LL ! [ GEOSR 2010.5.13 -c TEM(L,KC)=TEM(L,KC)-TMPKC*CLOUDT(L)*HPI(L)*(TEM(L,KC) -c & -TATMT(L)) - TEM(L,KC)=TEM(L,KC)-TMPKC*SOLSWRT(L)*HPI(L)*(TEM(L,KC) + TEM(L,KC)=TEM(L,KC)-TMPKC*CLOUDT(L)*HPI(L)*(TEM(L,KC) & -TATMT(L)) +c TEM(L,KC)=TEM(L,KC)-TMPKC*SOLSWRT(L)*HPI(L)*(TEM(L,KC) +c & -TATMT(L)) ! GEOSR 2010.5.13 ] ENDDO ENDDO -!$OMP END PARALLEL DO + ELSEIF(ISTOPT(2).EQ.3)THEN ! *** IMPLEMENT CONSTANT COEFFICIENT EQUILIBRIUM TEMPERATURE FORMULATION DTHEQT=DELT*HEQT*FLOAT(KC) @@ -600,13 +623,8 @@ c & -TATMT(L)) ! *** APPLY DRY CELL CORRECTIONS IF(ISDRY.GT.0)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(.NOT.LMASKDRY(L))THEN TEM(L,K)=TATMT(L) ! *** BEGIN PMC @@ -624,11 +642,9 @@ c ENDIF ENDDO ENDDO -c - enddo ENDIF - 600 FORMAT(4I5,2E12.4) +C 600 FORMAT(4I5,2E12.4) RETURN END @@ -643,11 +659,27 @@ c SUBROUTINE HEAT_EXCHANGE USE GLOBAL + IMPLICIT NONE ******* Tupe declaration - REAL JDAY - INTEGER*4 IDAY + REAL JDAY + INTEGER*4 IDAY + INTEGER::J + REAL::ET,ETP + REAL::BETA + REAL::TAIR,TD,TD_C,TDEW,WIND_MPH,TSTAR + REAL::DEG_F,DEG_C + REAL::DECL,H + REAL::THOUR,PMC1,EQTNEW + REAL::X + REAL::VAPORP + REAL::CLD,CLD10 + REAL::STANDARD,SINAL + REAL::A0,ASIN + REAL::SRO,SRON,SRO_BR + + REAL::WSPD,ATMPR,FW,CSHE,RA,TA_C ******* Allocate/Dimension declaration @@ -658,7 +690,6 @@ c Real, SAVE :: TDEW_F, TAIR_F, WIND_2M Real, SAVE :: TIMENEXT - ******* Data declaration DATA MPS_TO_MPH /2.23714/, @@ -681,7 +712,7 @@ c ************************************************************************ ENTRY SHORT_WAVE_RADIATION(WSPD,TD,TAIR,CLD,ATMPR,SRO,SRON) - + ******* Input Conversions IF(TD.LT.1.1.AND.IRELH(NASER).EQ.1)THEN ! *** TD IS RELATIVE HUMIDITY. CONVERT TO DEW POINT @@ -718,7 +749,7 @@ c ! *** Day of the Year THOUR = (TIMEDAY-INT(TIMEDAY))*24.0 - IDAY = TIMEDAY-INT(TIMEDAY/365.)*365. + IDAY = INT(TIMEDAY-INT(TIMEDAY/365.)*365.,KIND(IDAY)) IDAY = IDAY+INT(INT(TIMEDAY/365.)/4.) JDAY = REAL(IDAY) PMC1 = (2.*PI*(JDAY-1.))/365. @@ -748,7 +779,7 @@ c ************************************************************************ ENTRY EQUILIBRIUM_TEMPERATURE(SRON,ET,CSHE) - + ******* British units ! *** SRON Should already be adjusted for Shading & Reflection diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHEAT_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHEAT_mpi.for new file mode 100644 index 000000000..f45b32041 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHEAT_mpi.for @@ -0,0 +1,818 @@ + SUBROUTINE CALHEAT_mpi(ISTL_) +C +C Subroutine CALHEAT takes the information from the atmospheric boundary +C file and the wind forcing file and calculates the net heat flux across +C the water surface boundary. The heat flux is then used to update the +C water temperature either in the surface cells, or distributed across +C the cells in the vertical and into the bottom. The subroutine has +C three options these are: +C +C ISOPT(2)=1: Full surface and internal heat transfer calculation +C using meteorologic data from input stream. +C IASWRAD=0: ADSORB SW SOLR RAD TO ALL LAYERS AND BED +C IASWRAD=1: ADSORB SW SOLR RAD TO TO SURFACE LAYER +C ISOPT(2)=2: Transient equilibrium surface heat transfer calculation +C using external equilibrium temperature and heat transfer +C coefficient data from the meteorologic input data. +C ISOPT(2)=3: Equilibrium surface heat transfer calculation using constant +C equilibrium temperature and heat transfer coefficients +C HEQT and TEMO read in through input stream. +C ISOPT(2)=4: Equilibrium surface heat transfer calculation using algorithm +C from CE-QUAL-W2. +C +C The heat flux terms are derived from a paper by Rosati +C and Miyakoda (1988) entitled "A General Circulation Model for Upper Ocean +C Simulation". The heat flux is prescribed by term for the following +C influxes and outfluxes: +C +C - Short Wave Incoming Radiation (+) +C - Net Long Wave Radiation (+/-) +C - Sensible Heat Flux (convection -) +C - Latent Heat Flux (evaporation +/-) +C +C Two formulations of the Latent Heat Flux are provided. The first is from +C the Rosati and Miyakoda paper, the second is an alternate formulation by +C Brady, Graves, and Geyer (1969). The second formulation was taken from +C "Hydrodynamics and Transport for Water Quality Modeling" (Martin and +C McCutcheon, 1999). The Rosati and Miyakoda formulation will have zero +C evaporative cooling or heating if wind speed goes to zero. The Brady, +C Graves, and Geyer formulation provides for a minimum evaporative cooling +C under zero wind speed. +C +C +C VARIABLE LIST: +C +C CLOUDT = Cloud cover (0 to 10) +C HCON = Sensible heat flux (W/m2) +C HLAT = Latent heat flux (W/m2) +C HLWBR = Net longwave radiation (atmospheric long wave plus back +C radiation, W/m2) +C SOLSWRT = Short wave incoming radiation (W/m2) +C SVPW = Saturation vapor pressure in mb based upon the water surface +C temperature +C TATMT = Temperature of air above water surface (deg C) +C TEM = Water temperature in cell (deg C) +C VPA = Vapor pressure of air at near surface air temperature (mb) +C WINDST = Wind speed at 10 meters over cell surface (m/s) +C +C MODIFICATION HISTORY: +C +C Date Author Comments +C ---------- ------------------ --------------------------------------------- +C 06/01/1992 John M. Hamrick Orignial author +C 11/07/2000 Steven Peene Cleaned code, provided more detailed +C descriptions, added alternate formulation +C for latent heat flux, separated out +C individual heat flux terms +C 11/01/2005 Paul M. Craig Added Option 4, to use the Equilibrium Temperature +C algorithym from CE-QUAL-W2. Also added the sub-option +C under this option to couple or decouple the bottom temperature +C to the water column temperatures. +C Added the ability to input spatially variable bed temps and +C thermally active bed thicknesses. +C Also cleaned up the code and added structure. +C +C CHANGE RECORD +C ** SUBROUTINE CALHEAT CALCULATES SURFACE AND INTERNAL HEAT SOURCES +C ** AND SINKS IN THE HEAT (TEM) TRANSPORT EQUATION +C + USE GLOBAL + USE MPI + + IMPLICIT NONE + + INTEGER::I,J,K,L,L1,IS,ND + INTEGER::LL,LF + INTEGER::ISTL_ + REAL::C1,C2 + REAL::RB,RC,RE,ET,FW + REAL::TMPVAL,TMPKC + REAL::USPD,UBED,VBED + REAL::CLDFAC + REAL::TFAST,TFAST1,TSLOW,TSLOW1 + REAL::T1,T2 + REAL::BOT,TOP,EXPTOP,EXPBOT + REAL::GAMMA + REAL::TIMTMP + REAL::NDUM + REAL::SHDAY,SHDDAY,PSHADE0,PSHADE_OLD,NDATASHD + REAL::SRO,SRON,SVPW + REAL::RAN,RSN + REAL::DTHEQT + REAL::THICK,TFLUX + REAL::TSS_ABOVE,WQCHL_ABOVE,POM_ABOVE + + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::NETRAD + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TBEDTHK + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::HDEP + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RADBOT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::FLUXTB + !REAL,SAVE :: PTIME + !REAL,SAVE :: PMCTOL + REAL K_ABOVE + INTEGER ::NRANK + REAL TSSS_ABOVE + REAL WQCHLS_ABOVE + REAL POMS_ABOVE + REAL CSHE + TSSS_ABOVE=0.0 + WQCHLS_ABOVE=0.0 + POMS_ABOVE=0.0 + CSHE=0.0 +C + IF(.NOT.ALLOCATED(NETRAD))THEN + ALLOCATE(NETRAD(LCM,KCM)) + ALLOCATE(TBEDTHK(LCM)) + ALLOCATE(HDEP(LCM)) + ALLOCATE(RADBOT(LCM)) + ALLOCATE(FLUXTB(LCM)) + RADBOT=0.0 !SCJ + FLUXTB=0.0 !SCJ + + ! *** Ininitialze Heat Exchange Terms + IF(MYRANK.EQ.0) PRINT *,'CALHEAT: INITIALIZING' + CALL HEAT_EXCHANGE + !PMCTOL=0.1 + NETRAD=0. + HDEP=0. + TBEDTHK=0. + IF((ISTOPT(2).EQ.1.AND.IASWRAD.EQ.0).OR.ISTOPT(2).EQ.4)THEN + IF(DABEDT.GT.0.)THEN + IF(MYRANK.EQ.0) + & PRINT *,'CALHEAT: SETTING CONSTANT THICKNESS TO:',DABEDT + DO L=2,LA + TBEDTHK(L)=DABEDT + ENDDO + ELSE + ! *** READ IN THE SPATIALLY VARYING INIT T AND BED THICKNESS (DABEDT) + IF(MYRANK.EQ.0) + & PRINT *,'CALHEAT: READ IN THE SPATIALLY VARYING INIT T AND + & BED THICKNESS: TEMB.INP' + DO L=2,LA + TBEDTHK(L)=ABS(DABEDT) + IF(ISCI(2).EQ.0)TEMB(L)=ABS(TBEDIT) + ENDDO + OPEN(1001,FILE='TEMB.INP',ERR=1000,STATUS='OLD') + DO IS=1,4 + READ(1001,*) + ENDDO + DO L1 = 2, LA + READ(1001,*,END=1000) I,J,T1,T2 + L=LIJ(I,J) + IF(ISCI(2).EQ.0)TEMB(L)=T1 + TBEDTHK(L)=T2 + ENDDO + 1000 CLOSE(1001) + ENDIF + ENDIF + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'1HEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF +!{GeoSR, YSSONG, ICE COVER, 1111031 +C IF(ISTOPT(2).EQ.1.OR.ISTOPT(2).EQ.4)THEN +C DO L=2,LA +C PSHADE(L)=1.0 +C ENDDO +C IF(USESHADE)THEN +C ! *** READ IN THE SPATIALLY VARYING INIT T AND BED THICKNESS (DABEDT) +C PRINT *, +C * 'CALHEAT: READ IN SPATIALLY VARYING SHADE: PSHADE.INP' +C OPEN(1001,FILE='PSHADE.INP',ERR=1010,STATUS='OLD') +C DO IS=1,4 +C READ(1001,*) +C ENDDO +C DO L1 = 2, LA +C READ(1001,*,END=1010) I,J,T1 +C L=LIJ(I,J) +C PSHADE(L)=T1 +C ENDDO +C 1010 CLOSE(1001) +C ELSE +C PRINT *,'CALHEAT: SETTING CONSTANT SHADE TO: 1.0 (NO SHADE)' +C ENDIF +C ENDIF +!} + + IF(DEBUG.AND.MYRANK.EQ.0)THEN + PRINT *,'CALHEAT: Bed Temp(L=2):', TEMB(2) + OPEN(77,file='calheat.dia',status='unknown') + CLOSE(77,status='DELETE') + OPEN(77,file='calheat.dia',status='NEW') + WRITE(77,998)'TIMEDAY','SRON','ET','TD_C','TA_C','TDEW_F', + & 'TAIR_F','FW' + 998 FORMAT(A11,8A9) + ENDIF + ENDIF + +!{GeoSR, YSSONG, ICE COVER, 1111031 + S2TIME=MPI_TIC() + IF(USESHADE)THEN + IF(ISDYNSTP.EQ.0)THEN + TIMTMP=(DT*FLOAT(N)+TCON*TBEGIN)/86400. + ELSE + TIMTMP=TIMESEC/86400. + ENDIF + + IF(TIMTMP .GE. SHDDAY)THEN + IF(ISTOPT(2).EQ.1.OR.ISTOPT(2).EQ.4)THEN + DO L=2,LA + PSHADE(L)=1.0 + ENDDO + + IF(N.EQ.1)THEN + ! *** READ IN THE SPATIALLY VARYING INIT T (READ IN SPATIALLY VARYING SHADE: PSHADE.INP') + OPEN(1001,FILE='PSHADE.INP',STATUS='UNKNOWN') +C +C SKIP OVER ALL COMMENT CARDS AT BEGINNING OF FILE: +C + DO NDUM=1,3 + READ(1001,*) + ENDDO +C +C SEQUENTIALLY READ ICE COVER FILE UNTIL THE APPROPRIATE + ENDIF + +C TIME IS FOUND: +C SHDAY = CURRENT DAY AT WHICH ICE COVER IS IN EFFECT +C SHDDAY = NEXT DAY AT WHICH ICE COVER CHANGES (PASSED TO MAIN PROG +C + 10 READ(1001, *, END=15) SHDDAY,NDATASHD + IF(SHDDAY .GT. TIMTMP) GOTO 20 + SHDAY = SHDDAY + DO NDUM=1,NDATASHD + READ(1001,*,END=15) I,J,PSHADE0 + L=LIJ(I,J) + PSHADE(L)=PSHADE0 + ENDDO + GOTO 10 +C +C UNEXPECTED END-OF-FILE ENCOUNTERED: +C + 15 WRITE(2,16) + 16 FORMAT(//,' ************* WARNING *************',/, + & ' END-OF-FILE ENCOUNTERED IN FILE: ', A20,/,/ + & ' ICE COVER PSHADE SET TO VALUES CORRESPONDING ', + & ' TO LAST DAY IN FILE.',/) + SHDDAY=(TCON*TBEGIN + NTC*TIDALP)/86400.0 ! *** PMC SINGLE LINE + 20 CONTINUE + BACKSPACE(1001) + ENDIF + ENDIF + ENDIF + MPI_WTIMES(751)=MPI_WTIMES(751)+MPI_TOC(S2TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'2HEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF +!} +C + ! *** DSLLC BEGIN CHANGE +CPMC DELT=DT2 +CPMC IF(ISTL_.EQ.2)THEN +CPMC DELT=DT +CPMC ENDIF +CPMC DELT=DT2 + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + ELSE + DELT=DTDYN + END IF + ELSE + DELT=DT2 + ENDIF + ! *** DSLLC END CHANGE + + ! *** OVERWRITE THE INPUT SOLAR RAD WITH A COMPUTED ONE + IF(COMPUTESOLRAD)THEN + S2TIME=MPI_TIC() + CALL SHORT_WAVE_RADIATION(WINDST(2),RHA(2),TATMT(2),CLOUDT(2), + & PATMT(2),SRO,SRON) + MPI_WTIMES(752)=MPI_WTIMES(752)+MPI_TOC(S2TIME) + S2TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + ! *** USE COMPUTED SRO + SOLSWRT(L)=SRON + ENDDO + MPI_WTIMES(753)=MPI_WTIMES(753)+MPI_TOC(S2TIME) + ENDIF + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'3HEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + IF(USESHADE)THEN + S2TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + ! *** APPLY PSHADE FACTORS + SOLSWRT(L)=SOLSWRT(L)*PSHADE(L) + ENDDO + MPI_WTIMES(754)=MPI_WTIMES(754)+MPI_TOC(S2TIME) + ENDIF + IF(ISTOPT(2).EQ.1)THEN + ! *** FULL HEAT BALANCE WITH ATMOSPHERIC LINKAGE + + ! *** SET UP MIN DEPTH + S2TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + HDEP(L)=MAX(HP(L),0.) + ENDDO + MPI_WTIMES(755)=MPI_WTIMES(755)+MPI_TOC(S2TIME) + + ! NET HEAT FLUX = RSN+RAN-RB-RE-RC (WATT/M2) + S2TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(SVPW,CLDFAC,RAN,FW,RE,RC,RB) + DO L=LMPI2,LMPILA + SVPW=(10.**((0.7859+0.03477*TEM(L,KC))/ + & (1.+0.00412*TEM(L,KC)))) + ! *** Net atmospheric radiation (Diffusive) + CLDFAC=1.0+0.0017*CLOUDT(L)**2 + ! ** .5153153831e-12 = 1000.0/3600.0*9.37E-6*2.0411E-7*0.97 + RAN=0.51531538e-12*(TATMT(L)+273.15)**6*CLDFAC + ! *** Evaporation + FW=9.2+0.46*WINDST(L)**2; + RE=FW*(SVPW-VPA(L)); + ! *** Conduction + RC=0.47*FW*(TEM(L,KC)-TATMT(L)) + ! *** Longwave back radiation + ! *** 5.443E-8 = 5.67E-8 * 0.97 + RB=5.443E-8*(TEM(L,KC)+273.15)**4 + NETRAD(L,KC)=RAN-RB-RE-RC +!{GeoSR, 2015.01.15 JHLEE, NEGATIVE WATER TEMPERATURE PROBLEM + IF(ISICE.EQ.1)THEN + IF(TEM(L,KC).LT.0.0)THEN + NETRAD(L,KC)=0.0 + ENDIF + ENDIF +!} GeoSR, 2015.01.15 JHLEE, NEGATIVE WATER TEMPERATURE PROBLEM + ENDDO + MPI_WTIMES(756)=MPI_WTIMES(756)+MPI_TOC(S2TIME) + ! *** NET SHORTWAVE SOLAR RADIATION + IF(IASWRAD.EQ.0.)THEN + ! *** ADSORB SW SOLR RAD TO ALL LAYERS AND BED + + ! *** SURFACE LAYER + TFAST=SWRATNF*(Z(KC)-1.) + TFAST1=SWRATNF*(Z(KC-1)-1.) + TSLOW=SWRATNS*(Z(KC)-1.) + TSLOW1=SWRATNS*(Z(KC-1)-1.) + S2TIME=MPI_TIC() + IF(FSWRATF.LT.1.)THEN +!$OMP PARALLEL DO PRIVATE(RSN) + DO L=LMPI2,LMPILA + RSN=SOLSWRT(L)* + & ( FSWRATF*(EXP(TFAST*HDEP(L))-EXP(TFAST1*HDEP(L))) + & +(1.-FSWRATF)*(EXP(TSLOW*HDEP(L))-EXP(TSLOW1*HDEP(L)))) + NETRAD(L,KC)=NETRAD(L,KC)+RSN + ENDDO + ELSE +!$OMP PARALLEL DO PRIVATE(RSN) + DO L=LMPI2,LMPILA + RSN=SOLSWRT(L)*(1.-EXP(TFAST1*HDEP(L))) + NETRAD(L,KC)=NETRAD(L,KC)+RSN + ENDDO + ENDIF + MPI_WTIMES(757)=MPI_WTIMES(757)+MPI_TOC(S2TIME) + ! *** ALL REMAINING LAYERS + S2TIME=MPI_TIC() + IF(KC.GT.1)THEN + DO K=1,KS + TFAST=SWRATNF*(Z(K)-1.) + TFAST1=SWRATNF*(Z(K-1)-1.) + C2=DELT*DZIC(K)*0.2393E-6 + IF(FSWRATF.LT.1.)THEN + TSLOW=SWRATNS*(Z(K)-1.) + TSLOW1=SWRATNS*(Z(K-1)-1.) +!$OMP PARALLEL DO PRIVATE(RSN) + DO L=LMPI2,LMPILA + RSN=SOLSWRT(L)* + & ( FSWRATF*(EXP(TFAST*HDEP(L))-EXP(TFAST1*HDEP(L))) + & +(1.-FSWRATF)*(EXP(TSLOW*HDEP(L))-EXP(TSLOW1*HDEP(L)))) + NETRAD(L,K)=RSN + ENDDO + ELSE +!$OMP PARALLEL DO PRIVATE(RSN) + DO L=LMPI2,LMPILA + RSN=SOLSWRT(L)* + & (EXP(TFAST*HDEP(L))-EXP(TFAST1*HDEP(L))) + NETRAD(L,K)=RSN + ENDDO + ENDIF + ENDDO + ENDIF + MPI_WTIMES(758)=MPI_WTIMES(758)+MPI_TOC(S2TIME) + ! *** Distribute heat flux to the bed for each grid cell. + S2TIME=MPI_TIC() + TFAST=SWRATNF*(Z(0)-1.) + IF(FSWRATF.LT.1.)THEN + TSLOW=SWRATNS*(Z(0)-1.) +!$OMP PARALLEL DO PRIVATE(UBED,VBED,USPD,TMPVAL) + DO L=LMPI2,LMPILA + UBED=0.5*( U(L,1)+U(L+1,1) ) + VBED=0.5*( V(L,1)+V(LNC(L),1) ) + USPD=SQRT( UBED*UBED+VBED*VBED ) + TMPVAL=(HTBED1*USPD+HTBED2)*(TEM(L,1)-TEMB(L)) + NETRAD(L,1)=NETRAD(L,1)-TMPVAL/0.2393E-6 + ! *** UPDATE BOTTOM + IF(TBEDIT.GT.0.)THEN + TEMB(L)=TEMB(L) + (TMPVAL + 0.2393E-6*SOLSWRT(L)* + & (FSWRATF *EXP(TFAST*HDEP(L)) + & +(1.-FSWRATF)*EXP(TSLOW*HDEP(L))))*DELT/TBEDTHK(L) + ENDIF + ENDDO + ELSE +!$OMP PARALLEL DO PRIVATE(UBED,VBED,USPD,TMPVAL) + DO L=LMPI2,LMPILA + UBED=0.5*( U(L,1)+U(L+1,1) ) + VBED=0.5*( V(L,1)+V(LNC(L),1) ) + USPD=SQRT( UBED*UBED+VBED*VBED ) + TMPVAL=(HTBED1*USPD+HTBED2)*(TEM(L,1)-TEMB(L)) + NETRAD(L,1)=NETRAD(L,1)-TMPVAL/0.2393E-6 + + ! *** UPDATE BOTTOM + IF(TBEDIT.GT.0.)THEN + TEMB(L)=TEMB(L) + (TMPVAL + 0.2393E-6*SOLSWRT(L)* + & FSWRATF*EXP(TFAST*HDEP(L)))*DELT/TBEDTHK(L) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(759)=MPI_WTIMES(759)+MPI_TOC(S2TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'4HEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + ! *** NOW FINALIZE THE TEMPERATURE + S2TIME=MPI_TIC() + DO K=1,KC + ! *** RHO = 1000.0 Density (kg / m^3) + ! *** CP = 4179.0 Specific Heat (J / kg / degC) + ! *** 0.2393E-6 = 1/RHO/CP + C1=DELT*DZIC(K)*0.2393E-6 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TEM(L,K)=TEM(L,K)+HPI(L)*C1*NETRAD(L,K) + ENDDO + ENDDO + IF(ISDRY.GT.0.AND.ISTOPT(2).EQ.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(IMASKDRY(L).EQ.1.) TEMB(L)=TATMT(L) + ENDDO + ENDIF + MPI_WTIMES(760)=MPI_WTIMES(760)+MPI_TOC(S2TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'5HEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + + ELSE ! IF(IASWRAD.EQ.1)THEN + + ! *** ADSORB SW SOLR RAD TO TO SURFACE LAYER + S2TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + NETRAD(L,KC)=NETRAD(L,KC)+SOLSWRT(L) + ENDDO + ! *** NOW FINALIZE THE TEMPERATURE + C1=DELT*DZIC(KC)*0.2393E-6 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TEM(L,KC)=TEM(L,KC)+HPI(L)*C1*NETRAD(L,KC) + ENDDO + MPI_WTIMES(761)=MPI_WTIMES(761)+MPI_TOC(S2TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'6HEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + + ENDIF + + ELSEIF(ISTOPT(2).EQ.2)THEN + + ! *** IMPLEMENT EXTERNALLY SPECIFIED EQUILIBRIUM TEMPERATURE FORMULATION + S2TIME=MPI_TIC() + TMPKC=DELT/DZC(KC) + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO L=LF,LL +! [ GEOSR 2010.5.13 + TEM(L,KC)=TEM(L,KC)-TMPKC*CLOUDT(L)*HPI(L)*(TEM(L,KC) + & -TATMT(L)) +c TEM(L,KC)=TEM(L,KC)-TMPKC*SOLSWRT(L)*HPI(L)*(TEM(L,KC) +c & -TATMT(L)) +! GEOSR 2010.5.13 ] + ENDDO + ENDDO + MPI_WTIMES(762)=MPI_WTIMES(762)+MPI_TOC(S2TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'7HEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + + ELSEIF(ISTOPT(2).EQ.3)THEN + + ! *** IMPLEMENT CONSTANT COEFFICIENT EQUILIBRIUM TEMPERATURE FORMULATION + S2TIME=MPI_TIC() + DTHEQT=DELT*HEQT*FLOAT(KC) + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO L=LF,LL + TEM(L,KC)=TEM(L,KC)-DTHEQT*HPI(L)*(TEM(L,KC)-TEMO) + ENDDO + ENDDO + MPI_WTIMES(763)=MPI_WTIMES(763)+MPI_TOC(S2TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'8HEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + + ELSEIF(ISTOPT(2).EQ.4)THEN + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'9HEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + ! *** IMPLEMENT W2 EQUILIBRIUM TEMPERATURE FORMULATION + S2TIME=MPI_TIC() + IF(.NOT.COMPUTESOLRAD)THEN + ! *** MUST MAKE AT LEAST ONE CALL TO THIS TO INITIALIZE VARIABLES + CALL SHORT_WAVE_RADIATION(WINDST(2),RHA(2),TATMT(2),CLOUDT(2), + & PATMT(2),SRO,SRON) + ENDIF + MPI_WTIMES(764)=MPI_WTIMES(764)+MPI_TOC(S2TIME) + ! *** SWRATNF - Background/Clear Water Extinction Coefficient + ! *** SWRATNS - Light Extinction for TSS (1/m per g/m3) + ! *** FSWRATF - Fraction of Solar Rad Absobed in the Surface Layer + ! *** HTBED2 - Bottom Heat Exchange Coefficient (W/m2/s) + S2TIME=MPI_TIC() + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'AHEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + PSHADE_OLD=-1. + DO NRANK=0,NPROCS-1 + IF(MYRANK.EQ.NRANK)THEN + DO L=LMPI2,LMPILA + IF(PSHADE_OLD.NE.PSHADE(L))THEN + IF(SOLSWRT(L).gt.0.01.OR.PSHADE_OLD.LT.-.99)then + CALL EQUILIBRIUM_TEMPERATURE(SOLSWRT(L),ET,CSHE) + ENDIF + PSHADE_OLD=PSHADE(L) + ENDIF + ! *** SURFACE HEAT FLUX + THICK =HP(L)*DZC(KC) + TFLUX = CSHE*(ET-TEM(L,KC))/THICK*DELT + TEM(L,KC) = TEM(L,KC)+TFLUX + ! *** BEGIN PMC + ! *** TEMPORARY FIX UNTIL BUILD IN ICE SUB-MODEL INTO THE HEAT SUB-MODEL (COOK INLET) + IF(ISTRAN(1)>0)THEN + IF( TEM(L,KC)<-1.3 )THEN + TEM(L,KC) = -1.3*(SAL(L,KC)/35.) + ENDIF + ELSE + IF( TEM(L,KC)<0.1 )THEN + TEM(L,KC) = 0.1 + ENDIF + ENDIF + ! *** END PMC + ! *** BOTTOM HEAT FLUX + THICK = HP(L)*DZC(1) + TFLUX = HTBED2*(TEMB(L)-TEM(L,1))*DELT + TEM(L,1) = TEM(L,1)+TFLUX/THICK + FLUXTB(L)=TFLUX + ENDDO + ENDIF + CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) + IF(NRANK.LT.NPROCS-1)THEN + IF(MYRANK==NRANK)THEN + CALL MPI_ISEND( PSHADE_OLD,1,MPI_REAL,MYRANK+1,87, + & MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + ELSEIF(MYRANK==NRANK+1)THEN + CALL MPI_IRECV( PSHADE_OLD,1,MPI_REAL,MYRANK-1,87, + & MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + IF(MYRANK==NRANK)THEN + CALL MPI_ISEND( ET,1,MPI_REAL,MYRANK+1,87, + & MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + ELSEIF(MYRANK==NRANK+1)THEN + CALL MPI_IRECV( ET,1,MPI_REAL,MYRANK-1,87, + & MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + IF(MYRANK==NRANK)THEN + CALL MPI_ISEND( CSHE,1,MPI_REAL,MYRANK+1,87, + & MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + ELSEIF(MYRANK==NRANK+1)THEN + CALL MPI_IRECV( CSHE,1,MPI_REAL,MYRANK-1,87, + & MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + ENDIF + ENDDO + MPI_WTIMES(765)=MPI_WTIMES(765)+MPI_TOC(S2TIME) + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + call collect_in_zero(FLUXTB) + call collect_in_zero(TEMB) + call collect_in_zero(SOLSWRT) + call collect_in_zero(PSHADE) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'1FLUXTB = ', sum(abs(dble(FLUXTB))) + PRINT*, n,'1TEMB = ', sum(abs(dble(TEMB))) + PRINT*, n,'1SOLSWRT= ', sum(abs(dble(SOLSWRT))) + PRINT*, n,'1PSHADE = ', sum(abs(dble(PSHADE))) + PRINT*, n,'BHEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(SOLSWRT(2),1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + ! *** Distribute Solar Radiation Across Water Column + IF(SOLSWRT(2).GT.0.1)THEN + S2TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(K,TSS_ABOVE, +!$OMP+ WQCHL_ABOVE,POM_ABOVE,GAMMA,TOP,EXPTOP, +!$OMP+ K_ABOVE,SRON,BOT,EXPBOT) +!$OMP+ FIRSTPRIVATE(TSSS_ABOVE,WQCHLS_ABOVE,POMS_ABOVE) + DO L=LMPI2,LMPILA + K=KC + IF(ISTRAN(6).GT.0.OR.ISTRAN(7).GT.0)THEN + TSSS_ABOVE=SNDT(L,K)+SEDT(L,K) + TSS_ABOVE=TSSS_ABOVE + ELSE + TSS_ABOVE=0.0 + ENDIF + IF(ISTRAN(8).GT.0)THEN + ! *** Water Quality is Active so account for Chlorophyll and POM + ! *** If using WQ then use the WQ Coefficients + WQCHLS_ABOVE=WQCHL(L,K) + WQCHL_ABOVE=WQCHLS_ABOVE + POMS_ABOVE=WQV(L,K,4)+WQV(L,K,5) + POM_ABOVE =POMS_ABOVE + GAMMA = WQKEB(1) + WQKETSS*TSS_ABOVE + + & WQKECHL*WQCHL_ABOVE + + & WQKEPOM*POM_ABOVE + ELSE + GAMMA = SWRATNF + SWRATNS*TSS_ABOVE + ENDIF + + TOP=GAMMA*HP(L)*(Z(K-1)-1.) + EXPTOP=EXP(TOP) + K_ABOVE=1. + + ! *** ENSURE AT LEAST THE FSWRATF FRACTION OF SRO IS ATTENUATED + IF((1.-EXPTOP).GT.FSWRATF)THEN + SRON=SOLSWRT(L)*EXPTOP + ELSE + SRON=SOLSWRT(L)*(1.0-FSWRATF) + ENDIF + EXPBOT=0.0 + DO K = KS,1,-1 + ! *** Net Extinction Coefficient + K_ABOVE=K_ABOVE+1. + IF(ISTRAN(6).GT.0.OR.ISTRAN(7).GT.0)THEN + TSSS_ABOVE=TSSS_ABOVE+SNDT(L,K)+SEDT(L,K) + TSS_ABOVE=TSSS_ABOVE/K_ABOVE + ENDIF + IF(ISTRAN(8).GT.0)THEN + ! *** Water Quality is Active so account for Chlorophyll + ! *** If using WQ then use the WQ Coefficients + POMS_ABOVE=POMS_ABOVE+WQV(L,K,4)+WQV(L,K,5) + POM_ABOVE=POMS_ABOVE/K_ABOVE + + WQCHLS_ABOVE=WQCHLS_ABOVE+WQCHL(L,K) + WQCHL_ABOVE=WQCHLS_ABOVE/K_ABOVE + GAMMA = WQKEB(1) + WQKETSS*TSS_ABOVE + + & WQKECHL*WQCHL_ABOVE + + & WQKEPOM*POM_ABOVE + ELSE + GAMMA = SWRATNF + SWRATNS*TSS_ABOVE + ENDIF + + BOT=GAMMA*HP(L)*(Z(K-1)-1.) + + ! *** Compute Net Energy + EXPBOT=EXP(BOT) + NETRAD(L,K)=SRON*(EXPTOP-EXPBOT) + TOP=BOT + EXPTOP=EXPBOT + ENDDO + RADBOT(L)=EXPBOT*SRON + ENDDO + MPI_WTIMES(766)=MPI_WTIMES(766)+MPI_TOC(S2TIME) + ! *** NOW FINALIZE THE TEMPERATURE + S2TIME=MPI_TIC() + DO K=1,KS + ! *** RHO = 1000.0 Density (kg / m^3) + ! *** CP = 4179.0 Specific Heat (J / kg / degC) + ! *** 0.2393E-6 = 1/RHO/CP --> Conversion from Watts + C1=DELT*DZIC(K)*0.2393E-6 +C!$OMP PARALLEL DO PRIVATE(TEMO) + DO L=LMPI2,LMPILA + TEMO=TEM(L,K)+HPI(L)*C1*NETRAD(L,K) + !IF(ABS(TEM(L,K)-TEMO).GT.PMCTOL)THEN + ! IPMC=0 + !ENDIF + TEM(L,K)=TEMO + ENDDO + ENDDO + MPI_WTIMES(767)=MPI_WTIMES(767)+MPI_TOC(S2TIME) + CALL MPI_BCAST(TEMO,1,MPI_REAL,NPROCS-1,MPI_COMM_WORLD,IERR) + ENDIF + + ! *** UPDATE BOTTOM + S2TIME=MPI_TIC() + IF(TBEDIT.GT.0.)THEN + IF(SOLSWRT(2).GT.0.01.AND.BETAF.GT.0.)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TEMB(L)=TEMB(L) + + & (0.2393E-6*RADBOT(L)*DELT*BETAF - FLUXTB(L)) + & /TBEDTHK(L) + ENDDO + ELSE +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TEMB(L)=TEMB(L) - FLUXTB(L)/TBEDTHK(L) + ENDDO + ENDIF + ENDIF + MPI_WTIMES(768)=MPI_WTIMES(768)+MPI_TOC(S2TIME) + ENDIF + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + call collect_in_zero(FLUXTB) + call collect_in_zero(TEMB) + call collect_in_zero(SOLSWRT) + call collect_in_zero(PSHADE) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'2FLUXTB = ', sum(abs(dble(FLUXTB))) + PRINT*, n,'2TEMB = ', sum(abs(dble(TEMB))) + PRINT*, n,'2SOLSWRT= ', sum(abs(dble(SOLSWRT))) + PRINT*, n,'2PSHADE = ', sum(abs(dble(PSHADE))) + PRINT*, n,'CHEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + ! *** APPLY DRY CELL CORRECTIONS + S2TIME=MPI_TIC() + IF(ISDRY.GT.0)THEN + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(.NOT.LMASKDRY(L))THEN + TEM(L,K)=TATMT(L) + ! *** BEGIN PMC + ! *** TEMPORARY FIX UNTIL BUILD IN ICE SUB-MODEL INTO THE HEAT SUB-MODEL (COOK INLET) + IF(ISTRAN(1)>0)THEN + IF( TEM(L,K)<-1.3 )THEN + TEM(L,K) = -1.3*(SAL(L,K)/35.) + ENDIF + ELSE + IF( TEM(L,K)<0.1 )THEN + TEM(L,K) = 0.1 + ENDIF + ENDIF + ! *** END PMC + ENDIF + ENDDO + ENDDO + ENDIF + IF(PRINT_SUM)THEN + call collect_in_zero_array(TEM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'DHEAT = ', sum(abs(dble(TEM))) + ENDIF + ENDIF + MPI_WTIMES(769)=MPI_WTIMES(769)+MPI_TOC(S2TIME) + +C 600 FORMAT(4I5,2E12.4) + + RETURN + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHTA.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHTA.for index 04aaa0de0..29916c277 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHTA.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALHTA.for @@ -5,7 +5,22 @@ C ** SUBROUTINE CALHTA PERFORMS A HARMONIC ANALYSIS FOR THE M2 TIDE C ** OVER TWO TIDAL CYCLES C USE GLOBAL - CHARACTER*80 TITLE1,TITLE2,TITLE3,TITLE4,TITLE11,TITLE12 + USE MPI + IMPLICIT NONE + CHARACTER*80 TITLE1,TITLE2,TITLE3,TITLE4,TITLE11,TITLE12 + INTEGER::L,K + INTEGER::LINES,LEVELS,LN + REAL::DBS,DBS1,DBS2 + REAL::UTMP,UTMP1,VTMP,VTMP1 + REAL::AMC,AMS + REAL::SSURFAMP,SSURFPHS,SSURFPSC + REAL::PHI + REAL::TERM1,TERM2,TERM3,TERM4 + REAL::RPLUS,RMINS,APLUS,AMINS + REAL::RRMIN,RRMAJ,RMAJUKB,RMAJVKB,RMAJUKC,RMAJVKC + REAL::AACCWX + REAL::PHASEKB,PHASEKC + C C ** INITIALIZE ON FIRST ENTRY FOR CURRENT ANALYSIS INTERVAL C @@ -26,6 +41,7 @@ C AMSV(L,K)=0. ENDDO ENDDO + IF(MYRANK.EQ.0)THEN OPEN(1,FILE='SURFAMP.OUT',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='SURFAMP.OUT',STATUS='UNKNOWN') @@ -81,6 +97,7 @@ C WRITE (4,101)LINES,LEVELS WRITE (4,250)DBS1,DBS2 CLOSE(4) + ENDIF C C ** ACCUMULATE HARMONIC ANALYSIS C @@ -145,6 +162,7 @@ C ENDDO ENDDO NHAR=0 + IF(MYRANK.EQ.0)THEN OPEN(1,FILE='SURFAMP.OUT',POSITION='APPEND',STATUS='UNKNOWN') WRITE (1,100)N OPEN(2,FILE='SURFPHA.OUT',POSITION='APPEND',STATUS='UNKNOWN') @@ -235,6 +253,7 @@ C CLOSE(4) CLOSE(11) CLOSE(12) + ENDIF 2000 CONTINUE NHAR=NHAR+1 99 FORMAT(A80) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALIMP2T.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALIMP2T.for index fcd6866e6..e20a6211a 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALIMP2T.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALIMP2T.for @@ -4,7 +4,14 @@ C ** SUBROUTINE CALEXP CALCULATES IMPLICIT MOMENTUM EQUATION C ** CORIOLIS AND CURVATURE TERMS FOR 1/2 STEP PREDICTOR C CHANGE RECORD C - USE GLOBAL + USE GLOBAL + IMPLICIT NONE + INTEGER::K,L,ND + INTEGER::LS,LN,LNW,LSE + INTEGER::LF,LL + REAL::TMPVAL + REAL::WVFACT,RCDZF,DELTD2 + IF(ISDYNSTP.EQ.0)THEN DELT=DT DELTD2=0.5*DT @@ -504,7 +511,7 @@ C & (BELV(L)-BELV(LS)+Z(K)*(HP(L)-HP(LS))) ) ENDDO ENDDO - 1111 FORMAT(2I5,2X,8E12.4) +C1111 FORMAT(2I5,2X,8E12.4) C C ** CALCULATE EXPLICIT INTERNAL U AND V SHEAR EQUATION TERMS C ELSE diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALMMT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALMMT.for index 5f95561da..7aed6142d 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALMMT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALMMT.for @@ -5,6 +5,16 @@ C ** SUBROUTINE CALMMTF CALCULATES THE MEAN MASS TRANSPORT FIELD C USE GLOBAL C + IMPLICIT NONE + + INTEGER::I,J,K,L,ITMP + INTEGER::NT,NS,NSN,NMD,NWR + INTEGER::LL + INTEGER::LS,LSW,LT,LN + REAL:: UTMP,UTMP1,VTMP,VTMP1 + REAL::HPLW,HPLS,HPLSW,HMC + REAL::TMPVAL,FLTWT + LOGICAL INITIALIZE DATA INITIALIZE/.TRUE./ C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALMMT_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALMMT_mpi.for new file mode 100644 index 000000000..47d514af2 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALMMT_mpi.for @@ -0,0 +1,1003 @@ + SUBROUTINE CALMMT_mpi +C +C CHANGE RECORD +C ** SUBROUTINE CALMMTF CALCULATES THE MEAN MASS TRANSPORT FIELD +C + USE GLOBAL + USE MPI + + IMPLICIT NONE + + INTEGER::I,J,K,L,ITMP + INTEGER::NT,NS,NSN,NMD,NWR + INTEGER::LL + INTEGER::LS,LSW,LT,LN + REAL:: UTMP,UTMP1,VTMP,VTMP1 + REAL::HPLW,HPLS,HPLSW,HMC + REAL::TMPVAL,FLTWT + +C + LOGICAL INITIALIZE + DATA INITIALIZE/.TRUE./ +C +C ** INITIALIZE CE-QUAL-ICM INTERFACE +C + IF(ISICM.GE.1.AND.JSWASP.EQ.1) CALL CEQICM +C + IF(.NOT.INITIALIZE)GOTO 100 + INITIALIZE=.FALSE. + IF(NTSMMT.LT.NTSPTC)THEN + DO L=1,LC + HLPF(L)=0. + QSUMELPF(L)=0. + UELPF(L)=0. + VELPF(L)=0. + RAINLPF(L)=0. + EVPSLPF(L)=0. + EVPGLPF(L)=0. + RINFLPF(L)=0. + GWLPF(L)=0. + ENDDO + DO NSC=1,NSED + DO K=1,KB + DO L=1,LC + SEDBLPF(L,K,NSC)=0. + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KB + DO L=1,LC + SNDBLPF(L,K,NSN)=0. + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO K=1,KB + DO L=1,LC + TOXBLPF(L,K,NT)=0. + ENDDO + ENDDO + ENDDO + HLPF(1)=HMIN + HLPF(LC)=HMIN + DO K=1,KS + DO L=1,LC + ABLPF(L,K)=0. + ABEFF(L,K)=0. + WLPF(L,K)=0. + ENDDO + ENDDO + DO K=1,KC + DO L=1,LC + AHULPF(L,K)=0. + AHVLPF(L,K)=0. + SALLPF(L,K)=0. + TEMLPF(L,K)=0. + SFLLPF(L,K)=0. + DYELPF(L,K)=0. + UHLPF(L,K)=0. + VHLPF(L,K)=0. + QSUMLPF(L,K)=0. + ENDDO + ENDDO + DO NSC=1,NSED + DO K=1,KC + DO L=1,LC + SEDLPF(L,K,NSC)=0. + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KC + DO L=1,LC + SNDLPF(L,K,NSN)=0. + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO K=1,KC + DO L=1,LC + TOXLPF(L,K,NT)=0. + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO NS=1,NSED+NSND + DO K=1,KC + DO L=1,LC + TXPFLPF(L,K,NS,NT)=0. + ENDDO + ENDDO + ENDDO + ENDDO + DO NS=1,NQSER + DO K=1,KC + QSRTLPP(K,NS)=0. + QSRTLPN(K,NS)=0. + ENDDO + ENDDO + DO NS=1,NQCTL + DO K=1,KC + QCTLTLP(K,NS)=0. + ENDDO + ENDDO + DO NMD=1,MDCHH + QCHNULP(NMD)=0. + QCHNVLP(NMD)=0. + ENDDO + DO NWR=1,NQWR + QWRSERTLP(NWR)=0. + ENDDO + ELSE + DO L=1,LC + HLPF(L)=0. + QSUMELPF(L)=0. + UELPF(L)=0. + VELPF(L)=0. + RAINLPF(L)=0. + EVPSLPF(L)=0. + EVPGLPF(L)=0. + RINFLPF(L)=0. + GWLPF(L)=0. + ENDDO + DO NSC=1,NSED + DO K=1,KB + DO L=1,LC + SEDBLPF(L,K,NSC)=0. + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KB + DO L=1,LC + SNDBLPF(L,K,NSN)=0. + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO K=1,KB + DO L=1,LC + TOXBLPF(L,K,NT)=0. + ENDDO + ENDDO + ENDDO + HLPF(1)=HMIN + HLPF(LC)=HMIN + DO K=1,KS + DO L=1,LC + ABLPF(L,K)=0. + WIRT(L,K)=0. + WLPF(L,K)=0. + WTLPF(L,K)=0. + ENDDO + ENDDO + DO K=1,KC + DO L=1,LC + AHULPF(L,K)=0. + AHVLPF(L,K)=0. + SALLPF(L,K)=0. + TEMLPF(L,K)=0. + SFLLPF(L,K)=0. + DYELPF(L,K)=0. + UHLPF(L,K)=0. + UIRT(L,K)=0. + ULPF(L,K)=0. + UTLPF(L,K)=0. + VHLPF(L,K)=0. + QSUMLPF(L,K)=0. + VIRT(L,K)=0. + VLPF(L,K)=0. + VTLPF(L,K)=0. + ENDDO + ENDDO + DO NSC=1,NSED + DO K=1,KC + DO L=1,LC + SEDLPF(L,K,NSC)=0. + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KC + DO L=1,LC + SNDLPF(L,K,NSN)=0. + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO K=1,KC + DO L=1,LC + TOXLPF(L,K,NT)=0. + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO NS=1,NSED+NSND + DO K=1,KC + DO L=1,LC + TXPFLPF(L,K,NS,NT)=0. + ENDDO + ENDDO + ENDDO + ENDDO + DO NS=1,NQSER + DO K=1,KC + QSRTLPP(K,NS)=0. + QSRTLPN(K,NS)=0. + ENDDO + ENDDO + DO NS=1,NQCTL + DO K=1,KC + QCTLTLP(K,NS)=0. + ENDDO + ENDDO + DO NMD=1,MDCHH + QCHNULP(NMD)=0. + QCHNVLP(NMD)=0. + ENDDO + DO NWR=1,NQWR + QWRSERTLP(NWR)=0. + ENDDO + ENDIF +C +C ** ACCUMULATE FILTERED VARIABLES AND DISPLACEMENTS +C + 100 CONTINUE + IF(NTSMMT.LT.NTSPTC)THEN + DO L=2,LA + LN=LNC(L) + HLPF(L)=HLPF(L)+HP(L) + QSUMELPF(L)=QSUMELPF(L)+QSUME(L) + UTMP1=0.5*(UHDYE(L+1)+UHDYE(L))/(DYP(L)*HP(L)) + VTMP1=0.5*(VHDXE(LN)+VHDXE(L))/(DXP(L)*HP(L)) + UTMP=CUE(L)*UTMP1+CVE(L)*VTMP1 + VTMP=CUN(L)*UTMP1+CVN(L)*VTMP1 + UELPF(L)=UELPF(L)+UTMP + VELPF(L)=VELPF(L)+VTMP + RAINLPF(L)=RAINLPF(L)+DXYP(L)*RAINT(L) + ENDDO + IF(ISGWIE.EQ.0)THEN + DO L=2,LA + EVPSLPF(L)=EVPSLPF(L)+DXYP(L)*EVAPT(L) + EVPGLPF(L)=0. + RINFLPF(L)=0. + GWLPF(L)=0. + ENDDO + ELSE + DO L=2,LA + EVPSLPF(L)=EVPSLPF(L)+EVAPSW(L) + EVPGLPF(L)=EVPGLPF(L)+EVAPGW(L) + RINFLPF(L)=RINFLPF(L)+RIFTR(L) + GWLPF(L)=GWLPF(L)+AGWELV(L) + ENDDO + ENDIF + DO NT=1,NTOX + DO K=1,KB + DO L=2,LA + TOXBLPF(L,K,NT)=TOXBLPF(L,K,NT)+TOXB(L,K,NT) + ENDDO + ENDDO + ENDDO + DO NSC=1,NSED + DO K=1,KB + DO L=2,LA + SEDBLPF(L,K,NSC)=SEDBLPF(L,K,NSC)+SEDB(L,K,NSC) + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KB + DO L=2,LA + SNDBLPF(L,K,NSN)=SNDBLPF(L,K,NSN)+SNDB(L,K,NSN) + ENDDO + ENDDO + ENDDO + IF(ISWASP.EQ.99.OR.ISICM.GE.1)THEN + DO K=1,KS + DO L=2,LA + ABLPF(L,K)=ABLPF(L,K)+(AB(L,K)*HP(L)) + ABEFF(L,K)=ABEFF(L,K)+AB(L,K)*(SAL(L,K+1)-SAL(L,K)) + WLPF(L,K)=WLPF(L,K)+W(L,K) + ENDDO + ENDDO + ELSE + DO K=1,KS + DO L=2,LA + ABLPF(L,K)=ABLPF(L,K)+AB(L,K) + ABEFF(L,K)=ABEFF(L,K)+AB(L,K)*(SAL(L,K+1)-SAL(L,K)) + WLPF(L,K)=WLPF(L,K)+W(L,K) + ENDDO + ENDDO + ENDIF + DO K=1,KC + DO L=2,LA + LS=LSC(L) + AHULPF(L,K)=AHULPF(L,K)+0.5*(AH(L,K)+AH(L-1,K)) + AHVLPF(L,K)=AHVLPF(L,K)+0.5*(AH(L,K)+AH(LS,K)) + SALLPF(L,K)=SALLPF(L,K)+SAL(L,K) + TEMLPF(L,K)=TEMLPF(L,K)+TEM(L,K) + SFLLPF(L,K)=SFLLPF(L,K)+SFL(L,K) + DYELPF(L,K)=DYELPF(L,K)+DYE(L,K) + UHLPF(L,K)=UHLPF(L,K)+UHDYWQ(L,K)/DYU(L) + VHLPF(L,K)=VHLPF(L,K)+VHDXWQ(L,K)/DXV(L) + QSUMLPF(L,K)=QSUMLPF(L,K)+QSUM(L,K) + ENDDO + ENDDO + DO NT=1,NTOX + DO K=1,KC + DO L=2,LA + TOXLPF(L,K,NT)=TOXLPF(L,K,NT)+TOX(L,K,NT) + ENDDO + ENDDO + ENDDO + DO NSC=1,NSED + DO K=1,KC + DO L=2,LA + SEDLPF(L,K,NSC)=SEDLPF(L,K,NSC)+SED(L,K,NSC) + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KC + DO L=2,LA + SNDLPF(L,K,NSN)=SNDLPF(L,K,NSN)+SND(L,K,NSN) + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO NS=1,NSED+NSND + DO K=1,KC + DO L=1,LC + TXPFLPF(L,K,NS,NT)=TXPFLPF(L,K,NS,NT)+TOXPFW(L,K,NS,NT) + ENDDO + ENDDO + ENDDO + ENDDO + DO NS=1,NQSER + DO K=1,KC + QSRTLPP(K,NS)=QSRTLPP(K,NS)+MAX(QSERT(K,NS),0.) + QSRTLPN(K,NS)=QSRTLPN(K,NS)+MIN(QSERT(K,NS),0.) + ENDDO + ENDDO + DO NS=1,NQCTL + DO K=1,KC + QCTLTLP(K,NS)=QCTLTLP(K,NS)+QCTLT(K,NS) + ENDDO + ENDDO + DO NMD=1,MDCHH + QCHNULP(NMD)=QCHNULP(NMD)+QCHANU(NMD) + QCHNVLP(NMD)=QCHNVLP(NMD)+QCHANV(NMD) + ENDDO + DO NWR=1,NQWR + QWRSERTLP(NWR)=QWRSERTLP(NWR)+QWRSERT(NWR) + ENDDO + ELSE + DO L=2,LA + LN=LNC(L) + HLPF(L)=HLPF(L)+HP(L) + QSUMELPF(L)=QSUMELPF(L)+QSUME(L) + UTMP1=0.5*(UHDYE(L+1)+UHDYE(L))/(DYP(L)*HP(L)) + VTMP1=0.5*(VHDXE(LN)+VHDXE(L))/(DXP(L)*HP(L)) + UTMP=CUE(L)*UTMP1+CVE(L)*VTMP1 + VTMP=CUN(L)*UTMP1+CVN(L)*VTMP1 + UELPF(L)=UELPF(L)+UTMP + VELPF(L)=VELPF(L)+VTMP + RAINLPF(L)=RAINLPF(L)+DXYP(L)*RAINT(L) + ENDDO + IF(ISGWIE.EQ.0)THEN + DO L=2,LA + EVPSLPF(L)=EVPSLPF(L)+DXYP(L)*EVAPT(L) + EVPGLPF(L)=0. + RINFLPF(L)=0. + GWLPF(L)=0. + ENDDO + ELSE + DO L=2,LA + EVPSLPF(L)=EVPSLPF(L)+EVAPSW(L) + EVPGLPF(L)=EVPGLPF(L)+EVAPGW(L) + RINFLPF(L)=RINFLPF(L)+RIFTR(L) + GWLPF(L)=GWLPF(L)+AGWELV(L) + ENDDO + ENDIF + DO NT=1,NTOX + DO K=1,KB + DO L=2,LA + TOXBLPF(L,K,NT)=TOXBLPF(L,K,NT)+TOXB(L,K,NT) + ENDDO + ENDDO + ENDDO + DO NSC=1,NSED + DO K=1,KB + DO L=2,LA + SEDBLPF(L,K,NSC)=SEDBLPF(L,K,NSC)+SEDB(L,K,NSC) + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KB + DO L=2,LA + SNDBLPF(L,K,NSN)=SNDBLPF(L,K,NSN)+SNDB(L,K,NSN) + ENDDO + ENDDO + ENDDO + IF(ISWASP.EQ.99.OR.ISICM.GE.1)THEN + DO K=1,KS + DO L=2,LA + ABLPF(L,K)=ABLPF(L,K)+(AB(L,K)*HP(L)) + ABEFF(L,K)=ABEFF(L,K)+AB(L,K)*(SAL(L,K+1)-SAL(L,K)) + WIRT(L,K)=WIRT(L,K)+DT*W(L,K) + WLPF(L,K)=WLPF(L,K)+W(L,K) + WTLPF(L,K)=WTLPF(L,K)+DT*(FLOAT(NMMT)-0.5)*W(L,K) + ENDDO + ENDDO + ELSE + DO K=1,KS + DO L=2,LA + ABLPF(L,K)=ABLPF(L,K)+AB(L,K) + ABEFF(L,K)=ABEFF(L,K)+AB(L,K)*(SAL(L,K+1)-SAL(L,K)) + WIRT(L,K)=WIRT(L,K)+DT*W(L,K) + WLPF(L,K)=WLPF(L,K)+W(L,K) + WTLPF(L,K)=WTLPF(L,K)+DT*(FLOAT(NMMT)-0.5)*W(L,K) + ENDDO + ENDDO + ENDIF + DO K=1,KC + DO L=2,LA + LS=LSC(L) + AHULPF(L,K)=AHULPF(L,K)+0.5*(AH(L,K)+AH(L-1,K)) + AHVLPF(L,K)=AHVLPF(L,K)+0.5*(AH(L,K)+AH(LS,K)) + SALLPF(L,K)=SALLPF(L,K)+SAL(L,K) + TEMLPF(L,K)=TEMLPF(L,K)+TEM(L,K) + SFLLPF(L,K)=SFLLPF(L,K)+SFL(L,K) + DYELPF(L,K)=DYELPF(L,K)+DYE(L,K) + UHLPF(L,K)=UHLPF(L,K)+UHDYWQ(L,K)/DYU(L) + UIRT(L,K)=UIRT(L,K)+DT*U(L,K) + ULPF(L,K)=ULPF(L,K)+U(L,K) + UTLPF(L,K)=UTLPF(L,K)+DT*(FLOAT(NMMT)-0.5)*U(L,K) + VHLPF(L,K)=VHLPF(L,K)+VHDXWQ(L,K)/DXV(L) + QSUMLPF(L,K)=QSUMLPF(L,K)+QSUM(L,K) + VIRT(L,K)=VIRT(L,K)+DT*V(L,K) + VLPF(L,K)=VLPF(L,K)+V(L,K) + VTLPF(L,K)=VTLPF(L,K)+DT*(FLOAT(NMMT)-0.5)*V(L,K) + ENDDO + ENDDO + DO NT=1,NTOX + DO K=1,KC + DO L=2,LA + TOXLPF(L,K,NT)=TOXLPF(L,K,NT)+TOX(L,K,NT) + ENDDO + ENDDO + ENDDO + DO NSC=1,NSED + DO K=1,KC + DO L=2,LA + SEDLPF(L,K,NSC)=SEDLPF(L,K,NSC)+SED(L,K,NSC) + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KC + DO L=2,LA + SNDLPF(L,K,NSN)=SNDLPF(L,K,NSN)+SND(L,K,NSN) + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO NS=1,NSED+NSND + DO K=1,KC + DO L=1,LC + TXPFLPF(L,K,NS,NT)=TXPFLPF(L,K,NS,NT)+TOXPFW(L,K,NS,NT) + ENDDO + ENDDO + ENDDO + ENDDO + DO NS=1,NQSER + DO K=1,KC + QSRTLPP(K,NS)=QSRTLPP(K,NS)+MAX(QSERT(K,NS),0.) + QSRTLPN(K,NS)=QSRTLPN(K,NS)+MIN(QSERT(K,NS),0.) + ENDDO + ENDDO + DO NS=1,NQCTL + DO K=1,KC + QCTLTLP(K,NS)=QCTLTLP(K,NS)+QCTLT(K,NS) + ENDDO + ENDDO + DO NMD=1,MDCHH + QCHNULP(NMD)=QCHNULP(NMD)+QCHANU(NMD) + QCHNVLP(NMD)=QCHNVLP(NMD)+QCHANV(NMD) + ENDDO + DO NWR=1,NQWR + QWRSERTLP(NWR)=QWRSERTLP(NWR)+QWRSERT(NWR) + ENDDO + DO K=1,KS + DO L=2,LA + LS=LSC(L) + VPX(L,K)=VPX(L,K)+0.25*(V(L,K+1)+V(L,K))*(WIRT(L,K)+ + & WIRT(LS,K)) + VPY(L,K)=VPY(L,K)+0.25*(W(L,K)+W(L-1,K))*(UIRT(L,K+1)+ + & UIRT(L,K)) + ENDDO + ENDDO + DO K=1,KC + DO L=2,LA + LS=LSC(L) + VPZ(L,K)=VPZ(L,K)+0.25*(U(L,K)+U(LS,K))*(VIRT(L,K)+VIRT( + & L-1,K)) + ENDDO + ENDDO + ENDIF +C +C ** CHECK FOR END OF FILTER +C + IF(NMMT.LT.NTSMMT) GOTO 200 +C +C ** COMPLETE THE FILTERING +C + FLTWT=1./FLOAT(NTSMMT) + IF(ISICM.GE.1) FLTWT=2.*FLTWT + IF(NTSMMT.LT.NTSPTC)THEN + DO L=2,LA + HLPF(L)=FLTWT*HLPF(L) + QSUMELPF(L)=FLTWT*QSUMELPF(L) + UELPF(L)=FLTWT*UELPF(L) + VELPF(L)=FLTWT*VELPF(L) + RAINLPF(L)=FLTWT*RAINLPF(L) + EVPSLPF(L)=FLTWT*EVPSLPF(L) + EVPGLPF(L)=FLTWT*EVPGLPF(L) + RINFLPF(L)=FLTWT*RINFLPF(L) + GWLPF(L)=FLTWT*GWLPF(L) + ENDDO + DO NSC=1,NSED + DO K=1,KB + DO L=2,LA + SEDBLPF(L,K,NSC)=SEDBLPF(L,K,NSC)*FLTWT + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KB + DO L=2,LA + SNDBLPF(L,K,NSN)=SNDBLPF(L,K,NSN)*FLTWT + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO K=1,KB + DO L=2,LA + TOXBLPF(L,K,NT)=TOXBLPF(L,K,NT)*FLTWT + ENDDO + ENDDO + ENDDO + DO K=1,KS + DO L=2,LA + ABLPF(L,K)=FLTWT*ABLPF(L,K) + ABEFF(L,K)=FLTWT*ABEFF(L,K) + WLPF(L,K)=FLTWT*WLPF(L,K) + ENDDO + ENDDO + DO K=1,KC + DO L=2,LA + AHULPF(L,K)=AHULPF(L,K)*FLTWT + AHVLPF(L,K)=AHVLPF(L,K)*FLTWT + SALLPF(L,K)=SALLPF(L,K)*FLTWT + TEMLPF(L,K)=TEMLPF(L,K)*FLTWT + SFLLPF(L,K)=SFLLPF(L,K)*FLTWT + DYELPF(L,K)=DYELPF(L,K)*FLTWT + UHLPF(L,K)=FLTWT*UHLPF(L,K) + VHLPF(L,K)=FLTWT*VHLPF(L,K) + QSUMLPF(L,K)=FLTWT*QSUMLPF(L,K) + ENDDO + ENDDO + DO NSC=1,NSED + DO K=1,KC + DO L=2,LA + SEDLPF(L,K,NSC)=SEDLPF(L,K,NSC)*FLTWT + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KC + DO L=2,LA + SNDLPF(L,K,NSN)=SNDLPF(L,K,NSN)*FLTWT + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO K=1,KC + DO L=2,LA + TOXLPF(L,K,NT)=TOXLPF(L,K,NT)*FLTWT + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO NS=1,NSED+NSND + DO K=1,KC + DO L=1,LC + TXPFLPF(L,K,NS,NT)=TXPFLPF(L,K,NS,NT)*FLTWT + ENDDO + ENDDO + ENDDO + ENDDO + DO NS=1,NQSER + DO K=1,KC + QSRTLPP(K,NS)=FLTWT*QSRTLPP(K,NS) + QSRTLPN(K,NS)=FLTWT*QSRTLPN(K,NS) + ENDDO + ENDDO + DO NS=1,NQCTL + DO K=1,KC + QCTLTLP(K,NS)=FLTWT*QCTLTLP(K,NS) + ENDDO + ENDDO + DO NMD=1,MDCHH + QCHNULP(NMD)=FLTWT*QCHNULP(NMD) + QCHNVLP(NMD)=FLTWT*QCHNVLP(NMD) + ENDDO + DO NWR=1,NQWR + QWRSERTLP(NWR)=FLTWT*QWRSERTLP(NWR) + ENDDO + ELSE + DO L=2,LA + HLPF(L)=FLTWT*HLPF(L) + QSUMELPF(L)=FLTWT*QSUMELPF(L) + UELPF(L)=FLTWT*UELPF(L) + VELPF(L)=FLTWT*VELPF(L) + RAINLPF(L)=FLTWT*RAINLPF(L) + EVPSLPF(L)=FLTWT*EVPSLPF(L) + EVPGLPF(L)=FLTWT*EVPGLPF(L) + RINFLPF(L)=FLTWT*RINFLPF(L) + GWLPF(L)=FLTWT*GWLPF(L) + ENDDO + DO NSC=1,NSED + DO K=1,KB + DO L=2,LA + SEDBLPF(L,K,NSC)=SEDBLPF(L,K,NSC)*FLTWT + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KB + DO L=2,LA + SNDBLPF(L,K,NSN)=SNDBLPF(L,K,NSN)*FLTWT + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO K=1,KB + DO L=2,LA + TOXBLPF(L,K,NT)=TOXBLPF(L,K,NT)*FLTWT + ENDDO + ENDDO + ENDDO + DO K=1,KS + DO L=2,LA + ABLPF(L,K)=FLTWT*ABLPF(L,K) + ABEFF(L,K)=FLTWT*ABEFF(L,K) + VPX(L,K)=FLTWT*VPX(L,K) + VPY(L,K)=FLTWT*VPY(L,K) + WLPF(L,K)=FLTWT*WLPF(L,K) + WTLPF(L,K)=FLTWT*WTLPF(L,K) + ENDDO + ENDDO + DO K=1,KC + DO L=2,LA + AHULPF(L,K)=AHULPF(L,K)*FLTWT + AHVLPF(L,K)=AHVLPF(L,K)*FLTWT + SALLPF(L,K)=FLTWT*SALLPF(L,K) + TEMLPF(L,K)=FLTWT*TEMLPF(L,K) + SFLLPF(L,K)=FLTWT*SFLLPF(L,K) + DYELPF(L,K)=FLTWT*DYELPF(L,K) + UHLPF(L,K)=FLTWT*UHLPF(L,K) + ULPF(L,K)=FLTWT*ULPF(L,K) + UTLPF(L,K)=FLTWT*UTLPF(L,K) + VHLPF(L,K)=FLTWT*VHLPF(L,K) + QSUMLPF(L,K)=FLTWT*QSUMLPF(L,K) + VLPF(L,K)=FLTWT*VLPF(L,K) + VTLPF(L,K)=FLTWT*VTLPF(L,K) + VPZ(L,K)=FLTWT*VPZ(L,K) + ENDDO + ENDDO + DO NSC=1,NSED + DO K=1,KC + DO L=2,LA + SEDLPF(L,K,NSC)=SEDLPF(L,K,NSC)*FLTWT + ENDDO + ENDDO + ENDDO + DO NSN=1,NSND + DO K=1,KC + DO L=2,LA + SNDLPF(L,K,NSN)=SNDLPF(L,K,NSN)*FLTWT + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO K=1,KC + DO L=2,LA + TOXLPF(L,K,NT)=TOXLPF(L,K,NT)*FLTWT + ENDDO + ENDDO + ENDDO + DO NT=1,NTOX + DO NS=1,NSED+NSND + DO K=1,KC + DO L=1,LC + TXPFLPF(L,K,NS,NT)=TXPFLPF(L,K,NS,NT)*FLTWT + ENDDO + ENDDO + ENDDO + ENDDO + DO NS=1,NQSER + DO K=1,KC + QSRTLPP(K,NS)=FLTWT*QSRTLPP(K,NS) + QSRTLPN(K,NS)=FLTWT*QSRTLPN(K,NS) + ENDDO + ENDDO + DO NS=1,NQCTL + DO K=1,KC + QCTLTLP(K,NS)=FLTWT*QCTLTLP(K,NS) + ENDDO + ENDDO + DO NMD=1,MDCHH + QCHNULP(NMD)=FLTWT*QCHNULP(NMD) + QCHNVLP(NMD)=FLTWT*QCHNVLP(NMD) + ENDDO + DO NWR=1,NQWR + QWRSERTLP(NWR)=FLTWT*QWRSERTLP(NWR) + ENDDO + DO K=1,KS + DO L=2,LA + LS=LSC(L) + VPX(L,K)=VPX(L,K) + & -0.25*(VTLPF(L,K+1)+VTLPF(L,K))*(WLPF(L,K)+WLPF(LS,K)) + VPY(L,K)=VPY(L,K) + & -0.25*(WTLPF(L,K)+WTLPF(L-1,K))*(ULPF(L,K+1)+ULPF(L,K)) + ENDDO + ENDDO + DO K=1,KC + DO L=2,LA + LS=LSC(L) + LSW=LSWC(L) + VPZ(L,K)=VPZ(L,K) + & -0.25*(UTLPF(L,K)+UTLPF(LS,K))*(VLPF(L,K)+VLPF(L-1,K)) + ! *** DSLLC BEGIN BLOCK + TMPVAL=1.+SUB(L)+SVB(L)+SUB(L)*SVB(L) + HPLW =SUB(L)*HP(L-1) + HPLS =SVB(L)*HP(LS) + HPLSW=SUB(L)*SVBO(L)*HP(LSW) + HMC=(HP(L)+HPLW+HPLS+HPLSW)/TMPVAL + VPZ(L,K)=VPZ(L,K)*HMC*SUB(L)*SUB(LS)*SVB(L)*SVB(L-1) + ! *** DSLLC END BLOCK + ENDDO + ENDDO + DO K=1,KC + DO L=2,LA + LS=LSC(L) + LN=LNC(L) + UVPT(L,K)=(VPZ(LN,K)-VPZ(L,K))/DYU(L) + & -DZIC(K)*(VPY(L,K)-VPY(L,K-1)) + VVPT(L,K)=DZIC(K)*(VPX(L,K)-VPX(L,K-1)) + & -(VPZ(L+1,K)-VPZ(L,K))/DXV(L) + ENDDO + ENDDO + DO K=1,KS + DO L=2,LA + LS=LSC(L) + LN=LNC(L) + WVPT(L,K)=(VPY(L+1,K)-VPY(L,K))/DXP(L)-(VPX(LN,K)-VPX(L,K) + & )/DYP(L) + ENDDO + ENDDO + ENDIF + QXW=0. + QXWVP=0. + DO K=1,KC + DO LL=1,NPBW + L=LPBW(LL) + QXW=QXW+UHLPF(L+1,K)*DZC(K)*DYU(L+1) + QXWVP=QXWVP+UVPT(L+1,K)*DZC(K)*DYU(L+1) + ENDDO + ENDDO + QXE=0. + QXEVP=0. + DO K=1,KC + DO LL=1,NPBE + L=LPBE(LL) + QXE=QXE+UHLPF(L,K)*DZC(K)*DYU(L) + QXEVP=QXEVP+UVPT(L,K)*DZC(K)*DYU(L) + ENDDO + ENDDO + QYS=0. + QYSVP=0. + DO K=1,KC + DO LL=1,NPBS + L=LPBS(LL) + LN=LNC(L) + QYS=QYS+VHLPF(LN,K)*DZC(K)*DXV(LN) + QYSVP=QYSVP+VVPT(LN,K)*DZC(K)*DXV(LN) + ENDDO + ENDDO + QYN=0. + QYNVP=0. + DO K=1,KC + DO LL=1,NPBN + L=LPBN(LL) + LN=LNC(L) + QYN=QYN+VHLPF(L,K)*DZC(K)*DXV(L) + QYNVP=QYNVP+VVPT(L,K)*DZC(K)*DXV(L) + ENDDO + ENDDO +C +C ** OUTPUT RESIDUAL TRANSPORT TO FILE RESTRAN.OUT +C + IF(ISSSMMT.EQ.1.AND.N.LT.NTS) GOTO 198 + IF(ISRESTR.EQ.1)THEN + IF(MYRANK.EQ.0)THEN + IF(JSRESTR.EQ.1)THEN + OPEN(98,FILE='RESTRAN.OUT',STATUS='UNKNOWN') + CLOSE(98,STATUS='DELETE') + OPEN(98,FILE='RESTRAN.OUT',STATUS='UNKNOWN') + JSRESTR=0 + ELSE + OPEN(98,FILE='RESTRAN.OUT',POSITION='APPEND',STATUS='UNKNOWN') + ENDIF + IF(NTSMMT.LT.NTSPTC)THEN + DO LT=2,LALT + I=ILLT(LT) + J=JLLT(LT) + L=LIJ(I,J) + WRITE(98,907)HMP(L),HLPF(L),QSUMELPF(L) + WRITE(98,907)(UHLPF(L,K),K=1,KC) + WRITE(98,907)(VHLPF(L,K),K=1,KC) + WRITE(98,907)(AHULPF(L,K),K=1,KC) + WRITE(98,907)(AHVLPF(L,K),K=1,KC) + WRITE(98,907)(SALLPF(L,K),K=1,KC) + WRITE(98,907)(ABLPF(L,K),K=1,KS) + WRITE(98,907)(ABEFF(L,K),K=1,KS) + ENDDO + ELSE + DO LT=2,LALT + I=ILLT(LT) + J=JLLT(LT) + L=LIJ(I,J) + WRITE(98,907)HMP(L),HLPF(L),QSUMELPF(L) + WRITE(98,907)(UHLPF(L,K),K=1,KC) + WRITE(98,907)(VHLPF(L,K),K=1,KC) + WRITE(98,907)(VPZ(L,K),K=1,KC) + WRITE(98,907)(AHULPF(L,K),K=1,KC) + WRITE(98,907)(AHVLPF(L,K),K=1,KC) + WRITE(98,907)(SALLPF(L,K),K=1,KC) + WRITE(98,907)(VPX(L,K),K=1,KS) + WRITE(98,907)(VPY(L,K),K=1,KS) + WRITE(98,907)(ABLPF(L,K),K=1,KS) + ENDDO + ENDIF + CLOSE(98) + ENDIF + ENDIF + 907 FORMAT(12E12.4) +C +C ** OUTPUT TO WASP COMPATIABLE FILES +C + IF(ISWASP.EQ.4) CALL WASP4 + IF(ISWASP.EQ.5) CALL WASP5 + IF(ISWASP.EQ.6) CALL WASP6 + IF(ISWASP.EQ.7) CALL WASP7 + IF(ISWASP.EQ.17) CALL WASP7EPA + IF(ISRCA.GE.1) CALL RCAHQ + IF(ISICM.GE.1) CALL CEQICM + 198 CONTINUE +C +C ** WRITE GRAPHICS FILES FOR RESIDUAL VARIABLES +C + IF(ISSSMMT.EQ.1.AND.N.LT.NTS) GOTO 199 +C +C ** RESIDUAL SALINITY CONTOURING IN HORIZONTAL: SUBROUTINE RSALPLTH +C + IF(ISRSPH(1).EQ.1.AND.ISTRAN(1).GE.1)THEN + CALL RSALPLTH(1,SALLPF) + ENDIF + IF(ISRSPH(2).EQ.1.AND.ISTRAN(2).GE.1)THEN + CALL RSALPLTH(2,TEMLPF) + ENDIF + IF(ISRSPH(3).EQ.1.AND.ISTRAN(3).GE.1)THEN + CALL RSALPLTH(3,DYELPF) + ENDIF + IF(ISRSPH(4).EQ.1.AND.ISTRAN(4).GE.1)THEN + CALL RSALPLTH(4,SFLLPF) + ENDIF + DO K=2,KB + DO L=2,LA + SEDBTLPF(L,K)=0. + SNDBTLPF(L,K)=0. + ENDDO + ENDDO + DO K=1,KC + DO L=2,LA + TVAR1S(L,K)=TOXLPF(L,K,1) + SEDTLPF(L,K)=0. + SNDTLPF(L,K)=0. + ENDDO + ENDDO + IF(ISRSPH(5).EQ.1.AND.ISTRAN(5).GE.1)THEN + DO NT=1,NTOX + CALL RSALPLTH(5,TVAR1S) + ENDDO + ENDIF + DO NS=1,NSED + DO K=1,KB + DO L=2,LA + SEDBTLPF(L,K)=SEDBTLPF(L,K)+SEDBLPF(L,K,NS) + ENDDO + ENDDO + ENDDO + DO NS=1,NSED + DO K=1,KC + DO L=2,LA + SEDTLPF(L,K)=SEDTLPF(L,K)+SEDLPF(L,K,NS) + ENDDO + ENDDO + ENDDO + IF(ISRSPH(6).EQ.1.AND.ISTRAN(6).GE.1)THEN + DO NSC=1,NSED + CALL RSALPLTH(6,SEDTLPF) + ENDDO + ENDIF + DO NS=1,NSND + DO K=1,KB + DO L=2,LA + SNDBTLPF(L,K)=SNDBTLPF(L,K)+SNDBLPF(L,K,NS) + ENDDO + ENDDO + ENDDO + DO NS=1,NSND + DO K=1,KC + DO L=2,LA + SNDTLPF(L,K)=SNDTLPF(L,K)+SNDLPF(L,K,NS) + ENDDO + ENDDO + ENDDO + IF(ISRSPH(7).EQ.1.AND.ISTRAN(7).GE.1)THEN + DO NSN=1,NSND + CALL RSALPLTH(7,SNDTLPF) + ENDDO + ENDIF +C +C ** RESIDUAL VELOCITY VECTOR PLOTTING IN HORIZONTAL PLANES: +C ** SUBROUTINE RVELPLTH +C + IF(ISRVPH.GE.1) CALL RVELPLTH +C +C ** RESIDUAL SURFACE ELEVATION PLOTTING IN HORIZONTAL PLANES: +C ** SUBROUTINE RVELPLTH +C + IF(ISRPPH.EQ.1) CALL RSURFPLT +C +C ** RESIDUAL SALINITY AND VERTICAL MASS DIFFUSIVITY CONTOURING IN +C ** 3 VERTICAL PLANES: SUBROUTINE RSALPLTV +C + DO ITMP=1,7 + IF(ISRSPV(ITMP).GE.1) CALL RSALPLTV(ITMP) + ENDDO +C +C ** RESIDUAL NORMAL AND TANGENTIAL VELOCITY CONTOURING AND AND +C ** TANGENTIAL VELOCITY VECTOR PLOTTING IN VERTICAL PLANES: +C ** SUBROUTINE RVELPLTV +C + IF(ISRVPV.GE.1) CALL RVELPLTV +C +C ** RESIDUAL 3D SCALAR AND VECTOR OUTPUT FILES +C + IF(ISR3DO.GE.1) CALL ROUT3D + 199 CONTINUE + NMMT=0 + 200 CONTINUE + IF(ISICM.GE.1)THEN + NMMT=NMMT+2 + ELSE + NMMT=NMMT+1 + ENDIF + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPGCORR.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPGCORR.for index 8a7a343e1..3e88eb561 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPGCORR.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPGCORR.for @@ -12,7 +12,10 @@ C DATE MODIFIED BY DATE APPROVED BY C USE GLOBAL + IMPLICIT NONE INTEGER,SAVE::LASTCOR + INTEGER::L + REAL::RELAX, RATIO REAL, SAVE::BEGRELAX, ENDRELAX @@ -40,4 +43,4 @@ C ENDIF RETURN - END \ No newline at end of file + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPNHS.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPNHS.for index bbbc2c039..cf3163a90 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPNHS.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPNHS.for @@ -3,7 +3,16 @@ C C CHANGE RECORD C ** SUBROUTINE CALPNHS CALCULATES QUASI-NONHYDROSTATIC PRESSURE C - USE GLOBAL + USE GLOBAL + IMPLICIT NONE + + INTEGER::L,K,LN,LS,NS + INTEGER::IU,JU,KU,LU + INTEGER::ID,JD,KD,LD + INTEGER::NWR + REAL:: UHUW,VHVW + REAL::WB,ADIFF,TMPVAL,TMPANG,DELTD2 + REAL::QMF,QUMF REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::PNHYDSS REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::FWJET diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPNHS_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPNHS_mpi.for new file mode 100644 index 000000000..f2ef7534f --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPNHS_mpi.for @@ -0,0 +1,218 @@ + SUBROUTINE CALPNHS_mpi +C +C CHANGE RECORD +C ** SUBROUTINE CALPNHS CALCULATES QUASI-NONHYDROSTATIC PRESSURE +C + USE GLOBAL + USE MPI + IMPLICIT NONE + + INTEGER::L,K,LN,LS,NS + INTEGER::IU,JU,KU,LU + INTEGER::ID,JD,KD,LD + INTEGER::NWR + REAL:: UHUW,VHVW + REAL::WB,ADIFF,TMPVAL,TMPANG,DELTD2 + REAL::QMF,QUMF + + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::PNHYDSS + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::FWJET + IF(.NOT.ALLOCATED(PNHYDSS))THEN + ALLOCATE(PNHYDSS(LCM,KCM)) + ALLOCATE(FWJET(LCM,KCM)) + PNHYDSS=0.0 + FWJET=0.0 + ENDIF +C + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + DELTD2=0.5*DT + DELTI=1./DELT + ELSE + DELT=DTDYN + DELTD2=0.5*DTDYN + DELTI=1./DELT + END IF + IF(N.EQ.1)THEN + DO K=0,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WZ1(L,K)=0. + FWJET(L,K)=0. ! *** DSLLC + ENDDO + ENDDO + ENDIF +C +C ** CALCULATE THE PHYSICAL VERTICAL VELOCIY +C + IF(NPROCS.GT.1)THEN +C CALL BROADCAST_BOUNDARY(P,IC) + CALL BROADCAST_BOUNDARY(DXIU,IC) + CALL BROADCAST_BOUNDARY(DYIV,IC) +C CALL BROADCAST_BOUNDARY_ARRAY(U,IC) +C CALL BROADCAST_BOUNDARY_ARRAY(V,IC) + ENDIF +C +!$OMP PARALLEL DO PRIVATE(LN,LS) + DO L=LMPI2,LMPILA + LN=LNC(L) + LS=LSC(L) + WZ(L,0)=DELTI*(BELV(L)-BELV1(L)) + WZ(L,KC)=GI*( DELTI*(P(L)-P1(L)) + & +0.5*U(L+1,KC)*(P(L+1)-P(L))*DXIU(L+1) + & +0.5*U(L,KC)*(P(L)-P(L-1))*DXIU(L) + & +0.5*V(LN,KC)*(P(LN)-P(L))*DYIV(LN) + & +0.5*V(L,KC)*(P(L)-P(LS))*DYIV(L) ) + ENDDO + IF(KC.GT.2)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN,LS) + DO L=LMPI2,LMPILA + LN=LNC(L) + LS=LSC(L) + WZ(L,K)=W(L,K)+GI*ZZ(K)*( DELTI*(P(L)-P1(L)) + & +0.5*U(L+1,K)*(P(L+1)-P(L))*DXIU(L+1) + & +0.5*U(L,K)*(P(L)-P(L-1))*DXIU(L) + & +0.5*V(LN,K)*(P(LN)-P(L))*DYIV(LN) + & +0.5*V(L,K)*(P(L)-P(LS))*DYIV(L) ) + & +(1.-ZZ(K))*( DELTI*(BELV(L)-BELV1(L)) + & +0.5*U(L+1,K)*(BELV(L+1)-BELV(L))*DXIU(L+1) + & +0.5*U(L,K)*(BELV(L)-BELV(L-1))*DXIU(L) + & +0.5*V(LN,K)*(BELV(LN)-BELV(L))*DYIV(LN) + & +0.5*V(L,K)*(BELV(L)-BELV(LS))*DYIV(L) ) + ENDDO + ENDDO + ENDIF +C + IF(NPROCS.GT.1)THEN + CALL BROADCAST_BOUNDARY_ARRAY(WZ,IC) + ENDIF +C ** CALCULATE FLUXES +C + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + PNHYDSS(L,K)=PNHYDS(L,K) + FUHU(L,K)=0. + FVHU(L,K)=0. + FWQQ(L,KC)=0. + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + UHUW=0.5*(UHDY(L,K)+UHDY(L,K+1)) + VHVW=0.5*(VHDX(L,K)+VHDX(L,K+1)) + FUHU(L,K)=MAX(UHUW,0.)*WZ(L-1,K) + & +MIN(UHUW,0.)*WZ(L,K) + FVHU(L,K)=MAX(VHVW,0.)*WZ(LS,K) + & +MIN(VHVW,0.)*WZ(L,K) + ENDDO + ENDDO + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(WB) + DO L=LMPI2,LMPILA + WB=0.5*DXYP(L)*(W(L,K-1)+W(L,K)) + FWQQ(L,K)=MAX(WB,0.)*WZ(L,K-1) + & +MIN(WB,0.)*WZ(L,K) + FWJET(L,K)=0. + ENDDO + ENDDO +C +C ** ADD RETURN FLOW MOMENTUM FLUX +C + DO NWR=1,NQWR + IF(NQWRMFU(NWR).GT.0)THEN + IU=IQWRU(NWR) + JU=JQWRU(NWR) + KU=KQWRU(NWR) + LU=LIJ(IU,JU) + NS=NQWRSERQ(NWR) + QMF=QWR(NWR)+QWRSERT(NS) + QUMF=QMF*QMF/(H1P(LU)*DZC(KU)*BQWRMFU(NWR)) + IF(NQWRMFU(NWR).EQ.1) FWJET(LU ,KU)=-QUMF + IF(NQWRMFU(NWR).EQ.2) FWJET(LU ,KU)=-QUMF + IF(NQWRMFU(NWR).EQ.3) FWJET(LU+1 ,KU)=-QUMF + IF(NQWRMFU(NWR).EQ.4) FWJET(LNC(LU),KU)=-QUMF + IF(NQWRMFU(NWR).EQ.-1) FWJET(LU ,KU)=-QUMF + IF(NQWRMFU(NWR).EQ.-2) FWJET(LU ,KU)=-QUMF + IF(NQWRMFU(NWR).EQ.-3) FWJET(LU+1 ,KU)=-QUMF + IF(NQWRMFU(NWR).EQ.-4) FWJET(LNC(LU),KU)=-QUMF + ENDIF + IF(NQWRMFD(NWR).GT.0)THEN + ID=IQWRD(NWR) + JD=JQWRD(NWR) + KD=KQWRD(NWR) + LD=LIJ(ID,JD) + ADIFF=ABS(ANGWRMFD(NWR)-90.) + IF(ADIFF.LT.1.0)THEN + TMPANG=1. + ELSE + TMPANG=0.017453*ANGWRMFD(NWR) + TMPANG=SIN(TMPANG) + ENDIF + NS=NQWRSERQ(NWR) + QMF=QWR(NWR)+QWRSERT(NS) + QUMF=TMPANG*QMF*QMF/(H1P(LD)*DZC(KD)*BQWRMFD(NWR)) + IF(NQWRMFD(NWR).EQ.1) FWJET(LD ,KD)=QUMF + IF(NQWRMFD(NWR).EQ.2) FWJET(LD ,KD)=QUMF + IF(NQWRMFD(NWR).EQ.3) FWJET(LD+1 ,KD)=QUMF + IF(NQWRMFD(NWR).EQ.4) FWJET(LNC(LD),KD)=QUMF + IF(NQWRMFD(NWR).EQ.-1) FWJET(LD ,KD)=QUMF + IF(NQWRMFD(NWR).EQ.-2) FWJET(LD ,KD)=QUMF + IF(NQWRMFD(NWR).EQ.-3) FWJET(LD+1 ,KD)=QUMF + IF(NQWRMFD(NWR).EQ.-4) FWJET(LNC(LD),KD)=QUMF + ENDIF + ENDDO +C +C ** CALCULATE QUASI-NONHYDROSTATIC PRESSURE +C +!$OMP PARALLEL DO PRIVATE(LN,TMPVAL) + DO L=LMPI2,LMPILA + LN=LNC(L) + TMPVAL=0.5*DZC(KC)/DXYP(L) + PNHYDS(L,KC)= 0.75*TMPVAL*( + & DELTI*DXYP(L)*(HP(L)*WZ(L,KC)-H1P(L)*WZ1(L,KC)) + & +FUHU(L+1,KC)-FUHU(L,KC)+FVHU(LN,KC)-FVHU(L,KC) ) + & +0.25*TMPVAL*( + & DELTI*DXYP(L)*(HP(L)*WZ(L,KS)-H1P(L)*WZ1(L,KS)) + & +FUHU(L+1,KS)-FUHU(L,KS)+FVHU(LN,KS)-FVHU(L,KS) ) + & -FWQQ(L,KC) + ENDDO + DO K=KS,1,-1 +!$OMP PARALLEL DO PRIVATE(LN,TMPVAL) + DO L=LMPI2,LMPILA + LN=LNC(L) + TMPVAL=0.5*(DZC(K+1)+DZC(K))/DXYP(L) + PNHYDS(L,K)=PNHYDS(L,K+1)+FWQQ(L,K+1)-FWQQ(L,K)-FWJET(L,K) + & +TMPVAL*( DELTI*DXYP(L)*(HP(L)*WZ(L,K)-H1P(L)*WZ1(L,K)) + & +FUHU(L+1,K)-FUHU(L,K)+FVHU(LN,K)-FVHU(L,K) ) + ENDDO + ENDDO + DO K=0,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WZ1(L,K)=WZ(L,K) + ENDDO + ENDDO + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + PNHYDS(L,K)=0.5*(PNHYDSS(L,K)+PNHYDS(L,K)) + ENDDO + ENDDO + IF(N.EQ.2.AND.DEBUG)THEN +!####!!! COLLECT_ZERO_ARRAY(PHNYDS) + IF(MYRANK.EQ.0)THEN + OPEN(1,FILE='PNHYDS.DIA') + DO L=2,LA + WRITE(1,888)IL(L),JL(L),(PNHYDS(L,K),K=1,KC) + ENDDO + CLOSE(1) + ENDIF + ENDIF + 888 FORMAT(2I5,10E14.5) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPSER.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPSER.for index 90e04c5a3..3dd963e7e 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPSER.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPSER.for @@ -4,7 +4,14 @@ C CHANGE RECORD C ** SUBROUTINE CALPSER UPDATES TIME VARIABLE SURFACE ELEVATION C ** BOUNDARY CONDITIONS C - USE GLOBAL + USE GLOBAL + IMPLICIT NONE + INTEGER::ISTL_ + INTEGER::NS + INTEGER::M1,M2 + REAL::TDIFF,TIME + REAL::WTM1,WTM2 + PSERT(0)=0. DO NS=1,NPSER IF(ISDYNSTP.EQ.0)THEN @@ -39,9 +46,7 @@ C ENDIF 1001 FORMAT(/' TRANSPORT VARIABLE ID =',I5/) 1002 FORMAT(I5,2X,12E12.4) - - - 6000 FORMAT('N, PSERT = ',I6,4X,F12.4) +C6000 FORMAT('N, PSERT = ',I6,4X,F12.4) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPSER_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPSER_mpi.for new file mode 100644 index 000000000..cd3f2f19f --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPSER_mpi.for @@ -0,0 +1,46 @@ + SUBROUTINE CALPSER_mpi (ISTL_) +C +C CHANGE RECORD +C ** SUBROUTINE CALPSER UPDATES TIME VARIABLE SURFACE ELEVATION +C ** BOUNDARY CONDITIONS +C + USE GLOBAL + USE MPI + IMPLICIT NONE + INTEGER::ISTL_ + INTEGER::NS + INTEGER::M1,M2 + REAL::TDIFF,TIME + REAL::WTM1,WTM2 + +C + S1TIME=MPI_TIC() +C + PSERT(0)=0. + DO NS=1,NPSER + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N)/TCPSER(NS)+TBEGIN*(TCON/TCPSER(NS)) + ELSE + TIME=TIMESEC/TCPSER(NS) + ENDIF + M1=MPTLAST(NS) + 100 CONTINUE + M2=M1+1 + IF(TIME.GT.TPSER(M2,NS))THEN + M1=M2 + GOTO 100 + ELSE + MPTLAST(NS)=M1 + ENDIF + TDIFF=TPSER(M2,NS)-TPSER(M1,NS) + WTM1=(TPSER(M2,NS)-TIME)/TDIFF + WTM2=(TIME-TPSER(M1,NS))/TDIFF + PSERT(NS)=WTM1*PSER(M1,NS)+WTM2*PSER(M2,NS) + ENDDO +C + MPI_WTIMES(1214)=MPI_WTIMES(1214)+MPI_TOC(S1TIME) +C +C6000 FORMAT('N, PSERT = ',I6,4X,F12.4) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2C.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2C.for index 25beb6e30..8af668c04 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2C.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2C.for @@ -18,23 +18,53 @@ C ** SUBROUTINE CALPUV2TC CALCULATES THE EXTERNAL SOLUTION FOR P, UHDYE, C ** AND VHDXE, FOR FREE SURFACE FLOWS WITH PROVISIONS FOR WETTING C ** AND DRYING OF CELLS C - USE GLOBAL + USE GLOBAL + IMPLICIT NONE + INTEGER::K,L,IACTALL + INTEGER::LL,NTMP,LS,LN + INTEGER::IUE,IUW,IVN,IVS + INTEGER::ICHNU,JCHNU + INTEGER::IHOST,JHOST,LHOST + INTEGER::IFACE + INTEGER::ICHNV,JCHNV + INTEGER::LCHNU,LCHNV + INTEGER::IVAL + INTEGER::ITERHP + INTEGER::ICORDRY,NCORDRY,NEWDRY + INTEGER::NMD + INTEGER::IMIN,IMAX,JMIN,JMAX + REAL::C1,CCMNM,CCMNMI + REAL::SUBE,SUBW + REAL::HDRY2,RDRY + REAL::TMPVAL + REAL::SVBS,SVBN,SVPW + REAL::RLAMN,RLAMO + REAL::ETGWTMP,ETGWAVL + REAL::DELTD2,DTAGW,DHPDT + REAL::QSUMIET,QEAVAIL,RAVAIL,RIFTRL + REAL::DIVEXMX,DIVEX,DIVEXMN,DIFQVOL + REAL::VOLADD + REAL::RVAL,RNPORI + REAL::BELVAVG + REAL::HOLDTMP,SURFTMP + REAL::SRFCHAN,SRFHOST,SRFCHAN1,SRFHOST1 INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::IACTIVE INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::IQDRYDWN REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QCHANUT REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QCHANVT REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QSUMTMP - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DIFQVOL REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SUB1 REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SVB1 + INTEGER LMIN, LMAX + LMIN=0 + LMAX=0 IF(.NOT.ALLOCATED(IACTIVE))THEN ALLOCATE(IACTIVE(NCHANM)) ALLOCATE(IQDRYDWN(LCM)) ALLOCATE(QCHANUT(NCHANM)) ALLOCATE(QCHANVT(NCHANM)) ALLOCATE(QSUMTMP(LCM)) - ALLOCATE(DIFQVOL(LCM)) ALLOCATE(SUB1(LCM)) ALLOCATE(SVB1(LCM)) IACTIVE=0 @@ -42,7 +72,6 @@ C QCHANUT=0. QCHANVT=0. QSUMTMP=0. - DIFQVOL=0. SUB1=0. SVB1=0. ENDIF @@ -100,19 +129,14 @@ C NCORDRY=0 ICORDRY=0 NEWDRY=0 -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - DO L=LF,LL + DO L=1,LC IQDRYDWN(L)=0 ISCDRY(L)=0 + ENDDO + DO L=1,LC SUB1(L)=SUB(L) SVB1(L)=SVB(L) ENDDO -c - enddo C C ** INITIALIZE SUBGRID SCALE CHANNEL INTERACTIONS C @@ -126,28 +150,16 @@ C C ** CALCULATE EXTERNAL BUOYANCY INTEGRALS AT TIME LEVEL (N) C IF(BSC.GT.1.E-6)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - CALL CALEBI0(LF,LL) -c - enddo - ENDIF + CALL CALEBI C ! *** CALCULATE EXPLICIT EXTERNAL PRESSURE GRADIENTS -!$OMP PARALLEL DO PRIVATE(LF,LL,LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - IF(BSC.GT.1.E-6)THEN - DO L=LF,LL + DO L=2,LA !SBX(L)=0.5*SUB(L)*DYU(L) FPGXE(L)=-SBX(L)*HU(L)*GP*((BI2(L)+BI2(L-1))*(HP(L)-HP(L-1)) & +2.0*HU(L)*(BI1(L)-BI1(L-1)) & +(BE(L)+BE(L-1))*(BELV(L)-BELV(L-1))) + ENDDO + DO L=2,LA LS=LSC(L) !SBY(L)=0.5*SVB(L)*DXV(L) FPGYE(L)=-SBY(L)*HV(L)*GP*((BI2(L)+BI2(LS))*(HP(L)-HP(LS)) @@ -155,19 +167,15 @@ c & +(BE(L)+BE(LS))*(BELV(L)-BELV(LS))) ENDDO ENDIF -c -c enddo C C ** CALCULATE EXPLICIT EXTERNAL UHDYE AND VHDXE EQUATION TERMS C ** HRU=SUB*HMU*DYU/DXU & HRV=SVB*HMV*DXV/DYV C -c!$OMP PARALLEL DO PRIVATE(LF,LL,LS) -c do ithds=0,nthds-1 -c LF=jse(1,ithds) -c LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA H2P(L)=HP(L) ! *** DSLLC SINGLE LINE + ENDDO +C + DO L=2,LA LS=LSC(L) !DXYU(L)=DXU(L)*DYU(L) !DXIU(L)=1./DXU(L) @@ -185,8 +193,6 @@ C & +SVB(L)*DELT*DYIV(L)*(DXYV(L)*(TSY(L)-RITB1*TBY(L)) & -FCAYE(L)+FPGYE(L)-SNLT*FYE(L)) ENDDO -c - enddo IF(ISDSOLV.GE.1.AND.DEBUG)THEN OPEN(1,FILE='FUV.OUT',POSITION='APPEND',STATUS='UNKNOWN') WRITE(1,1001)N,ISTL @@ -217,19 +223,12 @@ c C C ** SET IMPLICIT BOTTOM AND VEGETATION DRAG AS APPROPRIATE C - RCX(1)=0. - RCY(1)=0. -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA RCX(L)=1. RCY(L)=1. ENDDO -c - enddo + RCX(1)=0. + RCY(1)=0. RCX(LC)=0. RCY(LC)=0. C @@ -276,12 +275,7 @@ C C C ** RESET BOUNDARY CONDITIONS SWITCHES C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA SUB(L)=SUBO(L) SVB(L)=SVBO(L) SBX(L)=SBXO(L) @@ -289,8 +283,6 @@ c c SUB(L+1)=SUBO(L+1) c SBX(L+1)=SBXO(L+1) ENDDO -c - enddo SUB(LC)=SUBO(LC) SBX(LC)=SBXO(LC) SVB(1)=SVBO(1) @@ -306,12 +298,7 @@ C C ** ADJUST VOLUME SOURCE AND SINKS C IF(ISGWIE.EQ.0)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA IF(QSUME(L).LE.0.)THEN IF(H1P(L).LE.HDRY)THEN QSUMTMP(L)=0. @@ -322,16 +309,14 @@ c ELSE QSUMTMP(L)=QSUME(L) ENDIF - DIFQVOL(L)=QSUME(L)-QSUMTMP(L) - QSUME(L)=QSUMTMP(L) ENDDO + DO L=2,LA + DIFQVOL=QSUME(L)-QSUMTMP(L) DO K=1,KC - DO L=LF,LL - QSUM(L,K)=QSUM(L,K)-DIFQVOL(L)*DZC(K) + QSUM(L,K)=QSUM(L,K)-DIFQVOL*DZC(K) ENDDO + QSUME(L)=QSUMTMP(L) ENDDO -c - enddo ENDIF C C ** ADJUST SOURCES AND SINKS ESTIMATING SURFACE AND GROUNDWATER @@ -398,24 +383,19 @@ C EVAPSW(L)=0. QSUMTMP(L)=MAX(QSUME(L),0.0) ENDIF - DIFQVOL(L)=QSUME(L)-QSUMTMP(L) - QSUME(L)=QSUMTMP(L) ENDDO DO L=2,LA + DIFQVOL=QSUME(L)-QSUMTMP(L) DO K=1,KC - QSUM(L,K)=QSUM(L,K)-DIFQVOL(L)*DZC(K) + QSUM(L,K)=QSUM(L,K)-DIFQVOL*DZC(K) ENDDO + QSUME(L)=QSUMTMP(L) ENDDO ENDIF C C ** ADVANCE EXTERNAL VARIABLES C -!$OMP PARALLEL DO PRIVATE(LF,LL,LN) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA UHDY1E(L)=UHDYE(L) VHDX1E(L)=VHDXE(L) P1(L)=P(L) @@ -428,7 +408,7 @@ C PMC H2P(L)=H1P(L) ENDDO C IF(ISGWIE.GE.1)THEN - DO L=LF,LL + DO L=2,LA AGWELV2(L)=AGWELV1(L) AGWELV1(L)=AGWELV(L) ENDDO @@ -439,13 +419,11 @@ C ** HRU=HMU*DYU/DXU & HRV=HMV*DXV/DYV C ** DXYIP=1/(DXP*DYP) C C *** DSLLC BEGIN BLOCK - DO L=LF,LL + DO L=2,LA LN=LNC(L) FP1(L)=DELTI*DXYP(L)*P(L)-0.5*G*(UHDYE(L+1)-UHDYE(L) & +VHDXE(LN )-VHDXE(L)) ENDDO -c - enddo C C ** SET NEW TIME LEVEL TERMS IN CONTINUITY EQUATION INCLUDING C ** HOST-GUEST CHANNAL INTERACTION FOR NON BOUNDARY POINTS @@ -454,20 +432,13 @@ C ** INTERACTION C 1000 CONTINUE C1=0.5*G -!$OMP PARALLEL DO PRIVATE(LF,LL,LN) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA LN=LNC(L) ! *** THE SUB & SVB SWITCHES ALREADY ACCOUNTED FOR FP(L)=FP1(L)-C1*(FUHDYE(L+1)-FUHDYE(L) & +FVHDXE(LN )-FVHDXE(L) & -2.0*QSUME(L) ) ENDDO -c - enddo C IF(ISGWIE.GE.1)THEN DO L=2,LA @@ -476,36 +447,24 @@ C ENDIF C C1=-0.5*DELTD2*G -!$OMP PARALLEL DO PRIVATE(LF,LL,LN) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA CS(L)=C1*SVB(L )*HRVO(L )*RCY(L )*HV(L ) CW(L)=C1*SUB(L )*HRUO(L )*RCX(L )*HU(L ) CE(L)=C1*SUB(L+1)*HRUO(L+1)*RCX(L+1)*HU(L+1) + ENDDO + DO L=2,LA LN=LNC(L) CN(L)=C1*SVB(LN )*HRVO(LN )*RCY(LN )*HV(LN ) ENDDO -c - enddo C C *** APPLY THE OPEN BOUNDARY CONDITIONS C IF(NBCSOP.GT.0) CALL SETOPENBC(DELT,DELTD2,DELTI,HU,HV) C ! *** SET THE CENTER -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA CC(L)=DELTI*DXYP(L)-CS(L)-CW(L)-CE(L)-CN(L) ENDDO -c - enddo C C ** INSERT IMPLICT SUB-GRID SCALE CHANNEL INTERACTIONS C @@ -514,17 +473,10 @@ C C ! *** SCALE COEFFICIENTS IN EXTERNAL MODEL LINEAR EQUATION SYSTEM CCMNM=1.E+18 -!$OMP PARALLEL DO PRIVATE(LF,LL) REDUCTION(min:CCMNM) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA CCMNM=MIN(CCMNM,CC(L)) FPTMP(L)=FP(L) ENDDO -c - enddo CCMNMI=1./CCMNM C @@ -566,12 +518,7 @@ C C ** SCALE BY MINIMUM DIAGONAL C IF(IRVEC.EQ.9)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA CCS(L)=CS(L)*CCMNMI CCW(L)=CW(L)*CCMNMI CCE(L)=CE(L)*CCMNMI @@ -580,8 +527,6 @@ c FPTMP(L)=FPTMP(L)*CCMNMI CCCI(L)=1./CCC(L) ENDDO -c - enddo IF(MDCHH.GE.1)THEN DO NMD=1,MDCHH CCCCHH(NMD)=CCCCHH(NMD)*CCMNMI @@ -672,17 +617,12 @@ C ENDIF ENDIF 1001 FORMAT(2I5,10(1X,E12.4)) - 1002 FORMAT(3I4,10(1X,E9.2)) +C1002 FORMAT(3I4,10(1X,E9.2)) C C ** CALCULATE UHEX AND VHEX AND TOTAL DEPTHS AT TIME LEVEL (N+1) C ** HRU=SUB*DYU/DXU & HRV=SVB*DXV/DYV C -!$OMP PARALLEL DO PRIVATE(LF,LL,LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA LS=LSC(L) UHDYE(L)=SUB(L)*( FUHDYE(L) & -DELTD2*HRUO(L)*RCX(L)*HU(L)*(P(L)-P(L-1)) ) @@ -693,8 +633,6 @@ c UHE(L)=UHDYE(L)*DYIU(L) VHE(L)=VHDXE(L)*DXIV(L) ENDDO -c - enddo C C ** CALCULATE NEW SUB-GRID SCALE CHANNEL EXCHANGE FLOWS C @@ -738,19 +676,12 @@ C C ** CALCULATE REVISED CELL DEPTHS BASED ON NEW HORIZONTAL C ** TRANSPORTS AT (N+1) C -!$OMP PARALLEL DO PRIVATE(LF,LL,LN) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA LN=LNC(L) HP(L)=H1P(L)+DELTD2*DXYIP(L)*(2.*QSUME(L) !+QSUM1E(L) PMC & -(UHDYE(L+1)+UHDY1E(L+1)-UHDYE(L)-UHDY1E(L) & +VHDXE(LN) +VHDX1E(LN )-VHDXE(L)-VHDX1E(L))) ENDDO -c - enddo C IF(ISGWIE.GE.1)THEN DO L=2,LA @@ -788,76 +719,40 @@ C C C ** PERFORM INTERMEDIATE UPDATES OF P C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA P(L)=G*(HP(L)+BELV(L)) ENDDO -c - enddo C C ** CHECK FOR DRYING AND RESOLVE EQUATIONS IF NECESSARY C IF(ISDRY.GT.0.AND.ISDRY.LT.98)THEN ICORDRY=0 -!$OMP PARALLEL DO PRIVATE(LF,LL) REDUCTION(+:ICORDRY) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL-1 + DO L=2,LA + LS=LSC(L) + LN=LNC(L) IF(HP(L).LE.HDRY)THEN IF(ISCDRY(L).EQ.0)THEN ISCDRY(L)=1 - ICORDRY=ICORDRY+1 + ICORDRY=1 ENDIF SUB(L)=0. SVB(L)=0. - SBX(L)=0. - SBY(L)=0. SUB(L+1)=0. - SBX(L+1)=0. - ENDIF - ENDDO -c - enddo - do ithds=0,nthds-1 - LL=jse(2,ithds) -c - L=LL - IF(HP(L).LE.HDRY)THEN - IF(ISCDRY(L).EQ.0)THEN - ISCDRY(L)=1 - ICORDRY=ICORDRY+1 - ENDIF - SUB(L)=0. - SVB(L)=0. + SVB(LN)=0. SBX(L)=0. SBY(L)=0. - SUB(L+1)=0. SBX(L+1)=0. - ENDIF -c - enddo - - DO L=2,LA - IF(HP(L).LE.HDRY)THEN - LN=LNC(L) - IF(SVB(LN).NE.0.) SVB(LN)=0. - IF(SBY(LN).NE.0.) SBY(LN)=0. + SBY(LN)=0. ENDIF ENDDO - IF(ICORDRY.GT.0)THEN + IF(ICORDRY.EQ.1)THEN NCORDRY=NCORDRY+1 GOTO 1000 ENDIF ENDIF - 6960 FORMAT(' NCORDRY =', I5) - 6961 FORMAT(' UNSTABLE, NCORDRY =', I5) - 9999 CONTINUE +C6960 FORMAT(' NCORDRY =', I5) +C6961 FORMAT(' UNSTABLE, NCORDRY =', I5) +C9999 CONTINUE C C ** CHECK FOR DRYING AND RESOLVE EQUATIONS IF NECESSARY C @@ -926,7 +821,9 @@ C ICORDRY=1 ELSE TMPVAL=ABS(SVB(LN)-SVBN) - IF(TMPVAL.GT.0.5)THEN ICORDRY=1 + IF(TMPVAL.GT.0.5)THEN + ICORDRY=1 + ENDIF ENDIF ENDIF ENDIF @@ -1036,38 +933,28 @@ C**********************************************************************C C C ** PERFORM FINAL UPDATES OF P,HU, AND HV C -!$OMP PARALLEL DO PRIVATE(LF,LL,LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA P(L)=G*(HP(L)+BELV(L)) + ENDDO + DO L=2,LA LS=LSC(L) HU(L)=0.5*(DXYP(L)*HP(L)+DXYP(L-1)*HP(L-1))*DXYIU(L) HV(L)=0.5*(DXYP(L)*HP(L)+DXYP(LS )*HP(LS ))*DXYIV(L) H1P(L)=H2P(L) ! *** DSLLC, UPDATE THE LAST DEPTH TO ACTUAL PREVIOUS + ENDDO + DO L=2,LA HPI(L)=1./HP(L) HUI(L)=1./HU(L) HVI(L)=1./HV(L) ENDDO -c - enddo C C ** SET TRANSPORT MASK FOR DRY CELLS C IF(ISDRY.GT.0)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA IMASKDRY(L)=0 LMASKDRY(L)=.TRUE. END DO -c - enddo IF(IDRYTBP.EQ.1)THEN DO L=2,LA LN=LNC(L) @@ -1247,34 +1134,34 @@ C C ** CHECK FOR NEGATIVE DEPTHS C IF(ISNEGH.GE.1)CALL NEGDEP(QCHANUT,QCHANVT,2) - 6910 FORMAT(' DRYING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6911 FORMAT(' DRY W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6912 FORMAT(' DRY E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6913 FORMAT(' DRY S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6914 FORMAT(' DRY N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6920 FORMAT(' WETTING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6921 FORMAT(' WET S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6922 FORMAT(' WET W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6923 FORMAT(' WET E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6924 FORMAT(' WET N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6930 FORMAT(' WET BY VOL N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6940 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6941 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUE,HP,H1P =' - & ,3(2X,E12.4)) - 6942 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUW,HP,H1P =' - & ,3(2X,E12.4)) - 6943 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVS,HP,H1P =' - & ,3(2X,E12.4)) - 6944 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVN,HP,H1P =' - & ,3(2X,E12.4)) - 6945 FORMAT(' RESOLVE NEG, N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6950 FORMAT(' RESOLVE, NEG DEP N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) +C6910 FORMAT(' DRYING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6911 FORMAT(' DRY W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6912 FORMAT(' DRY E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6913 FORMAT(' DRY S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6914 FORMAT(' DRY N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6920 FORMAT(' WETTING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6921 FORMAT(' WET S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6922 FORMAT(' WET W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6923 FORMAT(' WET E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6924 FORMAT(' WET N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6930 FORMAT(' WET BY VOL N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6940 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6941 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUE,HP,H1P =' +C & ,3(2X,E12.4)) +C6942 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUW,HP,H1P =' +C & ,3(2X,E12.4)) +C6943 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVS,HP,H1P =' +C & ,3(2X,E12.4)) +C6944 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVN,HP,H1P =' +C & ,3(2X,E12.4)) +C6945 FORMAT(' RESOLVE NEG, N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6950 FORMAT(' RESOLVE, NEG DEP N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) 8001 FORMAT(I7,5I5,4E13.4) 8002 FORMAT(17X,3I5,4E13.4) 8003 FORMAT(32X,4E13.4) @@ -1312,7 +1199,7 @@ C WRITE(6,6628)DIVEXMX,IMAX,JMAX WRITE(6,6629)DIVEXMN,IMIN,JMIN ENDIF - 566 FORMAT(' I=',I5,3X,'J=',I5,3X,'HP=',F12.4) +C 566 FORMAT(' I=',I5,3X,'J=',I5,3X,'HP=',F12.4) 6628 FORMAT(' DIVEXMX=',E13.5,5X,2I10) 6629 FORMAT(' DIVEXMN=',E13.5,5X,2I10) C @@ -1330,7 +1217,7 @@ C VOLZERD=VOLZERD+VOLADD VETZERD=VETZERD+VOLADD+DT*EVAPSW(L) ENDIF - 5303 FORMAT(2X,F10.4,2X,F10.5,3(2X,E13.5)) +C5303 FORMAT(2X,F10.4,2X,F10.5,3(2X,E13.5)) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2C_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2C_mpi.for new file mode 100644 index 000000000..463f1d3bb --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2C_mpi.for @@ -0,0 +1,1516 @@ + SUBROUTINE CALPUV2C_mpi +C +C ** PREVIOUS NAME WAS CALPUV2TC +C CHANGE RECORD +C MODIFIED DRYING AND WETTING SCHEME. THE OLD FORMULATION REMAINS +C SEE (ISDRY.GT.0.AND.ISDRY.LT.98). THE NEW FORMULATION IS ACTIVATED +C BY (ISDRY.EQ.99). ALSO ADDED OPTION TO WASTE WATER FROM ESSENTIALLY +C DRY CELLS HAVING WATER DEPTHS GREATER THAN HDRY. IE THE HIGH AND +C WET CELLS BLOCKED BY DRY CELLS. THIS IS ACTIVED BY A NEGATIVE VALUE +C OF NDRYSTP PARAMETER IS THE EFDC.INP FILE +C ADDED SAVE OF OLD VALUES OF HORIZONTAL FLOW FACE SWITCHES SUB1 & SVB1 +C AND TRANSPORT BYPASS MASK, IMASKDRY FOR DRY CELLS. ADD VARIABLE +C IDRYDWN TO MARK WASTING FROM BLOCKED CELLS +C ADDED QDWASTE(L) TO SAVE SOURCE EQUIVALENT OF VOLUME LOSS RATE +C FOR REDUCING DEPTH OF HIGH/DRY CELLS. ALSO ADDED CONCENTRATION +C ADJUSTMENT +C ** SUBROUTINE CALPUV2TC CALCULATES THE EXTERNAL SOLUTION FOR P, UHDYE, +C ** AND VHDXE, FOR FREE SURFACE FLOWS WITH PROVISIONS FOR WETTING +C ** AND DRYING OF CELLS +C + USE GLOBAL + USE MPI + IMPLICIT NONE + INTEGER::K,IACTALL + INTEGER::LL,NTMP,LS,LN + INTEGER::IUE,IUW,IVN,IVS + INTEGER::ICHNU,JCHNU + INTEGER::IHOST,JHOST,LHOST + INTEGER::IFACE + INTEGER::ICHNV,JCHNV + INTEGER::LCHNU,LCHNV + INTEGER::IVAL + INTEGER::ITERHP + INTEGER::ICORDRY,NCORDRY,NEWDRY + INTEGER::NMD + INTEGER::IMIN,IMAX,JMIN,JMAX + REAL::C1,CCMNM,CCMNMI + REAL::SUBE,SUBW + REAL::HDRY2,RDRY + REAL::TMPVAL + REAL::SVBS,SVBN,SVPW + REAL::RLAMN,RLAMO + REAL::ETGWTMP,ETGWAVL + REAL::DELTD2,DTAGW,DIFQVOL,DHPDT + REAL::QSUMIET,QEAVAIL,RAVAIL,RIFTRL + REAL::DIVEXMX,DIVEX,DIVEXMN + REAL::VOLADD + REAL::RVAL,RNPORI + REAL::BELVAVG + REAL::HOLDTMP,SURFTMP + REAL::SRFCHAN,SRFHOST,SRFCHAN1,SRFHOST1 + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::IACTIVE + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::IQDRYDWN + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QCHANUT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QCHANVT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QSUMTMP + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SUB1 + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SVB1 + INTEGER LMPI2IC + INTEGER CHECK_DRY + INTEGER LMIN,LMAX,L + L=0 + LMIN=0 + LMAX=0 + IF(.NOT.ALLOCATED(IACTIVE))THEN + ALLOCATE(IACTIVE(NCHANM)) + ALLOCATE(IQDRYDWN(LCM)) + ALLOCATE(QCHANUT(NCHANM)) + ALLOCATE(QCHANVT(NCHANM)) + ALLOCATE(QSUMTMP(LCM)) + ALLOCATE(SUB1(LCM)) + ALLOCATE(SVB1(LCM)) + IACTIVE=0 + IQDRYDWN=0 + QCHANUT=0. + QCHANVT=0. + QSUMTMP=0. + SUB1=0. + SVB1=0. + ENDIF +C + IF(MYRANK.EQ.0.AND.N.EQ.1.AND.DEBUG)THEN + OPEN(1,FILE='MODCHAN.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + ENDIF + IF(MYRANK.EQ.0.AND.N.EQ.1.AND.ISDSOLV.EQ.1.AND.DEBUG)THEN + OPEN(1,FILE='FUV1.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='EQCOEF1.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='EQTERM1.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='FP1.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + ENDIF + IF(MYRANK.EQ.0.AND.N.EQ.2.AND.ISDSOLV.EQ.1.AND.DEBUG)THEN + OPEN(1,FILE='FUV2.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='EQCOEF2.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='EQTERM2.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='FP2.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + ENDIF + IF(MYRANK.EQ.0.AND.ISDSOLV.EQ.1.AND.DEBUG)THEN + OPEN(1,FILE='FUV.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='EQCOEF.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='EQTERM.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='FP.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + ENDIF + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + DELTD2=0.5*DT + DELTI=1./DELT + ELSE + DELT=DTDYN + DELTD2=0.5*DTDYN + DELTI=1./DELT + ENDIF + ISTL=2 + RLAMN=QCHERR + RLAMO=1.-RLAMN +C +C ** SET SWITCHES FOR DRYING AND WETTING +C + ITERHP=0 + NCORDRY=0 + ICORDRY=0 + NEWDRY=0 + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + IQDRYDWN(L)=0 + ISCDRY(L)=0 + ENDDO +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SUB1(L)=SUB(L) + SVB1(L)=SVB(L) + ENDDO + MPI_WTIMES(201)=MPI_WTIMES(201)+MPI_TOC(S1TIME) +C +C ** INITIALIZE SUBGRID SCALE CHANNEL INTERACTIONS +C + IF(MDCHH.GE.1)THEN + DO NMD=1,MDCHH + QCHANUT(NMD)=QCHANU(NMD) + QCHANVT(NMD)=QCHANV(NMD) + ENDDO + ENDIF +C +C ** CALCULATE EXTERNAL BUOYANCY INTEGRALS AT TIME LEVEL (N) +C + IF(BSC.GT.1.E-6)THEN + CALL CALEBI_mpi +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FPGXE(L)=-SBX(L)*HU(L)*GP*((BI2(L)+BI2(L-1))*(HP(L)-HP(L-1)) + & +2.0*HU(L)*(BI1(L)-BI1(L-1)) + & +(BE(L)+BE(L-1))*(BELV(L)-BELV(L-1))) + ENDDO +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + FPGYE(L)=-SBY(L)*HV(L)*GP*((BI2(L)+BI2(LS))*(HP(L)-HP(LS)) + & +2.0*HV(L)*(BI1(L)-BI1(LS)) + & +(BE(L)+BE(LS))*(BELV(L)-BELV(LS))) + ENDDO + MPI_WTIMES(202)=MPI_WTIMES(202)+MPI_TOC(S1TIME) + ENDIF +C + IF(.FALSE.)THEN + call collect_in_zero(FPGXE) + call collect_in_zero(FPGYE) + call collect_in_zero(SBX ) + call collect_in_zero(SBY ) + call collect_in_zero(HU ) + call collect_in_zero(HV ) + call collect_in_zero(HP ) + call collect_in_zero(BI1 ) + call collect_in_zero(BI2 ) + call collect_in_zero(BE ) + call collect_in_zero(BELV ) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'FPGXE = ', sum(abs(dble(FPGXE))) + PRINT*, n,'FPGYE = ', sum(abs(dble(FPGYE))) + PRINT*, n,'SBX = ', sum(abs(dble(SBX ))) + PRINT*, n,'SBY = ', sum(abs(dble(SBY ))) + PRINT*, n,'HU = ', sum(abs(dble(HU ))) + PRINT*, n,'HV = ', sum(abs(dble(HV ))) + PRINT*, n,'HP = ', sum(abs(dble(HP ))) + PRINT*, n,'BI1 = ', sum(abs(dble(BI1 ))) + PRINT*, n,'BI2 = ', sum(abs(dble(BI2 ))) + PRINT*, n,'BE = ', sum(abs(dble(BE ))) + PRINT*, n,'BELV = ', sum(abs(dble(BELV ))) + ENDIF + ENDIF +C ** CALCULATE EXPLICIT EXTERNAL UHDYE AND VHDXE EQUATION TERMS +C ** HRU=SUB*HMU*DYU/DXU & HRV=SVB*HMV*DXV/DYV +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + H2P(L)=HP(L) + ENDDO +C +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + FUHDYE(L)=UHDYE(L) + & -DELTD2*SUB(L)*HRUO(L)*HU(L)*(P(L)-P(L-1)) + & +SUB(L)*DELT*DXIU(L)*(DXYU(L)*(TSX(L)-RITB1*TBX(L)) + & +FCAXE(L)+FPGXE(L)-SNLT*FXE(L)) +C + FVHDXE(L)=VHDXE(L) + & -DELTD2*SVB(L)*HRVO(L)*HV(L)*(P(L)-P(LS)) + & +SVB(L)*DELT*DYIV(L)*(DXYV(L)*(TSY(L)-RITB1*TBY(L)) + & -FCAYE(L)+FPGYE(L)-SNLT*FYE(L)) + ENDDO + MPI_WTIMES(203)=MPI_WTIMES(203)+MPI_TOC(S1TIME) +C + IF(ISDSOLV.GE.1.AND.DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='FUV.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + WRITE(1,1001)IL(L),JL(L),UHDY1E(L),HRUO(L),HU(L),P1(L), + & P1(L-1),TSX1(L),TBX1(L),FCAXE(L),FPGXE(L),FXE(L) + ENDDO + CLOSE(1) + IF(N.EQ.1)THEN + OPEN(1,FILE='FUV1.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + WRITE(1,1001)IL(L),JL(L),UHDY1E(L),HRUO(L),HU(L),P1(L), + & P1(L-1),TSX1(L),TBX1(L),FCAXE(L),FPGXE(L),FXE(L) + ENDDO + CLOSE(1) + ENDIF + IF(N.EQ.2)THEN + OPEN(1,FILE='FUV2.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + WRITE(1,1001)IL(L),JL(L),UHDY1E(L),HRUO(L),HU(L),P1(L), + & P1(L-1),TSX1(L),TBX1(L),FCAXE(L),FPGXE(L),FXE(L) + ENDDO + CLOSE(1) + ENDIF + ENDIF +C +C ** SET IMPLICIT BOTTOM AND VEGETATION DRAG AS APPROPRIATE +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + RCX(L)=1. + RCY(L)=1. + ENDDO + MPI_WTIMES(204)=MPI_WTIMES(204)+MPI_TOC(S1TIME) + + RCX(1)=0. + RCY(1)=0. + RCX(LC)=0. + RCY(LC)=0. +C +C * SINGLE LAYER NO VEGETATION +C + IF(KC.EQ.1)THEN + IF(ISVEG.EQ.0.AND.RITB.GT.0.)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + RCX(L)=1./( 1. + & +RITB*DELT*HUI(L)*STBX(L)*SQRT(VU(L)*VU(L)+U(L,1)*U(L,1))) + RCY(L)=1./( 1. + & +RITB*DELT*HVI(L)*STBY(L)*SQRT(UV(L)*UV(L)+V(L,1)*V(L,1))) + FUHDYE(L)=FUHDYE(L)*RCX(L) + FVHDXE(L)=FVHDXE(L)*RCY(L) + ENDDO + MPI_WTIMES(205)=MPI_WTIMES(205)+MPI_TOC(S1TIME) + ENDIF +C +C * SINGLE LAYER WITH VEGETATION +C + IF(ISVEG.GE.1)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + RCX(L)=1./( 1. + & +RITB*DELT*HUI(L)*STBX(L)*SQRT(VU(L)*VU(L)+U(L,1)*U(L,1)) + & +DELT*FXVEGE(L) ) + RCY(L)=1./( 1. + & +RITB*DELT*HVI(L)*STBY(L)*SQRT(UV(L)*UV(L)+V(L,1)*V(L,1)) + & +DELT*FYVEGE(L) ) + FUHDYE(L)=FUHDYE(L)*RCX(L) + FVHDXE(L)=FVHDXE(L)*RCY(L) + ENDDO + MPI_WTIMES(206)=MPI_WTIMES(206)+MPI_TOC(S1TIME) + ENDIF + ENDIF +C +C * MULTIPLE LAYERS WITH VEGETATION +C + IF(KC.GT.1.AND.ISVEG.GE.1)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + RCX(L)=1./( 1.+DELT*FXVEGE(L) ) + RCY(L)=1./( 1.+DELT*FYVEGE(L) ) + FUHDYE(L)=FUHDYE(L)*RCX(L) + FVHDXE(L)=FVHDXE(L)*RCY(L) + ENDDO + MPI_WTIMES(207)=MPI_WTIMES(207)+MPI_TOC(S1TIME) + ENDIF +C +C ** RESET BOUNDARY CONDITIONS SWITCHES +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SUB(L)=SUBO(L) + SVB(L)=SVBO(L) + SBX(L)=SBXO(L) + SBY(L)=SBYO(L) + SUB(L+1)=SUBO(L+1) + SBX(L+1)=SBXO(L+1) + ENDDO + MPI_WTIMES(208)=MPI_WTIMES(208)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + LN=LNC(L) + SVB(LN)=SVBO(LN) + SBY(LN)=SBYO(LN) + ENDDO + MPI_WTIMES(209)=MPI_WTIMES(209)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + CALL broadcast_boundary(RCX,ic) + CALL broadcast_boundary(RCY,ic) + CALL broadcast_boundary(HRUO,ic) + CALL broadcast_boundary(HRVO,ic) + CALL broadcast_boundary(FUHDYE,ic) + CALL broadcast_boundary(FVHDXE,ic) + CALL broadcast_boundary_lbm(SUB,ic) + CALL broadcast_boundary_lbm(SVB,ic) + CALL broadcast_boundary_lbm(SBX,ic) + CALL broadcast_boundary_lbm(SBY,ic) + MPI_WTIMES(249)=MPI_WTIMES(249)+MPI_TOC(S1TIME) +C + IF(.FALSE.)THEN + call collect_in_zero(RCX ) + call collect_in_zero(RCY ) + call collect_in_zero(HRUO ) + call collect_in_zero(HRVO ) + call collect_in_zero(FUHDYE ) + call collect_in_zero(FVHDXE ) + call COLLECT_IN_ZERO_LBM(SUB ) + call COLLECT_IN_ZERO_LBM(SVB ) + call COLLECT_IN_ZERO_LBM(SBX ) + call COLLECT_IN_ZERO_LBM(SBY ) + call COLLECT_IN_ZERO_LBM(SUBO ) + call COLLECT_IN_ZERO_LBM(SVBO ) + call COLLECT_IN_ZERO_LBM(SBXO ) + call COLLECT_IN_ZERO_LBM(SBYO ) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'RCX = ', sum(abs(dble(RCX ))) + PRINT*, n,'RCY = ', sum(abs(dble(RCY ))) + PRINT*, n,'HRUO = ', sum(abs(dble(HRUO ))) + PRINT*, n,'HRVO = ', sum(abs(dble(HRVO ))) + PRINT*, n,'FUHDYE = ', sum(abs(dble(FUHDYE))) + PRINT*, n,'FVHDXE = ', sum(abs(dble(FVHDXE))) + PRINT*, n,'SUB = ', sum(abs(dble(SUB ))) + PRINT*, n,'SVB = ', sum(abs(dble(SVB ))) + PRINT*, n,'SBX = ', sum(abs(dble(SBX ))) + PRINT*, n,'SBY = ', sum(abs(dble(SBY ))) + PRINT*, n,'SUBO = ', sum(abs(dble(SUBO ))) + PRINT*, n,'SVBO = ', sum(abs(dble(SVBO ))) + PRINT*, n,'SBXO = ', sum(abs(dble(SBXO ))) + PRINT*, n,'SBYO = ', sum(abs(dble(SBYO ))) + ENDIF + ENDIF +C ** ADJUST VOLUME SOURCE AND SINKS +C + IF(ISGWIE.EQ.0)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(QSUME(L).LE.0.)THEN + IF(H1P(L).LE.HDRY)THEN + QSUMTMP(L)=0. + ELSE + QSUMTMP(L)=-(H1P(L)-HDRY)*DXYP(L)*DELTI + QSUMTMP(L)=MAX(QSUMTMP(L),QSUME(L)) + ENDIF + ELSE + QSUMTMP(L)=QSUME(L) + ENDIF + ENDDO +!$OMP PARALLEL DO PRIVATE(DIFQVOL) + DO L=LMPI2,LMPILA + DIFQVOL=QSUME(L)-QSUMTMP(L) + DO K=1,KC + QSUM(L,K)=QSUM(L,K)-DIFQVOL*DZC(K) + ENDDO + QSUME(L)=QSUMTMP(L) + ENDDO + MPI_WTIMES(210)=MPI_WTIMES(210)+MPI_TOC(S1TIME) + ENDIF +C + S1TIME=MPI_TIC() + CALL broadcast_boundary(QSUME,ic) + CALL broadcast_boundary_array(QSUM,ic) + MPI_WTIMES(250)=MPI_WTIMES(250)+MPI_TOC(S1TIME) +C +C ** ADJUST SOURCES AND SINKS ESTIMATING SURFACE AND GROUNDWATER +C ** AVAILABLE FOR EVAPOTRANSPIRATON AND INFILTRATION +C + IF(ISGWIE.GE.1)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(SVPW,DTAGW,RIFTRL,RAVAIL,QSUMIET,QEAVAIL) + DO L=LMPI2,LMPILA + RIFTR(L)=0. + EVAPSW(L)=0. + EVAPGW(L)=0. + IF(H1P(L).GT.HDRY)THEN +C APPLY MAXIMUM ET + IF(EVAPCVT.LT.0.)THEN + SVPW=(10.**((0.7859+0.03477*TEM(L,KC))/ + & (1.+0.00412*TEM(L,KC)))) + EVAPT(L)=CLEVAP(L)*0.7464E-3*WINDST(L)*(SVPW-VPA(L)) + & /PATMT(L) + ENDIF + EVAPSW(L)=EVAPT(L)*DXYP(L) + RIFTR(L)=0. +C CALCULATE DEPTH OF ACTIVE GROUNDWATER ELEV BELOW SURFACE + DTAGW=BELV(L)-AGWELV(L) + IF(DTAGW.GT.0.0)THEN +C INFLITRATION CAN OCCUR, CALCULATE LIMITING RATE TO BRING +C GW ELEV TO SOIL SURFACE + RIFTRL=RNPOR*DTAGW*DELTI +C SET RIFTRL TO MIN OF LIMITING RATE OR ACTUAL RATE + RIFTRL=MIN(RIFTRM,RIFTRL) +C ESTIMATE RATE BASED ON AVAILABLE SURFACE WATER + RAVAIL=(H1P(L)-HDRY)*DELTI-EVAPT(L) +C SET RIFTRL TO MIN OF AVAILABLE RATE OR LIMITING RATE + RIFTRL=MIN(RAVAIL,RIFTRL) +C CONVERT TO VOLUME FLOW UNITS + RIFTR(L)=RIFTRL*DXYP(L) + ENDIF +C ADJUST VOLUME OUTFLOWS OF WET CELLS + IF(QSUME(L).LT.0.0)THEN + QSUMIET=RIFTR(L)+EVAPSW(L) + QEAVAIL=DXYP(L)*(H1P(L)-HDRY)*DELTI-QSUMIET + QEAVAIL=MAX(QEAVAIL,0.0) + QEAVAIL=-QEAVAIL + QSUMTMP(L)=MAX(QSUME(L),QEAVAIL) + ELSE + QSUMTMP(L)=QSUME(L) + ENDIF + ELSE + RIFTR(L)=0. + EVAPSW(L)=0. + QSUMTMP(L)=MAX(QSUME(L),0.0) + ENDIF + ENDDO + MPI_WTIMES(211)=MPI_WTIMES(211)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(DIFQVOL) + DO L=LMPI2,LMPILA + DIFQVOL=QSUME(L)-QSUMTMP(L) + DO K=1,KC + QSUM(L,K)=QSUM(L,K)-DIFQVOL*DZC(K) + ENDDO + QSUME(L)=QSUMTMP(L) + ENDDO + MPI_WTIMES(212)=MPI_WTIMES(212)+MPI_TOC(S1TIME) + ENDIF +C +C ** ADVANCE EXTERNAL VARIABLES +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHDY1E(L)=UHDYE(L) + VHDX1E(L)=VHDXE(L) + P1(L)=P(L) + H1U(L)=HU(L) + H1V(L)=HV(L) + H1UI(L)=HUI(L) + H1VI(L)=HVI(L) + H1P(L)=HP(L) + ENDDO + MPI_WTIMES(213)=MPI_WTIMES(213)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + CALL broadcast_boundary(UHDY1E,ic) + CALL broadcast_boundary(VHDX1E,ic) + CALL broadcast_boundary(P1,ic) + CALL broadcast_boundary(H1P,ic) + MPI_WTIMES(251)=MPI_WTIMES(251)+MPI_TOC(S1TIME) + +C + IF(ISGWIE.GE.1)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AGWELV2(L)=AGWELV1(L) + AGWELV1(L)=AGWELV(L) + ENDDO + MPI_WTIMES(214)=MPI_WTIMES(214)+MPI_TOC(S1TIME) + ENDIF +C +C ** SET OLD TIME LEVEL TERMS IN CONTINUITY EQUATION FOR NON BOUNDARY POINTS +C ** HRU=HMU*DYU/DXU & HRV=HMV*DXV/DYV +C ** DXYIP=1/(DXP*DYP) +C +C *** DSLLC BEGIN BLOCK + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + LN=LNC(L) + FP1(L)=DELTI*DXYP(L)*P(L)-0.5*G*(UHDYE(L+1)-UHDYE(L) + & +VHDXE(LN )-VHDXE(L)) + ENDDO + MPI_WTIMES(215)=MPI_WTIMES(215)+MPI_TOC(S1TIME) +C +C ** SET NEW TIME LEVEL TERMS IN CONTINUITY EQUATION INCLUDING +C ** HOST-GUEST CHANNAL INTERACTION FOR NON BOUNDARY POINTS +C ** REENTER AT 1000 FOR WETTING-DRYING CORRECTION AND CHANNEL +C ** INTERACTION +C + CHECK_DRY=0 + 1000 CONTINUE + CHECK_DRY=CHECK_DRY+1 + C1=0.5*G + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + LN=LNC(L) + FP(L)=FP1(L)-C1*(FUHDYE(L+1)-FUHDYE(L) + & +FVHDXE(LN )-FVHDXE(L) + & -2.0*QSUME(L) ) + ENDDO + MPI_WTIMES(216)=MPI_WTIMES(216)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + IF(ISGWIE.GE.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FP(L)=FP(L)-G*SPB(L)*(RIFTR(L)+EVAPSW(L)) + ENDDO + ENDIF + MPI_WTIMES(217)=MPI_WTIMES(217)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + C1=-0.5*DELTD2*G +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CS(L)=C1*SVB(L )*HRVO(L )*RCY(L )*HV(L ) + CW(L)=C1*SUB(L )*HRUO(L )*RCX(L )*HU(L ) + CE(L)=C1*SUB(L+1)*HRUO(L+1)*RCX(L+1)*HU(L+1) + ENDDO +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + LN=LNC(L) + CN(L)=C1*SVB(LN )*HRVO(LN )*RCY(LN )*HV(LN ) + ENDDO + MPI_WTIMES(218)=MPI_WTIMES(218)+MPI_TOC(S1TIME) +C + IF(.FALSE.)THEN + call COLLECT_IN_ZERO_LBM(SVB ) + call collect_in_zero(HRVO ) + call collect_in_zero(RCY ) + call collect_in_zero(HV ) + call collect_in_zero(CS ) + call collect_in_zero(CW ) + call collect_in_zero(CE ) + call collect_in_zero(CN ) + call collect_in_zero(CC ) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'SVB2 = ', sum(abs(dble(SVB ))) + PRINT*, n,'HRVO2 = ', sum(abs(dble(HRVO))) + PRINT*, n,'RCY2 = ', sum(abs(dble(RCY ))) + PRINT*, n,'HV2 = ', sum(abs(dble(HV ))) + PRINT*, n,'CS2 = ', sum(abs(dble(CS ))) + PRINT*, n,'CW2 = ', sum(abs(dble(CW ))) + PRINT*, n,'CE2 = ', sum(abs(dble(CE ))) + PRINT*, n,'CN2 = ', sum(abs(dble(CN ))) + PRINT*, n,'CC2 = ', sum(abs(dble(CC ))) + ENDIF + ENDIF +C *** APPLY THE OPEN BOUNDARY CONDITIONS +C +C IF(MYRANK.EQ.0) PRINT*,'SETOPENBC',NBCSOP + IF(NBCSOP.GT.0) CALL SETOPENBC(DELT,DELTD2,DELTI,HU,HV) +C + ! *** SET THE CENTER + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CC(L)=DELTI*DXYP(L)-CS(L)-CW(L)-CE(L)-CN(L) + ENDDO + MPI_WTIMES(219)=MPI_WTIMES(219)+MPI_TOC(S1TIME) +C + IF(.FALSE.)THEN + call collect_in_zero(CS ) + call collect_in_zero(CW ) + call collect_in_zero(CE ) + call collect_in_zero(CN ) + call collect_in_zero(CC ) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'CS3 = ', sum(abs(dble(CS ))) + PRINT*, n,'CW3 = ', sum(abs(dble(CW ))) + PRINT*, n,'CE3 = ', sum(abs(dble(CE ))) + PRINT*, n,'CN3 = ', sum(abs(dble(CN ))) + PRINT*, n,'CC3 = ', sum(abs(dble(CC ))) + ENDIF + ENDIF +C ** INSERT IMPLICT SUB-GRID SCALE CHANNEL INTERACTIONS +C +C IF(MYRANK.EQ.0) PRINT*,'SUBCHAN',MDCHH + IF(MDCHH.GE.1)CALL SUBCHAN(QCHANUT,QCHANVT,IACTIVE,RLAMN,RLAMO, + & DELT,IACTALL) +C + ! *** SCALE COEFFICIENTS IN EXTERNAL MODEL LINEAR EQUATION SYSTEM + S1TIME=MPI_TIC() + CCMNM=1.E+18 +!$OMP PARALLEL DO REDUCTION(MIN:CCMNM) + DO L=LMPI2,LMPILA + CCMNM=MIN(CCMNM,CC(L)) + FPTMP(L)=FP(L) + ENDDO + CALL MPI_ALLREDUCE(CCMNM,MPI_R4,1,MPI_REAL,MPI_MIN,MPI_COMM_WORLD, + & IERR) + CCMNM=MPI_R4 + CCMNMI=1./CCMNM + MPI_WTIMES(220)=MPI_WTIMES(220)+MPI_TOC(S1TIME) + +C +C *** APPLY THE OPEN BOUNDARY CONDITIONS FOR ADJACENT CELLS +C +C IF(MYRANK.EQ.0) PRINT*,'SETOPENBC2',NBCSOP + IF(NBCSOP.GT.0) CALL SETOPENBC2 +C + S1TIME=MPI_TIC() + IF(ISDSOLV.GE.1.AND.DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='FP.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + WRITE(1,1001)IL(L),JL(L),FP1(L),FUHDYE(L),FUHDYE(L+1), + & FVHDXE(L),FVHDXE(LNC(L)),QSUME(L),RIFTR(L),EVAPSW(L) + ENDDO + CLOSE(1) + IF(N.EQ.1)THEN + OPEN(1,FILE='FP1.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + WRITE(1,1001)IL(L),JL(L),FP1(L),FUHDYE(L),FUHDYE(L+1), + & FVHDXE(L),FVHDXE(LNC(L)),QSUME(L),RIFTR(L),EVAPSW(L) + ENDDO + CLOSE(1) + ENDIF + IF(N.EQ.2)THEN + OPEN(1,FILE='FP2.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + WRITE(1,1001)IL(L),JL(L),FP1(L),FUHDYE(L),FUHDYE(L+1), + & FVHDXE(L),FVHDXE(LNC(L)),QSUME(L),RIFTR(L),EVAPSW(L) + ENDDO + CLOSE(1) + ENDIF + ENDIF + MPI_WTIMES(221)=MPI_WTIMES(221)+MPI_TOC(S1TIME) +C + CC(1)=1. + CC(LC)=1. +C +C ** SCALE BY MINIMUM DIAGONAL +C + S1TIME=MPI_TIC() + IF(IRVEC.EQ.9)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CCS(L)=CS(L)*CCMNMI + CCW(L)=CW(L)*CCMNMI + CCE(L)=CE(L)*CCMNMI + CCN(L)=CN(L)*CCMNMI + CCC(L)=CC(L)*CCMNMI + FPTMP(L)=FPTMP(L)*CCMNMI + CCCI(L)=1./CCC(L) + ENDDO + IF(MDCHH.GE.1)THEN + DO NMD=1,MDCHH + CCCCHH(NMD)=CCCCHH(NMD)*CCMNMI + ENDDO + ENDIF + ENDIF + MPI_WTIMES(222)=MPI_WTIMES(222)+MPI_TOC(S1TIME) +C +C ** CALL EQUATION SOLVER +C + IF(.FALSE.)THEN + call collect_in_zero(FPTMP) + call collect_in_zero(CCS ) + call collect_in_zero(CCW ) + call collect_in_zero(CCE ) + call collect_in_zero(CCN ) + call collect_in_zero(CCC ) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'FPTMP = ', sum(abs(dble(FPTMP))) + PRINT*, n,'CCS = ', sum(abs(dble(CCS ))) + PRINT*, n,'CCW = ', sum(abs(dble(CCW ))) + PRINT*, n,'CCE = ', sum(abs(dble(CCE ))) + PRINT*, n,'CCN = ', sum(abs(dble(CCN ))) + PRINT*, n,'CCC = ', sum(abs(dble(CCC ))) + ENDIF + ENDIF + IF(MDCHH.EQ.0) CALL CONGRAD_mpi(ISTL) + !IF(MDCHH.EQ.0) CALL CONGRAD_mpi_real(ISTL) + IF(MDCHH.GE.1) CALL CONGRADC(ISTL) +C +C ** DIAGNOSTICS +C + S1TIME=MPI_TIC() + IF(ISDSOLV.GE.1.AND.DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='EQCOEF.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + SURFTMP=GI*P(L) + WRITE(1,1001)IL(L),JL(L),CS(L),CW(L),CC(L),CE(L),CN(L), + & FP(L),SURFTMP + ENDDO + IF(MDCHH.GE.1)THEN + DO NMD=1,MDCHH + WRITE(1,1001)NMD,MDCHTYP(NMD),CCCCHH(NMD),CCCCHU(NMD), + & CCCCHV(NMD),QCHANUT(NMD),QCHANVT(NMD) + ENDDO + ENDIF + CLOSE(1) + IF(N.EQ.1)THEN + OPEN(1,FILE='EQCOEF1.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + SURFTMP=GI*P(L) + WRITE(1,1001)IL(L),JL(L),CS(L),CW(L),CC(L),CE(L),CN(L), + & FP(L),SURFTMP + ENDDO + IF(MDCHH.GE.1)THEN + DO NMD=1,MDCHH + WRITE(1,1001)NMD,MDCHTYP(NMD),CCCCHH(NMD),CCCCHU(NMD), + & CCCCHV(NMD),QCHANUT(NMD),QCHANVT(NMD) + ENDDO + ENDIF + CLOSE(1) + ENDIF + IF(N.EQ.2)THEN + OPEN(1,FILE='EQCOEF2.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + SURFTMP=GI*P(L) + WRITE(1,1001)IL(L),JL(L),CS(L),CW(L),CC(L),CE(L),CN(L), + & FP(L),SURFTMP + ENDDO + IF(MDCHH.GE.1)THEN + DO NMD=1,MDCHH + WRITE(1,1001)NMD,MDCHTYP(NMD),CCCCHH(NMD),CCCCHU(NMD), + & CCCCHV(NMD),QCHANUT(NMD),QCHANVT(NMD) + ENDDO + ENDIF + CLOSE(1) + ENDIF + ENDIF + MPI_WTIMES(223)=MPI_WTIMES(223)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(ISDSOLV.GE.1.AND.DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='EQTERM.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + WRITE(1,1001)IL(L),JL(L),SUB(L),SVB(L),HRUO(L), + & HRVO(L),HU(L),HV(L) + ENDDO + CLOSE(1) + IF(N.EQ.1)THEN + OPEN(1,FILE='EQTERM1.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + WRITE(1,1001)IL(L),JL(L),SUB(L),SVB(L),HRUO(L), + & HRVO(L),HU(L),HV(L) + ENDDO + CLOSE(1) + ENDIF + IF(N.EQ.2)THEN + OPEN(1,FILE='EQTERM2.OUT',POSITION='APPEND',STATUS='UNKNOWN') + WRITE(1,1001)N,ISTL + DO L=2,LA + WRITE(1,1001)IL(L),JL(L),SUB(L),SVB(L),HRUO(L), + & HRVO(L),HU(L),HV(L) + ENDDO + CLOSE(1) + ENDIF + ENDIF + MPI_WTIMES(224)=MPI_WTIMES(224)+MPI_TOC(S1TIME) + 1001 FORMAT(2I5,10(1X,E12.4)) +C1002 FORMAT(3I4,10(1X,E9.2)) +C +C ** CALCULATE UHEX AND VHEX AND TOTAL DEPTHS AT TIME LEVEL (N+1) +C ** HRU=SUB*DYU/DXU & HRV=SVB*DXV/DYV +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + UHDYE(L)=SUB(L)*( FUHDYE(L) + & -DELTD2*HRUO(L)*RCX(L)*HU(L)*(P(L)-P(L-1)) ) + VHDXE(L)=SVB(L)*( FVHDXE(L) + & -DELTD2*HRVO(L)*RCY(L)*HV(L)*(P(L)-P(LS )) ) + ENDDO +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHE(L)=UHDYE(L)*DYIU(L) + VHE(L)=VHDXE(L)*DXIV(L) + ENDDO + MPI_WTIMES(225)=MPI_WTIMES(225)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + CALL broadcast_boundary(UHDYE,ic) + CALL broadcast_boundary(VHDXE,ic) + MPI_WTIMES(252)=MPI_WTIMES(252)+MPI_TOC(S1TIME) +C +C ** CALCULATE NEW SUB-GRID SCALE CHANNEL EXCHANGE FLOWS +C + S1TIME=MPI_TIC() + IF(MDCHH.GE.1)THEN + DO NMD=1,MDCHH + IF (IACTIVE(NMD).GT.0)THEN + LHOST=LMDCHH(NMD) + LCHNU=LMDCHU(NMD) + LCHNV=LMDCHV(NMD) + IF(MDCHTYP(NMD).EQ.1)THEN + QCHANU(NMD)=CCCCHU(NMD)*QCHANUT(NMD) + & -RLAMN*CCCCHU(NMD)*CCCCHV(NMD)*(P(LHOST)-P(LCHNU)) + & -RLAMO*CCCCHU(NMD)*CCCCHV(NMD)*(P1(LHOST)-P1(LCHNU)) + QCHANUN(NMD)=QCHANUT(NMD) + QCHANV(NMD)=0. + QCHANVN(NMD)=QCHANVT(NMD) + ENDIF + IF(MDCHTYP(NMD).EQ.2)THEN + QCHANV(NMD)=CCCCHU(NMD)*QCHANVT(NMD) + & -RLAMN*CCCCHU(NMD)*CCCCHV(NMD)*(P(LHOST)-P(LCHNV)) + & -RLAMO*CCCCHU(NMD)*CCCCHV(NMD)*(P1(LHOST)-P1(LCHNV)) + QCHANVN(NMD)=QCHANVT(NMD) + QCHANU(NMD)=0. + QCHANUN(NMD)=QCHANUT(NMD) + ENDIF + ELSE + QCHANV(NMD)=0. + QCHANVN(NMD)=0. + QCHANU(NMD)=0. + QCHANUN(NMD)=0. + ENDIF + ENDDO + ENDIF + MPI_WTIMES(226)=MPI_WTIMES(226)+MPI_TOC(S1TIME) +C +C ** CALCULATE REVISED CELL DEPTHS BASED ON NEW HORIZONTAL +C ** TRANSPORTS AT (N+1) +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + LN=LNC(L) + HP(L)=H1P(L)+DELTD2*DXYIP(L)*(2.*QSUME(L) !+QSUM1E(L) PMC + & -(UHDYE(L+1)+UHDY1E(L+1)-UHDYE(L)-UHDY1E(L) + & +VHDXE(LN) +VHDX1E(LN )-VHDXE(L)-VHDX1E(L))) + ENDDO + MPI_WTIMES(227)=MPI_WTIMES(227)+MPI_TOC(S1TIME) +C + IF(.FALSE.)THEN + call collect_in_zero(DXYIP ) + call collect_in_zero(QSUME ) + call collect_in_zero(UHDYE ) + call collect_in_zero(VHDXE ) + call collect_in_zero(H1P ) + call collect_in_zero(HP ) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'DXYIP = ', sum(abs(dble(DXYIP))) + PRINT*, n,'QSUME = ', sum(abs(dble(QSUME))) + PRINT*, n,'UHDYE = ', sum(abs(dble(UHDYE))) + PRINT*, n,'VHDXE = ', sum(abs(dble(VHDXE))) + PRINT*, n,'H1P = ', sum(abs(dble(H1P ))) + PRINT*, n,'HP = ', sum(abs(dble(HP ))) + ENDIF + ENDIF + + S1TIME=MPI_TIC() + IF(ISGWIE.GE.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + HP(L)=HP(L)-DELT*DXYIP(L)*(RIFTR(L)+EVAPSW(L)) + ENDDO + ENDIF + MPI_WTIMES(228)=MPI_WTIMES(228)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + ! *** APPLY OPEN BOUNDARYS + DO LL=1,NBCSOP + L=LOBCS(LL) + HP(L)=GI*P(L)-BELV(L) + ENDDO +C +C ** ADD CHANNEL INTERACTION EXCHANGES +C + IF(MDCHH.GE.1)THEN + DO NMD=1,MDCHH + IF(IACTIVE(NMD).GT.0)THEN + LHOST=LMDCHH(NMD) + LCHNU=LMDCHU(NMD) + LCHNV=LMDCHV(NMD) + IF(MDCHTYP(NMD).EQ.1)THEN + TMPVAL=DELT*(RLAMN*QCHANU(NMD)+RLAMO*QCHANUT(NMD)) + HP(LHOST)=HP(LHOST)+TMPVAL*DXYIP(LHOST) + HP(LCHNU)=HP(LCHNU)-TMPVAL*DXYIP(LCHNU) + ENDIF + IF(MDCHTYP(NMD).EQ.2)THEN + TMPVAL=DELT*(RLAMN*QCHANV(NMD)+RLAMO*QCHANVT(NMD)) + HP(LHOST)=HP(LHOST)+TMPVAL*DXYIP(LHOST) + HP(LCHNV)=HP(LCHNV)-TMPVAL*DXYIP(LCHNV) + ENDIF + ENDIF + ENDDO + ENDIF + MPI_WTIMES(229)=MPI_WTIMES(229)+MPI_TOC(S1TIME) +C +C ** PERFORM INTERMEDIATE UPDATES OF P +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + P(L)=G*(HP(L)+BELV(L)) + ENDDO + MPI_WTIMES(230)=MPI_WTIMES(230)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + CALL broadcast_boundary(P,2*ic) + CALL broadcast_boundary(HP,2*ic) + MPI_WTIMES(253)=MPI_WTIMES(253)+MPI_TOC(S1TIME) +C +C ** CHECK FOR DRYING AND RESOLVE EQUATIONS IF NECESSARY +C +CGEO call collect_in_zero(HP ) +CGEO IF(MYRANK.EQ.0)THEN +CGEO PRINT*, n,'HP = ', sum(abs(dble(HP))) +CGEO ENDIF +C + IF(ISDRY.GT.0.AND.ISDRY.LT.98)THEN + S1TIME=MPI_TIC() + ICORDRY=0 + LMPI2IC=MAX(2,LMPI2-IC) + DO L=LMPI2IC,LMPILA + LS=LSC(L) + LN=LNC(L) + IF(HP(L).LE.HDRY)THEN + IF(ISCDRY(L).EQ.0)THEN + ISCDRY(L)=1 + ICORDRY=1 + ENDIF + SUB(L)=0. + SVB(L)=0. + SUB(L+1)=0. + SVB(LN)=0. + SBX(L)=0. + SBY(L)=0. + SBX(L+1)=0. + SBY(LN)=0. + ENDIF + ENDDO + MPI_WTIMES(231)=MPI_WTIMES(231)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + CALL broadcast_boundary_lbm(SUB,ic) + CALL broadcast_boundary_lbm(SVB,ic) + CALL broadcast_boundary_lbm(SBX,ic) + CALL broadcast_boundary_lbm(SBY,ic) + CALL MPI_ALLREDUCE(ICORDRY,MPI_I4,1,MPI_INTEGER, + & MPI_MAX,MPI_COMM_WORLD,IERR) + ICORDRY=MPI_I4 + MPI_WTIMES(254)=MPI_WTIMES(254)+MPI_TOC(S1TIME) +C +CGEO IF(MYRANK.EQ.0) PRINT*,N,1,ICORDRY + IF(ICORDRY.EQ.1)THEN + NCORDRY=NCORDRY+1 + GOTO 1000 + ENDIF + ENDIF +C6960 FORMAT(' NCORDRY =', I5) +C6961 FORMAT(' UNSTABLE, NCORDRY =', I5) +C9999 CONTINUE +C +C ** CHECK FOR DRYING AND RESOLVE EQUATIONS IF NECESSARY +C + CALL broadcast_boundary_lbm(SUB,ic) + CALL broadcast_boundary_lbm(SVB,ic) + CALL broadcast_boundary_lbm(SBX,ic) + CALL broadcast_boundary_lbm(SBY,ic) + CALL broadcast_boundary_lbm(SUBO,ic) + CALL broadcast_boundary_lbm(SVBO,ic) + S1TIME=MPI_TIC() + IF(ISDRY.EQ.99)THEN + HDRY2=2.*HDRY + ICORDRY=0 + LMPI2IC=MAX(2,LMPI2-IC) + DO L=LMPI2IC,LMPILA + LS=LSC(L) + LN=LNC(L) + IF(HP(L).LE.HDRY)THEN + SUBW=SUB(L) + SUBE=SUB(L+1) + SVBS=SVB(L) + SVBN=SVB(LN) + DHPDT=DELTI*(HP(L)-H1P(L)) + ! *** ALLOW RE-WETTING + IF(DHPDT.GT.0.0)THEN + SUB(L)=0.0 + SUB(L+1)=0.0 + SVB(L)=0.0 + SVB(LN)=0.0 + SBX(L)=0.0 + SBX(L+1)=0.0 + SBY(L)=0.0 + SBY(LN)=0.0 + IF(SUBO(L).GT.0.5)THEN + IF(UHDYE(L).GT.0.0.AND.HP(L-1).GT.HDRY2)THEN + SUB(L)=1. + SBX(L)=1. + ENDIF + ENDIF + IF(SUBO(L+1).GT.0.5)THEN + IF(UHDYE(L+1).LT.0.0.AND.HP(L+1).GT.HDRY2)THEN + SUB(L+1)=1. + SBX(L+1)=1. + ENDIF + ENDIF + IF(SVBO(L).GT.0.5)THEN + IF(VHDXE(L).GT.0.0.AND.HP(LS).GT.HDRY2)THEN + SVB(L)=1. + SBY(L)=1. + ENDIF + ENDIF + IF(SVBO(LN).GT.0.5)THEN + IF(VHDXE(LN).LT.0.0.AND.HP(LN).GT.HDRY2)THEN + SVB(LN)=1. + SBY(LN)=1. + ENDIF + ENDIF + RDRY=SUB(L)+SUB(L+1)+SVB(L)+SVB(LN) + IF(RDRY.LT.0.5)THEN + ISCDRY(L)=1 + ELSE + ISCDRY(L)=0 + ENDIF + TMPVAL=ABS(SUB(L)-SUBW) + IF(TMPVAL.GT.0.5)THEN + ICORDRY=1 + ELSE + TMPVAL=ABS(SUB(L+1)-SUBE) + IF(TMPVAL.GT.0.5)THEN + ICORDRY=1 + ELSE + TMPVAL=ABS(SVB(L)-SVBS) + IF(TMPVAL.GT.0.5)THEN + ICORDRY=1 + ELSE + TMPVAL=ABS(SVB(LN)-SVBN) + IF(TMPVAL.GT.0.5)THEN + ICORDRY=1 + ENDIF + ENDIF + ENDIF + ENDIF + ELSE + SUB(L)=0.0 + SUB(L+1)=0.0 + SVB(L)=0.0 + SVB(LN)=0.0 + SBX(L)=0.0 + SBX(L+1)=0.0 + SBY(L)=0.0 + SBY(LN)=0.0 + IF(ISCDRY(L).EQ.0)THEN + ISCDRY(L)=1 + ICORDRY=1 + ENDIF + ENDIF + ENDIF + ENDDO + S1TIME=MPI_TIC() + CALL broadcast_boundary_lbm(SUB,ic) + CALL broadcast_boundary_lbm(SVB,ic) + CALL broadcast_boundary_lbm(SBX,ic) + CALL broadcast_boundary_lbm(SBY,ic) + CALL MPI_ALLREDUCE(ICORDRY,MPI_I4,1,MPI_INTEGER, + & MPI_MAX,MPI_COMM_WORLD,IERR) + ICORDRY=MPI_I4 +CGEO IF(MYRANK.EQ.0) PRINT*,N,2,ICORDRY + MPI_WTIMES(254)=MPI_WTIMES(254)+MPI_TOC(S1TIME) + IF(ICORDRY.EQ.1)THEN + NCORDRY=NCORDRY+1 + GOTO 1000 + ENDIF + ENDIF + MPI_WTIMES(232)=MPI_WTIMES(232)+MPI_TOC(S1TIME) + +C WRITE(8,6960)NCORDRY +C**********************************************************************C +C +C ** COUNT THE NUMBER TO TIME STEPS A CELL IS DRY, AND IF IT HAS BEEN +C ** DRY FOR MORE THAN ABS(NDRYSTP), AND ITS BOTTOM ELEVATION IS HIGHER +C ** THAN THE SURROUNDING DRY CELLS, THEN REDUCE ITS DEPTH BELOW THE +C ** DRYING DEPTH IF NECESSARY. SAVE VOLUME REDUCTION RATE AS QDWASTE +C ** DEFINED AS POSITIVE OUT. THEN ADJUST CONCENTRATIONS +C + S1TIME=MPI_TIC() + IF(ISDRY.GT.0) THEN + IF(NDRYSTP.LT.0) THEN + NTMP=ABS(NDRYSTP) +!$OMP PARALLEL DO PRIVATE(LN,LS,RDRY,BELVAVG,RVAL,HOLDTMP,TMPVAL) + DO L=LMPI2,LMPILA + LN=LNC(L) + LS=LSC(L) + QDWASTE(L)=0. + IQDRYDWN(L)=0 + RDRY=SUB(L)+SUB(L+1)+SVB(L)+SVB(LN) + IF(RDRY.GT.0.5)NATDRY(L)=0 + IF(RDRY.LT.0.5)NATDRY(L)=NATDRY(L)+1 + IF(NATDRY(L).GT.NTMP)THEN + IF(HP(L).GE.HDRY)THEN + BELVAVG=0.0 + RVAL=0.0 + IF(HP(L+1).LT.HDRY.AND.SUBO(L+1).GT.0.5)THEN + BELVAVG=BELVAVG+BELV(L+1) + RVAL=RVAL+1. + ENDIF + IF(HP(L-1).LT.HDRY.AND.SUBO(L).GT.0.5)THEN + BELVAVG=BELVAVG+BELV(L-1) + RVAL=RVAL+1. + ENDIF + IF(HP(LN).LT.HDRY.AND.SVBO(LN).GT.0.5)THEN + BELVAVG=BELVAVG+BELV(LN) + RVAL=RVAL+1. + ENDIF + IF(HP(LS).LT.HDRY.AND.SVBO(L).GT.0.5)THEN + BELVAVG=BELVAVG+BELV(LS) + RVAL=RVAL+1. + ENDIF + IF(BELV(L).GE.BELVAVG)THEN + HOLDTMP=HP(L) + IQDRYDWN(L)=1 + HP(L)=0.90*HDRY + NATDRY(L)=0 + QDWASTE(L)=DELTI*DXYP(L)*(HOLDTMP-HP(L)) + VDWASTE(L)=VDWASTE(L)+DXYP(L)*(HOLDTMP-HP(L)) + TMPVAL=HOLDTMP/HP(L) + ENDIF + END IF + ENDIF + IF(QDWASTE(L).GT.0.0)THEN + TMPVAL=QDWASTE(L)/DXYP(L) + ENDIF + ENDDO + ENDIF + ENDIF + MPI_WTIMES(233)=MPI_WTIMES(233)+MPI_TOC(S1TIME) +C +C 8888 FORMAT(' QDW ',2I6,6E14.6) +C +C**********************************************************************C +C +C ** PERFORM FINAL UPDATES OF P,HU, AND HV +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + P(L)=G*(HP(L)+BELV(L)) + ENDDO +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + HU(L)=0.5*(DXYP(L)*HP(L)+DXYP(L-1)*HP(L-1))*DXYIU(L) + HV(L)=0.5*(DXYP(L)*HP(L)+DXYP(LS )*HP(LS ))*DXYIV(L) + H1P(L)=H2P(L) ! *** DSLLC, UPDATE THE LAST DEPTH TO ACTUAL PREVIOUS + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + HPI(L)=1./HP(L) + HUI(L)=1./HU(L) + HVI(L)=1./HV(L) + ENDDO + MPI_WTIMES(234)=MPI_WTIMES(234)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + CALL broadcast_boundary(HU,ic) + CALL broadcast_boundary(HV,ic) + MPI_WTIMES(255)=MPI_WTIMES(255)+MPI_TOC(S1TIME) +C +C ** SET TRANSPORT MASK FOR DRY CELLS +C + S1TIME=MPI_TIC() + CALL broadcast_boundary(SUB1,ic) + CALL broadcast_boundary(SVB1,ic) + IF(ISDRY.GT.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IMASKDRY(L)=0 + LMASKDRY(L)=.TRUE. + END DO + IF(IDRYTBP.EQ.1)THEN + LMPI2IC=MAX(2,LMPI2-IC) +!$OMP PARALLEL DO PRIVATE(LN,IUW,IUE,IVS,IVN,IFACE) + DO L=LMPI2IC,LMPILA + LN=LNC(L) + IUW=0 + IUE=0 + IVS=0 + IVN=0 + IF(SUB1(L).LT.0.5.AND.SUB(L).LT.0.5)IUE=1 + IF(SUB1(L+1).LT.0.5.AND.SUB(L+1).LT.0.5)IUW=1 + IF(SVB1(L).LT.0.5.AND.SVB(L).LT.0.5)IVS=1 + IF(SVB1(LN).LT.0.5.AND.SVB(LN).LT.0.5)IVN=1 + IFACE=IUW+IUE+IVS+IVN + IF(IFACE.EQ.4)THEN + IMASKDRY(L)=1 + LMASKDRY(L)=.FALSE. + IF(H1P(L).EQ.HP(L))IMASKDRY(L)=2 + END IF + IF(IQDRYDWN(L).EQ.1)THEN + IMASKDRY(L)=0 + LMASKDRY(L)=.TRUE. + ENDIF + END DO + END IF + END IF + MPI_WTIMES(235)=MPI_WTIMES(235)+MPI_TOC(S1TIME) +C +C ** OUTPUT DIAGNOSTICS FOR 2 GRID INTERATCTION +C + S1TIME=MPI_TIC() + IF(MDCHH.GT.0.AND.DEBUG)THEN + IF(MDCHHD.GT.0)THEN + IVAL=MOD(N,MDCHHD2) + IF(IVAL.EQ.0)THEN + IF(IACTALL.GT.0)THEN + IF(DEBUG)OPEN(1,FILE='MODCHAN.OUT',POSITION='APPEND') + DO NMD=1,MDCHH + WRITE(1,8000) + LHOST=LMDCHH(NMD) + IHOST=IL(LHOST) + JHOST=JL(LHOST) + LCHNU=LMDCHU(NMD) + LCHNV=LMDCHV(NMD) +C X-DIRECTION CHANNEL + IF(MDCHTYP(NMD).EQ.1)THEN + ICHNU=IL(LCHNU) + JCHNU=JL(LCHNU) + SRFCHAN=HP(LCHNU)+BELV(LCHNU) + SRFHOST=HP(LHOST)+BELV(LHOST) + SRFCHAN1=H1P(LCHNU)+BELV(LCHNU) + SRFHOST1=H1P(LHOST)+BELV(LHOST) + IF(MYRANK.EQ.0)THEN + WRITE(1,8001)N,NMD,MDCHTYP(NMD),ICHNU,JCHNU, + & ISCDRY(LCHNU),SRFCHAN,HP(LCHNU),SRFCHAN1,H1P(LCHNU) + WRITE(1,8002)IHOST,JHOST,ISCDRY(LHOST), + & SRFHOST,HP(LHOST),SRFHOST1,H1P(LHOST) + WRITE(1,8003)QCHANU(NMD),QCHANUT(NMD),CCCCHU(NMD) + & ,CCCCHV(NMD) + ENDIF + ENDIF +C Y-DIRECTION CHANNEL + IF(MDCHTYP(NMD).EQ.2)THEN + ICHNV=IL(LCHNV) + JCHNV=JL(LCHNV) + SRFCHAN=HP(LCHNV)+BELV(LCHNV) + SRFHOST=HP(LHOST)+BELV(LHOST) + SRFCHAN1=H1P(LCHNV)+BELV(LCHNV) + SRFHOST1=H1P(LHOST)+BELV(LHOST) + IF(MYRANK.EQ.0)THEN + WRITE(1,8001)N,NMD,MDCHTYP(NMD),ICHNV,JCHNV, + & ISCDRY(LCHNV),SRFCHAN,HP(LCHNV),SRFCHAN1,H1P(LCHNV) + WRITE(1,8002)IHOST,JHOST,ISCDRY(LHOST), + & SRFHOST,HP(LHOST),SRFHOST1,H1P(LHOST) + WRITE(1,8003)QCHANV(NMD),QCHANVT(NMD),CCCCHU(NMD) + & ,CCCCHV(NMD) + ENDIF + ENDIF + WRITE(1,8004) + ENDDO + CLOSE(1) + ENDIF + ENDIF + ENDIF + ENDIF + MPI_WTIMES(236)=MPI_WTIMES(236)+MPI_TOC(S1TIME) +C +C ** PERFORM UPDATE ON GROUNDWATER ELEVATION +C + S1TIME=MPI_TIC() + IF(ISGWIE.GE.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + QSUM(L,KC)=QSUM(L,KC)-EVAPSW(L) + QSUM(L,1 )=QSUM(L,1 )-RIFTR(L) + ENDDO +C +C INFILTRATION STEP +C + RNPORI=1./RNPOR + IF(ISTL.EQ.3)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AGWELV(L)=AGWELV2(L)+RNPORI*DELT*DXYIP(L)*RIFTR(L) + ENDDO + ELSE +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AGWELV(L)=AGWELV1(L)+RNPORI*DELT*DXYIP(L)*RIFTR(L) + ENDDO + ENDIF +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AGWELV(L)=MIN(AGWELV(L),BELV(L)) + ENDDO +C +C ET STEP +C +!$OMP PARALLEL DO PRIVATE(SVPW,ETGWTMP,ETGWAVL) + DO L=LMPI2,LMPILA + IF(EVAPCVT.LT.0.)THEN + SVPW=(10.**((0.7859+0.03477*TEM(L,KC))/ + & (1.+0.00412*TEM(L,KC)))) + EVAPT(L)=CLEVAP(L)*0.7464E-3*WINDST(L)*(SVPW-VPA(L))/PATMT(L) + ENDIF + ETGWTMP=EVAPT(L)-EVAPSW(L)*DXYIP(L) + ETGWTMP=MAX(ETGWTMP,0.0) + ETGWAVL=RNPOR*DELTI*(AGWELV(L)-BELAGW(L)) + ETGWAVL=MAX(ETGWAVL,0.0) + ETGWTMP=MIN(ETGWTMP,ETGWAVL) + EVAPGW(L)=ETGWTMP*DXYP(L) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AGWELV(L)=AGWELV(L)-RNPORI*DELT*DXYIP(L)*EVAPGW(L) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AGWELV(L)=MAX(AGWELV(L),BELAGW(L)) + ENDDO + ENDIF + MPI_WTIMES(237)=MPI_WTIMES(237)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(N.EQ.NTS.AND.DEBUG.AND.MYRANK.EQ.0)THEN + IF(MDCHH.GT.0)THEN + DO NMD=1,MDCHH + WRITE(8,8000) + LHOST=LMDCHH(NMD) + IHOST=IL(LHOST) + JHOST=JL(LHOST) + LCHNU=LMDCHU(NMD) + LCHNV=LMDCHV(NMD) +C X-DIRECTION CHANNEL + IF(MDCHTYP(NMD).EQ.1)THEN + ICHNU=IL(LCHNU) + JCHNU=JL(LCHNU) + SRFCHAN=HP(LCHNU)+BELV(LCHNU) + SRFHOST=HP(LHOST)+BELV(LHOST) + SRFCHAN1=H1P(LCHNU)+BELV(LCHNU) + SRFHOST1=H1P(LHOST)+BELV(LHOST) + IF(MYRANK.EQ.0)THEN + WRITE(8,8001)N,NMD,MDCHTYP(NMD),ICHNU,JCHNU,ISCDRY(LCHNU), + & SRFCHAN,HP(LCHNU),P1(LCHNU),H1P(LCHNU) + WRITE(8,8002)IHOST,JHOST,ISCDRY(LHOST), + & SRFHOST,HP(LHOST),P1(LHOST),H1P(LHOST) + WRITE(8,8003)QCHANU(NMD),QCHANUT(NMD),CCCCHU(NMD), + & CCCCHV(NMD) + ENDIF + ENDIF +C Y-DIRECTION CHANNEL + IF(MDCHTYP(NMD).EQ.2)THEN + ICHNV=IL(LCHNV) + JCHNV=JL(LCHNV) + SRFCHAN=HP(LCHNV)+BELV(LCHNV) + SRFHOST=HP(LHOST)+BELV(LHOST) + SRFCHAN1=H1P(LCHNV)+BELV(LCHNV) + SRFHOST1=H1P(LHOST)+BELV(LHOST) + IF(MYRANK.EQ.0)THEN + WRITE(8,8001)N,NMD,MDCHTYP(NMD),ICHNV,JCHNV,ISCDRY(LCHNV), + & SRFCHAN,HP(LCHNV),SRFCHAN1,H1P(LCHNV) + WRITE(8,8002)IHOST,JHOST,ISCDRY(LHOST), + & SRFHOST,HP(LHOST),SRFHOST1,H1P(LHOST) + WRITE(8,8003)QCHANV(NMD),QCHANVT(NMD),CCCCHU(NMD), + & CCCCHV(NMD) + ENDIF + ENDIF + WRITE(8,8004) + ENDDO + ENDIF + ENDIF + MPI_WTIMES(238)=MPI_WTIMES(238)+MPI_TOC(S1TIME) +C +C ** CHECK FOR NEGATIVE DEPTHS +C + S1TIME=MPI_TIC() + IF(ISNEGH.GE.1)CALL NEGDEP(QCHANUT,QCHANVT,2) + MPI_WTIMES(239)=MPI_WTIMES(239)+MPI_TOC(S1TIME) +C6910 FORMAT(' DRYING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6911 FORMAT(' DRY W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6912 FORMAT(' DRY E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6913 FORMAT(' DRY S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6914 FORMAT(' DRY N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6920 FORMAT(' WETTING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6921 FORMAT(' WET S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6922 FORMAT(' WET W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6923 FORMAT(' WET E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6924 FORMAT(' WET N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6930 FORMAT(' WET BY VOL N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6940 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6941 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUE,HP,H1P =' +C & ,3(2X,E12.4)) +C6942 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUW,HP,H1P =' +C & ,3(2X,E12.4)) +C6943 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVS,HP,H1P =' +C & ,3(2X,E12.4)) +C6944 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVN,HP,H1P =' +C & ,3(2X,E12.4)) +C6945 FORMAT(' RESOLVE NEG, N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6950 FORMAT(' RESOLVE, NEG DEP N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) + 8001 FORMAT(I7,5I5,4E13.4) + 8002 FORMAT(17X,3I5,4E13.4) + 8003 FORMAT(32X,4E13.4) + 8000 FORMAT(' N NMD MTYP I J IDRY P H', + & ' P1 H1') + 8004 FORMAT(' QCHANU', + & ' QCHANUT CCCCHU CCCCHV ') +C +C ** CALCULATE THE EXTERNAL DIVERGENCE +C + S1TIME=MPI_TIC() + IF(ISDIVEX.EQ.1)THEN + DIVEXMX=0. + DIVEXMN=1000000. + DO L=2,LA + IF(SPB(L).NE.0)THEN + LN=LNC(L) + DIVEX=SPB(L)*(DXYP(L)*(HP(L)-H1P(L))*DELTI + & +0.5*(UHDYE(L+1)+UHDY1E(L+1)-UHDYE(L)-UHDY1E(L) + & +VHDXE(LN)+VHDX1E(LN)-VHDXE(L)-VHDX1E(L))-QSUME(L) + & +RIFTR(L)+EVAPSW(L)) + IF(DIVEX.GT.DIVEXMX)THEN + DIVEXMX=DIVEX + LMAX=L + ENDIF + IF(DIVEX.LT.DIVEXMN)THEN + DIVEXMN=DIVEX + LMIN=L + ENDIF + ENDIF + ENDDO + IMAX=IL(LMAX) + JMAX=JL(LMAX) + IMIN=IL(LMIN) + JMIN=JL(LMIN) + IF(MYRANK.EQ.0)WRITE(6,6628)DIVEXMX,IMAX,JMAX + IF(MYRANK.EQ.0)WRITE(6,6629)DIVEXMN,IMIN,JMIN + ENDIF + MPI_WTIMES(240)=MPI_WTIMES(240)+MPI_TOC(S1TIME) +C 566 FORMAT(' I=',I5,3X,'J=',I5,3X,'HP=',F12.4) + 6628 FORMAT(' DIVEXMX=',E13.5,5X,2I10) + 6629 FORMAT(' DIVEXMN=',E13.5,5X,2I10) +C +C ** UPDATE ZERO DIMENSION VOLUME BALANCE +C + ISTL=2 + S1TIME=MPI_TIC() + IF(ISDRY.GE.1.AND.ISTL.EQ.3)THEN + VOLADD=0. +!$OMP PARALLEL DO REDUCTION(+:VOLADD) + DO L=LMPI2,LMPILA + IF(SPB(L).NE.0)THEN + VOLADD=VOLADD+QSUME(L)-RIFTR(L)-EVAPSW(L) + ENDIF + ENDDO + CALL MPI_ALLREDUCE(VOLADD,MPI_R4,1,MPI_REAL, + & MPI_MIN,MPI_COMM_WORLD,IERR) + VOLADD=MPI_R4 + VOLADD=VOLADD*DT + VOLZERD=VOLZERD+VOLADD + VETZERD=VETZERD+VOLADD+DT*EVAPSW(L) + ENDIF + MPI_WTIMES(241)=MPI_WTIMES(241)+MPI_TOC(S1TIME) +C5303 FORMAT(2X,F10.4,2X,F10.5,3(2X,E13.5)) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2T.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2T.for index 0cafe0a06..92bb03c20 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2T.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV2T.for @@ -15,6 +15,9 @@ C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QCHANUT REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QCHANVT REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QSUMTMP + INTEGER LMIN,LMAX + LMIN = 0 + LMAX = 0 IF(.NOT.ALLOCATED(QCHANUT))THEN ALLOCATE(QCHANUT(NCHANM)) @@ -515,7 +518,7 @@ C ENDIF ENDIF 1001 FORMAT(2I5,10(1X,E12.4)) - 1002 FORMAT(3I4,10(1X,E9.2)) +C1002 FORMAT(3I4,10(1X,E9.2)) C C ** CALCULATE UHEX AND VHEX AND TOTAL DEPTHS AT TIME LEVEL (N+1) C ** HRU=SUB*DYU/DXU & HRV=SVB*DXV/DYV @@ -634,34 +637,34 @@ C ** CHECK FOR NEGATIVE DEPTHS C ISTLX=ISTL IF(ISNEGH.GE.1)CALL NEGDEP(QCHANUT,QCHANVT,ISTLX) - 6910 FORMAT(' DRYING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6911 FORMAT(' DRY W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6912 FORMAT(' DRY E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6913 FORMAT(' DRY S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6914 FORMAT(' DRY N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6920 FORMAT(' WETTING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6921 FORMAT(' WET S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6922 FORMAT(' WET W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6923 FORMAT(' WET E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6924 FORMAT(' WET N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6930 FORMAT(' WET BY VOL N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6940 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6941 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUE,HP,H1P =' - & ,3(2X,E12.4)) - 6942 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUW,HP,H1P =' - & ,3(2X,E12.4)) - 6943 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVS,HP,H1P =' - & ,3(2X,E12.4)) - 6944 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVN,HP,H1P =' - & ,3(2X,E12.4)) - 6945 FORMAT(' RESOLVE NEG, N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6950 FORMAT(' RESOLVE, NEG DEP N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) +C6910 FORMAT(' DRYING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6911 FORMAT(' DRY W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6912 FORMAT(' DRY E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6913 FORMAT(' DRY S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6914 FORMAT(' DRY N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6920 FORMAT(' WETTING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6921 FORMAT(' WET S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6922 FORMAT(' WET W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6923 FORMAT(' WET E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6924 FORMAT(' WET N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6930 FORMAT(' WET BY VOL N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6940 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6941 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUE,HP,H1P =' +C & ,3(2X,E12.4)) +C6942 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUW,HP,H1P =' +C & ,3(2X,E12.4)) +C6943 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVS,HP,H1P =' +C & ,3(2X,E12.4)) +C6944 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVN,HP,H1P =' +C & ,3(2X,E12.4)) +C6945 FORMAT(' RESOLVE NEG, N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6950 FORMAT(' RESOLVE, NEG DEP N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) C C ** CALCULATE THE EXTERNAL DIVERGENCE C @@ -692,7 +695,7 @@ C WRITE(6,6628)DIVEXMX,IMAX,JMAX WRITE(6,6629)DIVEXMN,IMIN,JMIN ENDIF - 566 FORMAT(' I=',I5,3X,'J=',I5,3X,'HP=',F12.4) +C 566 FORMAT(' I=',I5,3X,'J=',I5,3X,'HP=',F12.4) 6628 FORMAT(' DIVEXMX=',E13.5,5X,2I10) 6629 FORMAT(' DIVEXMN=',E13.5,5X,2I10) C @@ -710,7 +713,7 @@ C IF(ISDRY.GE.1.AND.ISTL.EQ.3)THEN VOLZERD=VOLZERD+VOLADD VETZERD=VETZERD+VOLADD+DT*EVAPSW(L) ENDIF - 5303 FORMAT(2X,F10.4,2X,F10.5,3(2X,E13.5)) +C5303 FORMAT(2X,F10.4,2X,F10.5,3(2X,E13.5)) C !CALL NOW_CHECK ! PMC TESTING C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV9.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV9.for index 53cb7b0b8..54138f72e 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV9.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV9.for @@ -8,6 +8,11 @@ C USE GLOBAL REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QSUMTMP + INTEGER LMIN,LMAX + INTEGER INEGFLG + LMIN = 0 + LMAX = 0 + INEGFLG = 0 IF(.NOT.ALLOCATED(QSUMTMP))THEN ALLOCATE(QSUMTMP(LCM)) @@ -713,34 +718,34 @@ C 6062 FORMAT(' NEG DEPTH AT I,J =',2I4,' HUE,H1UE =',2(2X,E12.4)) 6063 FORMAT(' NEG DEPTH AT I,J =',2I4,' HVS,H1VS =',2(2X,E12.4)) 6064 FORMAT(' NEG DEPTH AT I,J =',2I4,' HVN,H1VN =',2(2X,E12.4)) - 6910 FORMAT(' DRYING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6911 FORMAT(' DRY W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6912 FORMAT(' DRY E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6913 FORMAT(' DRY S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6914 FORMAT(' DRY N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6920 FORMAT(' WETTING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6921 FORMAT(' WET S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6922 FORMAT(' WET W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6923 FORMAT(' WET E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6924 FORMAT(' WET N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6930 FORMAT(' WET BY VOL N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6940 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6941 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUE,HP,H1P =' - & ,3(2X,E12.4)) - 6942 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUW,HP,H1P =' - & ,3(2X,E12.4)) - 6943 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVS,HP,H1P =' - & ,3(2X,E12.4)) - 6944 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVN,HP,H1P =' - & ,3(2X,E12.4)) - 6945 FORMAT(' RESOLVE NEG, N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6950 FORMAT(' RESOLVE, NEG DEP N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) +C6910 FORMAT(' DRYING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6911 FORMAT(' DRY W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6912 FORMAT(' DRY E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6913 FORMAT(' DRY S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6914 FORMAT(' DRY N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6920 FORMAT(' WETTING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6921 FORMAT(' WET S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6922 FORMAT(' WET W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6923 FORMAT(' WET E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6924 FORMAT(' WET N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6930 FORMAT(' WET BY VOL N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6940 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6941 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUE,HP,H1P =' +C & ,3(2X,E12.4)) +C6942 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUW,HP,H1P =' +C & ,3(2X,E12.4)) +C6943 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVS,HP,H1P =' +C & ,3(2X,E12.4)) +C6944 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVN,HP,H1P =' +C & ,3(2X,E12.4)) +C6945 FORMAT(' RESOLVE NEG, N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6950 FORMAT(' RESOLVE, NEG DEP N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) C C ** CALCULATE THE EXTERNAL DIVERGENCE C @@ -791,7 +796,7 @@ C WRITE(6,6628)DIVEXMX,IMAX,JMAX WRITE(6,6629)DIVEXMN,IMIN,JMIN ENDIF - 566 FORMAT(' I=',I5,3X,'J=',I5,3X,'HP=',F12.4) +C 566 FORMAT(' I=',I5,3X,'J=',I5,3X,'HP=',F12.4) 6628 FORMAT(' DIVEXMX=',E13.5,5X,2I10) 6629 FORMAT(' DIVEXMN=',E13.5,5X,2I10) C @@ -808,7 +813,7 @@ C VOLZERD=VOLZERD+VOLADD VETZERD=VETZERD+VOLADD+DT*EVAPSW(L) ENDIF - 5303 FORMAT(2X,F10.4,2X,F10.5,3(2X,E13.5)) +C5303 FORMAT(2X,F10.4,2X,F10.5,3(2X,E13.5)) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV9C.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV9C.for index ee15f0d20..7e94dd0c6 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV9C.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUV9C.for @@ -10,6 +10,13 @@ C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QCHANUT REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QCHANVT REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QSUMTMP + REAL HCHNCOR + INTEGER LMIN,LMAX + INTEGER INEGFLG + LMIN = 0 + LMAX = 0 + INEGFLG = 0 + HCHNCOR = 0.0 IF(.NOT.ALLOCATED(QCHANUT))THEN ALLOCATE(QCHANUT(NCHANM)) @@ -861,9 +868,9 @@ C GOTO 1000 ENDIF ENDIF - 6960 FORMAT(' NCORDRY =', I5) - 6961 FORMAT(' UNSTABLE, NCORDRY =', I5) - 9999 CONTINUE +C6960 FORMAT(' NCORDRY =', I5) +C6961 FORMAT(' UNSTABLE, NCORDRY =', I5) +C9999 CONTINUE C C ** PERFORM FINAL UPDATES OF P,HU, AND HV C @@ -1031,34 +1038,34 @@ C 8001 FORMAT(5I5,3E13.4) 8002 FORMAT(10X,3I5,3E13.4) 8000 FORMAT(' NMD MTYP I J IDRY P H Q') - 6910 FORMAT(' DRYING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6911 FORMAT(' DRY W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6912 FORMAT(' DRY E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6913 FORMAT(' DRY S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6914 FORMAT(' DRY N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6920 FORMAT(' WETTING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6921 FORMAT(' WET S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6922 FORMAT(' WET W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6923 FORMAT(' WET E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) - 6924 FORMAT(' WET N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) - 6930 FORMAT(' WET BY VOL N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6940 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6941 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUE,HP,H1P =' - & ,3(2X,E12.4)) - 6942 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUW,HP,H1P =' - & ,3(2X,E12.4)) - 6943 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVS,HP,H1P =' - & ,3(2X,E12.4)) - 6944 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVN,HP,H1P =' - & ,3(2X,E12.4)) - 6945 FORMAT(' RESOLVE NEG, N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) - 6950 FORMAT(' RESOLVE, NEG DEP N,I,J =',I10,2I6,' HP,H1P,H2P =' - & ,3(2X,E12.4)) +C6910 FORMAT(' DRYING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6911 FORMAT(' DRY W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6912 FORMAT(' DRY E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6913 FORMAT(' DRY S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6914 FORMAT(' DRY N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6920 FORMAT(' WETTING AT N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6921 FORMAT(' WET S FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6922 FORMAT(' WET W FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6923 FORMAT(' WET E FACE N,I,J =',I10,2I6,' HU,H,H1 =',3(2X,E12.4)) +C6924 FORMAT(' WET N FACE N,I,J =',I10,2I6,' HV,H,H1 =',3(2X,E12.4)) +C6930 FORMAT(' WET BY VOL N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6940 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6941 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUE,HP,H1P =' +C & ,3(2X,E12.4)) +C6942 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HUW,HP,H1P =' +C & ,3(2X,E12.4)) +C6943 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVS,HP,H1P =' +C & ,3(2X,E12.4)) +C6944 FORMAT(' RESOLVE, N,I,J =',I10,2I6,' HVN,HP,H1P =' +C & ,3(2X,E12.4)) +C6945 FORMAT(' RESOLVE NEG, N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) +C6950 FORMAT(' RESOLVE, NEG DEP N,I,J =',I10,2I6,' HP,H1P,H2P =' +C & ,3(2X,E12.4)) C C ** CALCULATE THE EXTERNAL DIVERGENCE C @@ -1109,7 +1116,7 @@ C WRITE(6,6628)DIVEXMX,IMAX,JMAX WRITE(6,6629)DIVEXMN,IMIN,JMIN ENDIF - 566 FORMAT(' I=',I5,3X,'J=',I5,3X,'HP=',F12.4) +C 566 FORMAT(' I=',I5,3X,'J=',I5,3X,'HP=',F12.4) 6628 FORMAT(' DIVEXMX=',E13.5,5X,2I10) 6629 FORMAT(' DIVEXMN=',E13.5,5X,2I10) C @@ -1126,7 +1133,7 @@ C VOLZERD=VOLZERD+VOLADD VETZERD=VETZERD+VOLADD+DT*EVAPSW(L) ENDIF - 5303 FORMAT(2X,F10.4,2X,F10.5,3(2X,E13.5)) +C5303 FORMAT(2X,F10.4,2X,F10.5,3(2X,E13.5)) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUVTT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUVTT.for index bce5e88d1..e472d2b2d 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUVTT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALPUVTT.for @@ -39,22 +39,13 @@ C HP(L) = PMCTESTX(5,L) C USE GLOBAL DIMENSION QSUMTMP(LCM) - DIMENSION QCHANUT(NCHANM),QCHANVT(NCHANM) PARAMETER (LLCM=200) REAL, SAVE :: CCW1(LLCM),CCE1(LLCM),CCN1(LLCM),CCS1(LLCM) REAL, SAVE :: CCC1(LLCM) - REAL, SAVE :: UHDY1ET(LLCM) - REAL, SAVE :: VHDX1ET(LLCM) - REAL, SAVE :: H1PT(LLCM) - - REAL*8 DTMP REAL*4 EPSILON - LOGICAL HILOWX(LCM) - LOGICAL HILOWY(LCM) - REAL*4 DELTAHP C C**********************************************************************C C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ1.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ1.for index 42b31348a..947090d05 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ1.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ1.for @@ -465,11 +465,11 @@ C *** DSLLC BEGIN BLOCK ENDDO ENDDO C *** DSLLC END BLOCK - 110 FORMAT(' I J QQ BOT QQ MID QQ SURF', - & ' PROD+ADV 1./DIAGON') - 111 FORMAT(2I5,5E14.5) - 600 FORMAT('N,QX,QN,QLX,QLN,CX,CN=',I5,6E12.4) - 601 FORMAT('NEG QQ I,J,K,QQ=',3I5,E13.5) +C 110 FORMAT(' I J QQ BOT QQ MID QQ SURF', +C & ' PROD+ADV 1./DIAGON') +C 111 FORMAT(2I5,5E14.5) +C 600 FORMAT('N,QX,QN,QLX,QLN,CX,CN=',I5,6E12.4) +C 601 FORMAT('NEG QQ I,J,K,QQ=',3I5,E13.5) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ1OLD.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ1OLD.for index 86008d0e0..cb9a44ea2 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ1OLD.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ1OLD.for @@ -434,11 +434,11 @@ C *** DSLLC BEGIN BLOCK ENDDO ENDDO C *** DSLLC END BLOCK - 110 FORMAT(' I J QQ BOT QQ MID QQ SURF', - & ' PROD+ADV 1./DIAGON') - 111 FORMAT(2I5,5E14.5) - 600 FORMAT('N,QX,QN,QLX,QLN,CX,CN=',I5,6E12.4) - 601 FORMAT('NEG QQ I,J,K,QQ=',3I5,E13.5) +C 110 FORMAT(' I J QQ BOT QQ MID QQ SURF', +C & ' PROD+ADV 1./DIAGON') +C 111 FORMAT(2I5,5E14.5) +C 600 FORMAT('N,QX,QN,QLX,QLN,CX,CN=',I5,6E12.4) +C 601 FORMAT('NEG QQ I,J,K,QQ=',3I5,E13.5) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2T.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2T.for index a8c549e1d..6a0dfebca 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2T.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2T.for @@ -18,12 +18,14 @@ C END IF S2TL=0.0 BSMALL=1.E-12 -! -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) - DO L=LF,LL + DO K=1,KS + DO L=2,LA + QQ2(L,K)=QQ(L,K)+QQ(L,K) + QQL2(L,K)=QQL(L,K)+QQL(L,K) + ENDDO + ENDDO +C + DO L=1,LC UUU(L,KC)=0. VVV(L,KC)=0. FUHU(L,KC)=0. @@ -31,22 +33,6 @@ C FVHU(L,KC)=0. FUHV(L,KC)=0. ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO -C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& WB,LS,UHUW,VHVW) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -! - DO K=1,KS - DO L=LF,LL - QQ2(L,K)=QQ(L,K)+QQ(L,K) - QQL2(L,K)=QQL(L,K)+QQL(L,K) - ENDDO - ENDDO C C ** CALCULATE ADVECTIVE FLUXES BY UPWIND DIFFERENCE WITH TRANSPORT C ** AVERAGED BETWEEN (N) AND (N+1) AND TRANSPORTED FIELD AT (N) OR @@ -56,7 +42,7 @@ C ** FUHQQ=FUHU, FVHQQ=FVHU, FUHQQL=FUHV, FVHQQL=FVHV C IF(IDRYTBP.EQ.0)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA WB=0.5*DXYP(L)*(W2(L,K-1)+W2(L,K)) FWQQ(L,K)=MAX(WB,0.)*QQ(L,K-1) & +MIN(WB,0.)*QQ(L,K) @@ -66,7 +52,7 @@ C ENDDO ELSE DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN WB=0.5*DXYP(L)*(W2(L,K-1)+W2(L,K)) FWQQ(L,K)=MAX(WB,0.)*QQ(L,K-1) @@ -83,7 +69,7 @@ C C IF(IDRYTBP.EQ.0)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA LS=LSC(L) UHUW=0.5*(UHDY2(L,K)+UHDY2(L,K+1)) VHVW=0.5*(VHDX2(L,K)+VHDX2(L,K+1)) @@ -99,7 +85,7 @@ C ENDDO ELSE DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LS=LSC(L) UHUW=0.5*(UHDY2(L,K)+UHDY2(L,K+1)) @@ -121,9 +107,6 @@ C ENDDO ENDDO ENDIF -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO C C ** CALCULATE PRODUCTION, LOAD BOUNDARY CONDITIONS AND SOLVE C ** TRANSPORT EQUATIONS @@ -161,16 +144,10 @@ C ENDIF ENDDO ENDDO -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS,PQQB,PQQU,PQQ,TMPVAL,WVFACT,PQQV,PQQW,FFTMP,PQQL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -! IF(ISWAVE.LE.1.OR.ISWAVE.EQ.3)THEN IF(IDRYTBP.EQ.0)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA LN=LNC(L) UUU(L,K)=QQ(L,K)*H1P(L) & +DELT*(FUHU(L,K)-FUHU(L+1,K)+FVHU(L,K)-FVHU(LN,K) @@ -178,8 +155,17 @@ C VVV(L,K)=QQL(L,K)*H1P(L)*H1P(L) & +DELT*(FUHV(L,K)-FUHV(L+1,K)+FVHV(L,K)-FVHV(LN,K) & +(FWQQL(L,K)-FWQQL(L,K+1))*DZIG(K))*DXYIP(L) + ENDDO + ENDDO + DO K=1,KS + DO L=2,LA UUU(L,K)=MAX(UUU(L,K),0.) VVV(L,K)=MAX(VVV(L,K),0.) + ENDDO + ENDDO + DO K=1,KS + DO L=2,LA + LN=LNC(L) LS=LSC(L) PQQB=AB(L,K)*GP*HP(L)*DZIG(K)*(B(L,K+1)-B(L,K)) PQQU=AV(L,K)*DZIGSD4(K)*(U(L+1,K+1)-U(L+1,K)+U(L,K+1)- @@ -189,11 +175,11 @@ C UUU(L,K)=UUU(L,K)+2.*PQQ PQQL=DELT*H1P(L)*(CTE3*PQQB+CTE1*PQQU) VVV(L,K)=VVV(L,K)+DML(L,K)*PQQL - ENDDO !DO L=LF,LL - ENDDO ! DO K=1,KS + ENDDO + ENDDO ELSE DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LN=LNC(L) UUU(L,K)=QQ(L,K)*H1P(L) @@ -213,7 +199,7 @@ C ENDDO DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) @@ -241,12 +227,12 @@ C WVFACT=1.0 ENDIF DO K=1,KS - DO L=LF,LL + DO L=2,LA TVAR1W(L,K)=WVDTKEM(K)*WVDISP(L,K)+WVDTKEP(K)*WVDISP(L,K+1) ENDDO ENDDO DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) @@ -269,22 +255,12 @@ C ENDDO ENDDO ENDIF -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO C C *** DSLLC END BLOCK C -! -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL, -!$OMP& QQHDH,DMLTMP,DELB,DMLMAX) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) IF(KC.LE.2)THEN IF(IDRYTBP.EQ.0)THEN - DO L=LF,LL + DO L=2,LA CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) CMQTMP=1.-CLQTMP-CUQTMP @@ -301,7 +277,7 @@ C VVV(L,1)=VVV(L,1)*EQL ENDDO ELSE - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) @@ -323,7 +299,7 @@ C ENDIF IF(KC.GT.2)THEN IF(IDRYTBP.EQ.0)THEN - DO L=LF,LL + DO L=2,LA CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) CMQTMP=1.-CLQTMP-CUQTMP @@ -341,7 +317,7 @@ C UUU(L,KS)=UUU(L,KS)-CUQTMP*HP(L)*QQ(L,KC) ENDDO DO K=2,KS - DO L=LF,LL + DO L=2,LA CLQTMP=-DELT*CDZKK(K)*AQ(L,K)*HPI(L) CUQTMP=-DELT*CDZKKP(K)*AQ(L,K+1)*HPI(L) CMQTMP=1.-CLQTMP-CUQTMP @@ -358,13 +334,13 @@ C ENDDO ENDDO DO K=KS-1,1,-1 - DO L=LF,LL + DO L=2,LA UUU(L,K)=UUU(L,K)-CU1(L,K)*UUU(L,K+1) VVV(L,K)=VVV(L,K)-CU2(L,K)*VVV(L,K+1) ENDDO ENDDO ELSE - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) @@ -384,7 +360,7 @@ C ENDIF ENDDO DO K=2,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN CLQTMP=-DELT*CDZKK(K)*AQ(L,K)*HPI(L) CUQTMP=-DELT*CDZKKP(K)*AQ(L,K+1)*HPI(L) @@ -403,7 +379,7 @@ C ENDDO ENDDO DO K=KS-1,1,-1 - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN UUU(L,K)=UUU(L,K)-CU1(L,K)*UUU(L,K+1) VVV(L,K)=VVV(L,K)-CU2(L,K)*VVV(L,K+1) @@ -414,7 +390,7 @@ C ENDIF IF(IDRYTBP.EQ.0)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA QQ1(L,K)=QQ(L,K) QQHDH=UUU(L,K)*HPI(L) QQ(L,K)=MAX(QQHDH,QQMIN) @@ -425,7 +401,7 @@ C ** ORIGINAL FORM MODIFED FOR DIMENSIONAL LENGHT SCALE TRANSPORT C IF(ISTOPT(0).EQ.1)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA QQL1(L,K)=QQL(L,K) QQHDH=VVV(L,K)*HPI(L)*HPI(L) QQL(L,K)=MAX(QQHDH,QQLMIN) @@ -446,7 +422,7 @@ C ** BUCHARD'S MODIFED CLOSURE FOR DIMENSIONAL LENGHT SCALE TRANSPORT C IF(ISTOPT(0).EQ.2)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA QQL1(L,K)=QQL(L,K) QQHDH=VVV(L,K)*HPI(L)*HPI(L) QQL(L,K)=MAX(QQHDH,QQLMIN) @@ -457,7 +433,7 @@ C ENDIF ELSE DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN QQ1(L,K)=QQ(L,K) QQHDH=UUU(L,K)*HPI(L) @@ -470,7 +446,7 @@ C ** ORIGINAL FORM MODIFED FOR DIMENSIONAL LENGHT SCALE TRANSPORT C IF(ISTOPT(0).EQ.1)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN QQL1(L,K)=QQL(L,K) QQHDH=VVV(L,K)*HPI(L)*HPI(L) @@ -493,7 +469,7 @@ C ** BUCHARD'S MODIFED CLOSURE FOR DIMENSIONAL LENGHT SCALE TRANSPORT C IF(ISTOPT(0).EQ.2)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN QQL1(L,K)=QQL(L,K) QQHDH=VVV(L,K)*HPI(L)*HPI(L) @@ -505,9 +481,6 @@ C ENDDO ENDIF ENDIF -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO C C QQMXSV=-1.E+12 C QQMNSV=1.E+12 @@ -549,25 +522,17 @@ C ENDDO ENDDO C *** DSLLC BEGIN BLOCK -! -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) DO K=1,KS - DO L=LF,LL + DO L=1,LC QQSQR(L,K)=SQRT(QQ(L,K)) ! *** DSLLC ENDDO ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO C *** DSLLC END BLOCK - 110 FORMAT(' I J QQ BOT QQ MID QQ SURF', - & ' PROD+ADV 1./DIAGON') - 111 FORMAT(2I5,5E14.5) - 600 FORMAT('N,QX,QN,QLX,QLN,CX,CN=',I5,6E12.4) - 601 FORMAT('NEG QQ I,J,K,QQ=',3I5,E13.5) +C 110 FORMAT(' I J QQ BOT QQ MID QQ SURF', +C & ' PROD+ADV 1./DIAGON') +C 111 FORMAT(2I5,5E14.5) +C 600 FORMAT('N,QX,QN,QLX,QLN,CX,CN=',I5,6E12.4) +C 601 FORMAT('NEG QQ I,J,K,QQ=',3I5,E13.5) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2TOLD.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2TOLD.for index 506e9a4de..11b0dd6fa 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2TOLD.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2TOLD.for @@ -22,12 +22,14 @@ C S2TL=0.0 BSMALL=1.E-12 C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - DO L=LF,LL + DO K=1,KS + DO L=2,LA + QQ2(L,K)=QQ(L,K)+QQ(L,K) + QQL2(L,K)=QQL(L,K)+QQL(L,K) + ENDDO + ENDDO +C + DO L=1,LC UUU(L,KC)=0. VVV(L,KC)=0. FUHU(L,KC)=0. @@ -35,21 +37,6 @@ c FVHU(L,KC)=0. FUHV(L,KC)=0. ENDDO -c - enddo -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& WB,LS,UHUW,VHVW) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c -C - DO K=1,KS - DO L=LF,LL - QQ2(L,K)=QQ(L,K)+QQ(L,K) - QQL2(L,K)=QQL(L,K)+QQL(L,K) - ENDDO - ENDDO C C ** CALCULATE ADVECTIVE FLUXES BY UPWIND DIFFERENCE WITH TRANSPORT C ** AVERAGED BETWEEN (N) AND (N+1) AND TRANSPORTED FIELD AT (N) OR @@ -59,7 +46,7 @@ C ** FUHQQ=FUHU, FVHQQ=FVHU, FUHQQL=FUHV, FVHQQL=FVHV C IF(IDRYTBP.EQ.0)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA WB=0.5*DXYP(L)*(W2(L,K-1)+W2(L,K)) FWQQ(L,K)=MAX(WB,0.)*QQ(L,K-1) & +MIN(WB,0.)*QQ(L,K) @@ -69,7 +56,7 @@ C ENDDO ELSE DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN WB=0.5*DXYP(L)*(W2(L,K-1)+W2(L,K)) FWQQ(L,K)=MAX(WB,0.)*QQ(L,K-1) @@ -91,7 +78,7 @@ C WB=0.25*DXYP(L)*(W2(L,K-1)+W2(L,K)) C IF(IDRYTBP.EQ.0)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA LS=LSC(L) UHUW=0.5*(UHDY2(L,K)+UHDY2(L,K+1)) VHVW=0.5*(VHDX2(L,K)+VHDX2(L,K+1)) @@ -107,7 +94,7 @@ C ENDDO ELSE DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LS=LSC(L) UHUW=0.5*(UHDY2(L,K)+UHDY2(L,K+1)) @@ -129,8 +116,6 @@ C ENDDO ENDDO ENDIF -c - enddo C C ELSE C UHUW=0.25*(UHDY2(L,K)+UHDY2(L,K+1)) @@ -174,16 +159,10 @@ C ENDIF ENDDO ENDDO -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS,PQQB,PQQU,PQQ,TMPVAL,WVFACT,PQQV,PQQW,FFTMP,PQQL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(ISWAVE.LE.1.OR.ISWAVE.EQ.3)THEN IF(IDRYTBP.EQ.0)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA LN=LNC(L) UUU(L,K)=QQ(L,K)*H1P(L) & +DELT*(FUHU(L,K)-FUHU(L+1,K)+FVHU(L,K)-FVHU(LN,K) @@ -191,8 +170,17 @@ c VVV(L,K)=QQL(L,K)*H1P(L) & +DELT*(FUHV(L,K)-FUHV(L+1,K)+FVHV(L,K)-FVHV(LN,K) & +(FWQQL(L,K)-FWQQL(L,K+1))*DZIG(K))*DXYIP(L) + ENDDO + ENDDO + DO K=1,KS + DO L=2,LA UUU(L,K)=MAX(UUU(L,K),0.) VVV(L,K)=MAX(VVV(L,K),0.) + ENDDO + ENDDO + DO K=1,KS + DO L=2,LA + LN=LNC(L) LS=LSC(L) PQQB=AB(L,K)*GP*HP(L)*DZIG(K)*(B(L,K+1)-B(L,K)) PQQU=AV(L,K)*DZIGSD4(K)*(U(L+1,K+1)-U(L+1,K)+U(L,K+1)- @@ -205,7 +193,7 @@ c ENDDO ELSE DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LN=LNC(L) UUU(L,K)=QQ(L,K)*H1P(L) @@ -225,7 +213,7 @@ c ENDDO C DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LN=LNC(L) LS=LSC(L) @@ -255,12 +243,12 @@ C WVFACT=1.0 ENDIF DO K=1,KS - DO L=LF,LL + DO L=2,LA TVAR1W(L,K)=WVDTKEM(K)*WVDISP(L,K)+WVDTKEP(K)*WVDISP(L,K+1) ENDDO ENDDO DO K=1,KS - DO L=LF,LL + DO L=2,LA LN=LNC(L) LS=LSC(L) PQQB=AB(L,K)*GP*HP(L)*DZIG(K)*(B(L,K+1)-B(L,K)) @@ -281,8 +269,6 @@ C ENDDO ENDDO ENDIF -c - enddo C C *** DSLLC END BLOCK C @@ -325,16 +311,9 @@ C ENDDO ENDIF ENDIF -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL, -!$OMP& QQHDH,DMLTMP,DELB,DMLMAX) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(KC.GT.2)THEN IF(IDRYTBP.EQ.0)THEN - DO L=LF,LL + DO L=2,LA CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) CMQTMP=1.-CLQTMP-CUQTMP @@ -352,7 +331,7 @@ c UUU(L,KS)=UUU(L,KS)-CUQTMP*HP(L)*QQ(L,KC) ENDDO DO K=2,KS - DO L=LF,LL + DO L=2,LA CLQTMP=-DELT*CDZKK(K)*AQ(L,K)*HPI(L) CUQTMP=-DELT*CDZKKP(K)*AQ(L,K+1)*HPI(L) CMQTMP=1.-CLQTMP-CUQTMP @@ -372,13 +351,13 @@ C ENDDO ENDDO DO K=KS-1,1,-1 - DO L=LF,LL + DO L=2,LA UUU(L,K)=UUU(L,K)-CU1(L,K)*UUU(L,K+1) VVV(L,K)=VVV(L,K)-CU2(L,K)*VVV(L,K+1) ENDDO ENDDO ELSE - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) @@ -398,7 +377,7 @@ C ENDIF ENDDO DO K=2,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN CLQTMP=-DELT*CDZKK(K)*AQ(L,K)*HPI(L) CUQTMP=-DELT*CDZKKP(K)*AQ(L,K+1)*HPI(L) @@ -420,7 +399,7 @@ C ENDDO ENDDO DO K=KS-1,1,-1 - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN UUU(L,K)=UUU(L,K)-CU1(L,K)*UUU(L,K+1) VVV(L,K)=VVV(L,K)-CU2(L,K)*VVV(L,K+1) @@ -431,14 +410,14 @@ C ENDIF IF(IDRYTBP.EQ.0)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA QQ1(L,K)=QQ(L,K) QQHDH=UUU(L,K)*HPI(L) QQ(L,K)=MAX(QQHDH,QQMIN) -c ENDDO -c ENDDO -c DO K=1,KS -c DO L=LF,LL + ENDDO + ENDDO + DO K=1,KS + DO L=2,LA QQL1(L,K)=QQL(L,K) QQHDH=VVV(L,K)*HPI(L) QQL(L,K)=MAX(QQHDH,QQLMIN) @@ -455,7 +434,7 @@ c DO L=LF,LL ENDDO ELSE DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN QQ1(L,K)=QQ(L,K) QQHDH=UUU(L,K)*HPI(L) @@ -464,7 +443,7 @@ c DO L=LF,LL ENDDO ENDDO DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN QQL1(L,K)=QQL(L,K) QQHDH=VVV(L,K)*HPI(L) @@ -482,8 +461,6 @@ c DO L=LF,LL ENDDO ENDDO ENDIF -c - enddo C C QQMXSV=-1.E+12 C QQMNSV=1.E+12 @@ -498,18 +475,24 @@ C QQL(L,K)=QQL(LN,K) DML(L,K)=DML(LN,K) ENDDO + ENDDO + DO K=1,KS DO LL=1,NCBW L=LCBW(LL) QQ(L,K)=QQ(L+1,K) QQL(L,K)=QQL(L+1,K) DML(L,K)=DML(L+1,K) ENDDO + ENDDO + DO K=1,KS DO LL=1,NCBE L=LCBE(LL) QQ(L,K)=QQ(L-1,K) QQL(L,K)=QQL(L-1,K) DML(L,K)=DML(L-1,K) ENDDO + ENDDO + DO K=1,KS DO LL=1,NCBN L=LCBN(LL) LS=LSC(L) @@ -519,24 +502,17 @@ C ENDDO ENDDO C *** DSLLC BEGIN BLOCK -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c DO K=1,KS - DO L=LF,LL + DO L=1,LC QQSQR(L,K)=SQRT(QQ(L,K)) ! *** DSLLC ENDDO ENDDO -c - enddo C *** DSLLC END BLOCK - 110 FORMAT(' I J QQ BOT QQ MID QQ SURF', - & ' PROD+ADV 1./DIAGON') - 111 FORMAT(2I5,5E14.5) - 600 FORMAT('N,QX,QN,QLX,QLN,CX,CN=',I5,6E12.4) - 601 FORMAT('NEG QQ I,J,K,QQ=',3I5,E13.5) +C 110 FORMAT(' I J QQ BOT QQ MID QQ SURF', +C & ' PROD+ADV 1./DIAGON') +C 111 FORMAT(2I5,5E14.5) +C 600 FORMAT('N,QX,QN,QLX,QLN,CX,CN=',I5,6E12.4) +C 601 FORMAT('NEG QQ I,J,K,QQ=',3I5,E13.5) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2TOLD_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2TOLD_mpi.for new file mode 100644 index 000000000..45b5e0e34 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2TOLD_mpi.for @@ -0,0 +1,691 @@ + SUBROUTINE CALQQ2TOLD_mpi (ISTL_) +C +C CHANGE RECORD +C FIXED DYNAMIC TIME STEPPING +C 03/18/2004 PAUL CRAIG +C MADE CHANGES SO DML AND QQL ARE DIMENSIONALLY CORRECT +C ** SUBROUTINE CALQQ CALCULATES THE TURBULENT INTENSITY SQUARED AT +C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF +C ** TIME LEVELS INVOLVED +C + USE GLOBAL + USE MPI +C + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + DELTD2=0.5*DT + DELTI=1./DELT + ELSE + DELT=DTDYN + DELTD2=0.5*DTDYN + DELTI=1./DELT + END IF + S2TL=0.0 + BSMALL=1.E-12 +C + S1TIME=MPI_TIC() + DO K=0,KCM + CALL broadcast_boundary(QQ(:,K),ic) + CALL broadcast_boundary(QQL(:,K),ic) + ENDDO + MPI_WTIMES(513)=MPI_WTIMES(513)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + QQ2(L,K)=QQ(L,K)+QQ(L,K) + QQL2(L,K)=QQL(L,K)+QQL(L,K) + ENDDO + ENDDO + MPI_WTIMES(501)=MPI_WTIMES(501)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + UUU(L,KC)=0. + VVV(L,KC)=0. + FUHU(L,KC)=0. + FUHV(L,KC)=0. + FVHU(L,KC)=0. + FUHV(L,KC)=0. + ENDDO + MPI_WTIMES(502)=MPI_WTIMES(502)+MPI_TOC(S1TIME) +C +C ** CALCULATE ADVECTIVE FLUXES BY UPWIND DIFFERENCE WITH TRANSPORT +C ** AVERAGED BETWEEN (N) AND (N+1) AND TRANSPORTED FIELD AT (N) OR +C ** TRANSPORT BETWEEN (N-1) AND (N+1) AND TRANSPORTED FIELD AT (N-1) +C ** FOR ISTL EQUAL TO 2 AND 3 RESPECTIVELY +C ** FUHQQ=FUHU, FVHQQ=FVHU, FUHQQL=FUHV, FVHQQL=FVHV +C + S1TIME=MPI_TIC() + IF(IDRYTBP.EQ.0)THEN + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(WB) + DO L=LMPI2,LMPILA + WB=0.5*DXYP(L)*(W2(L,K-1)+W2(L,K)) + FWQQ(L,K)=MAX(WB,0.)*QQ(L,K-1) + & +MIN(WB,0.)*QQ(L,K) + FWQQL(L,K)=MAX(WB,0.)*QQL(L,K-1) + & +MIN(WB,0.)*QQL(L,K) + ENDDO + ENDDO + ELSE + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(WB) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + WB=0.5*DXYP(L)*(W2(L,K-1)+W2(L,K)) + FWQQ(L,K)=MAX(WB,0.)*QQ(L,K-1) + & +MIN(WB,0.)*QQ(L,K) + FWQQL(L,K)=MAX(WB,0.)*QQL(L,K-1) + & +MIN(WB,0.)*QQL(L,K) + ELSE + FWQQ(L,K)=0. + FWQQL(L,K)=0. + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(503)=MPI_WTIMES(503)+MPI_TOC(S1TIME) +C +C ELSE +C WB=0.25*DXYP(L)*(W2(L,K-1)+W2(L,K)) +C ELSE +C WB=0.25*DXYP(L)*(W2(L,K-1)+W2(L,K)) +C + S1TIME=MPI_TIC() + IF(IDRYTBP.EQ.0)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LS,UHUW,VHVW) + DO L=LMPI2,LMPILA + LS=LSC(L) + UHUW=0.5*(UHDY2(L,K)+UHDY2(L,K+1)) + VHVW=0.5*(VHDX2(L,K)+VHDX2(L,K+1)) + FUHU(L,K)=MAX(UHUW,0.)*QQ(L-1,K) + & +MIN(UHUW,0.)*QQ(L,K) + FVHU(L,K)=MAX(VHVW,0.)*QQ(LS,K) + & +MIN(VHVW,0.)*QQ(L,K) + FUHV(L,K)=MAX(UHUW,0.)*QQL(L-1,K) + & +MIN(UHUW,0.)*QQL(L,K) + FVHV(L,K)=MAX(VHVW,0.)*QQL(LS,K) + & +MIN(VHVW,0.)*QQL(L,K) + ENDDO + ENDDO + ELSE + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LS,UHUW,VHVW) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LS=LSC(L) + UHUW=0.5*(UHDY2(L,K)+UHDY2(L,K+1)) + VHVW=0.5*(VHDX2(L,K)+VHDX2(L,K+1)) + FUHU(L,K)=MAX(UHUW,0.)*QQ(L-1,K) + & +MIN(UHUW,0.)*QQ(L,K) + FVHU(L,K)=MAX(VHVW,0.)*QQ(LS,K) + & +MIN(VHVW,0.)*QQ(L,K) + FUHV(L,K)=MAX(UHUW,0.)*QQL(L-1,K) + & +MIN(UHUW,0.)*QQL(L,K) + FVHV(L,K)=MAX(VHVW,0.)*QQL(LS,K) + & +MIN(VHVW,0.)*QQL(L,K) + ELSE + FUHU(L,K)=0. + FUHV(L,K)=0. + FVHU(L,K)=0. + FUHV(L,K)=0. + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(504)=MPI_WTIMES(504)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(FUHU,ic) + CALL broadcast_boundary_array(FVHU,ic) + CALL broadcast_boundary_array(FUHV,ic) + CALL broadcast_boundary_array(FVHV,ic) + MPI_WTIMES(514)=MPI_WTIMES(514)+MPI_TOC(S1TIME) +C +C ELSE +C UHUW=0.25*(UHDY2(L,K)+UHDY2(L,K+1)) +C VHVW=0.25*(VHDX2(L,K)+VHDX2(L,K+1)) +C ELSE +C UHUW=0.25*(UHDY2(L,K)+UHDY2(L,K+1)) +C VHVW=0.25*(VHDX2(L,K)+VHDX2(L,K+1)) +C ** CALCULATE PRODUCTION, LOAD BOUNDARY CONDITIONS AND SOLVE +C ** TRANSPORT EQUATIONS +C ** FUHQQ=FUHU, FVHQQ=FVHU, FUHQQL=FUHV, FVHQQL=FVHV +C ** CU1=CUQ, CU2=CUQL, UUU=QQH, VVV=QQLH +C + S1TIME=MPI_TIC() + DO K=1,KC + DO LL=1,NCBS + L=LCBS(LL) + LN=LNC(L) + IF(FVHU(LN,K).GT.0)THEN + FVHU(LN,K)=0.0 + FVHV(LN,K)=0.0 + ENDIF + ENDDO + DO LL=1,NCBW + L=LCBW(LL) + IF(FUHU(L+1,K).GT.0)THEN + FUHU(L+1,K)=0.0 + FUHV(L+1,K)=0.0 + ENDIF + ENDDO + DO LL=1,NCBE + L=LCBE(LL) + IF(FUHU(L,K).LT.0.)THEN + FUHU(L,K)=0.0 + FUHV(L,K)=0.0 + ENDIF + ENDDO + DO LL=1,NCBN + L=LCBN(LL) + IF(FVHU(L,K).LT.0.)THEN + FVHU(L,K)=0.0 + FVHV(L,K)=0.0 + ENDIF + ENDDO + ENDDO + MPI_WTIMES(505)=MPI_WTIMES(505)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(ISWAVE.LE.1.OR.ISWAVE.EQ.3)THEN + IF(IDRYTBP.EQ.0)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + LN=LNC(L) + UUU(L,K)=QQ(L,K)*H1P(L) + & +DELT*(FUHU(L,K)-FUHU(L+1,K)+FVHU(L,K)-FVHU(LN,K) + & +(FWQQ(L,K)-FWQQ(L,K+1))*DZIG(K))*DXYIP(L) + VVV(L,K)=QQL(L,K)*H1P(L) + & +DELT*(FUHV(L,K)-FUHV(L+1,K)+FVHV(L,K)-FVHV(LN,K) + & +(FWQQL(L,K)-FWQQL(L,K+1))*DZIG(K))*DXYIP(L) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UUU(L,K)=MAX(UUU(L,K),0.) + VVV(L,K)=MAX(VVV(L,K),0.) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN,LS,PQQB,PQQU,PQQ) + DO L=LMPI2,LMPILA + LN=LNC(L) + LS=LSC(L) + PQQB=AB(L,K)*GP*HP(L)*DZIG(K)*(B(L,K+1)-B(L,K)) + PQQU=AV(L,K)*DZIGSD4(K)*(U(L+1,K+1)-U(L+1,K)+U(L,K+1)- + & U(L,K))**2+AV(L,K)*DZIGSD4(K)*(V(LN,K+1)-V(LN,K)+V(L,K+1)- + & V(L,K))**2 + PQQ=DELT*(PQQB+PQQU) + UUU(L,K)=UUU(L,K)+2.*PQQ + VVV(L,K)=VVV(L,K)+CTE1*DML(L,K)*PQQ + ENDDO + ENDDO + ELSE + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LN=LNC(L) + UUU(L,K)=QQ(L,K)*H1P(L) + & +DELT*(FUHU(L,K)-FUHU(L+1,K)+FVHU(L,K)-FVHU(LN,K) + & +(FWQQ(L,K)-FWQQ(L,K+1))*DZIG(K))*DXYIP(L) + VVV(L,K)=QQL(L,K)*H1P(L) + & +DELT*(FUHV(L,K)-FUHV(L+1,K)+FVHV(L,K)-FVHV(LN,K) + & +(FWQQL(L,K)-FWQQL(L,K+1))*DZIG(K))*DXYIP(L) + + UUU(L,K)=MAX(UUU(L,K),0.) + VVV(L,K)=MAX(VVV(L,K),0.) + ELSE + UUU(L,K)=0.0 + VVV(L,K)=0.0 + ENDIF + ENDDO + ENDDO + IF(PRINT_SUM)THEN + call collect_in_zero_array(UUU) + call collect_in_zero_array(VVV) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'U3UU = ', sum(abs(dble(UUU))) + PRINT*, n,'V3VV = ', sum(abs(dble(VVV))) + PRINT*, N,'TEMO = ', TEMO + ENDIF + ENDIF +C + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN,LS,PQQB,PQQU,PQQ) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LN=LNC(L) + LS=LSC(L) + PQQB=AB(L,K)*GP*HP(L)*DZIG(K)*(B(L,K+1)-B(L,K)) + PQQU=AV(L,K)*DZIGSD4(K)*(U(L+1,K+1)-U(L+1,K)+U(L,K+1) + & -U(L,K))**2+AV(L,K)*DZIGSD4(K)*(V(LN,K+1)-V(LN,K)+V(L,K+1)- + & V(L,K))**2 + PQQ=DELT*(PQQB+PQQU) + UUU(L,K)=UUU(L,K)+2.*PQQ + VVV(L,K)=VVV(L,K)+CTE1*DML(L,K)*PQQ + ENDIF + ENDDO + ENDDO + IF(PRINT_SUM)THEN + call collect_in_zero_array(UUU) + call collect_in_zero_array(VVV) + call collect_in_zero_array(AB) + call collect_in_zero_array(AV) + call collect_in_zero_array(B) + call collect_in_zero_array(U) + call collect_in_zero_array(V) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'U4UU = ', sum(abs(dble(UUU))) + PRINT*, n,'V4VV = ', sum(abs(dble(VVV))) + PRINT*, n,'AB4 = ', sum(abs(dble(AB))) + PRINT*, n,'AV4 = ', sum(abs(dble(AV))) + PRINT*, n,'B4 = ', sum(abs(dble(B))) + PRINT*, n,'U4 = ', sum(abs(dble(U))) + PRINT*, n,'V4 = ', sum(abs(dble(V))) + ENDIF + ENDIF + ENDIF +C +C ELSE +C + ENDIF + MPI_WTIMES(506)=MPI_WTIMES(506)+MPI_TOC(S1TIME) +C +C *** DSLLC BEGIN BLOCK +C + IF(ISWAVE.EQ.2)THEN + IF(N.LT.NTSWV)THEN + TMPVAL=FLOAT(N)/FLOAT(NTSWV) + WVFACT=0.5-0.5*COS(PI*TMPVAL) + ELSE + WVFACT=1.0 + ENDIF + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR1W(L,K)=WVDTKEM(K)*WVDISP(L,K)+WVDTKEP(K)*WVDISP(L,K+1) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN,LS,PQQB,PQQU,PQQV,PQQW,PQQ,PQQL,FFTMP) + DO L=LMPI2,LMPILA + LN=LNC(L) + LS=LSC(L) + PQQB=AB(L,K)*GP*HP(L)*DZIG(K)*(B(L,K+1)-B(L,K)) + PQQU=AV(L,K)*DZIGSD4(K)* + & (U(L+1,K+1)-U(L+1,K)+U(L,K+1)-U(L,K))**2 + PQQV=AV(L,K)*DZIGSD4(K)* + & (V(LN,K+1)-V(LN,K)+V(L,K+1)-V(L,K))**2 + PQQW= WVFACT*TVAR1W(L,K) + PQQ=DELT*(PQQU+PQQV+PQQB+PQQW) + FFTMP=MAX(FUHU(L,K)-FUHU(L+1,K)+FVHU(L,K)-FVHU(LN,K) + + & (FWQQ(L,K)-FWQQ(L,K+1))*DZIG(K),0.) + UUU(L,K)=QQ(L,K)*H1P(L)+DELT*FFTMP*DXYIP(L) + 2.*PQQ + PQQL=DELT*(CTE3*PQQB+CTE1*(PQQU+PQQV+PQQW)) + FFTMP=MAX(FUHV(L,K)-FUHV(L+1,K)+FVHV(L,K)-FVHV(LN,K) + + & (FWQQL(L,K)-FWQQL(L,K+1))*DZIG(K),0.) + VVV(L,K)=QQL(L,K)*H1P(L)+DELT*FFTMP*DXYIP(L) + + & DML(L,K)*PQQL + ENDDO + ENDDO + ENDIF +C +C *** DSLLC END BLOCK +C + S1TIME=MPI_TIC() + IF(KC.LE.2)THEN + IF(IDRYTBP.EQ.0)THEN +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) + CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)))*(1. + & +CTE2*DML(L,1)*DML(L,1)*FPROX(1)) + EQ=1./CMQTMP + EQL=1./CMQLTMP + CU1(L,1)=CUQTMP*EQ + CU2(L,1)=CUQTMP*EQL + UUU(L,1)=(UUU(L,1)-CLQTMP*HP(L)*QQ(L,0) + & -CUQTMP*HP(L)*QQ(L,KC))*EQ + VVV(L,1)=VVV(L,1)*EQL + ENDDO + ELSE +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) + CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)))*(1. + & +CTE2*DML(L,1)*DML(L,1)*FPROX(1)) + EQ=1./CMQTMP + EQL=1./CMQLTMP + CU1(L,1)=CUQTMP*EQ + CU2(L,1)=CUQTMP*EQL + UUU(L,1)=(UUU(L,1)-CLQTMP*HP(L)*QQ(L,0) + & -CUQTMP*HP(L)*QQ(L,KC))*EQ + VVV(L,1)=VVV(L,1)*EQL + ENDIF + ENDDO + ENDIF + ENDIF + MPI_WTIMES(508)=MPI_WTIMES(508)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(KC.GT.2)THEN + IF(IDRYTBP.EQ.0)THEN +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) + CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)))*(1. + & +CTE2*DML(L,1)*DML(L,1)*FPROX(1)) + EQ=1./CMQTMP + EQL=1./CMQLTMP + CU1(L,1)=CUQTMP*EQ + CU2(L,1)=CUQTMP*EQL + UUU(L,1)=(UUU(L,1)-CLQTMP*HP(L)*QQ(L,0))*EQ + VVV(L,1)=VVV(L,1)*EQL + CUQTMP=-DELT*CDZKKP(KS)*AQ(L,KC)*HPI(L) + UUU(L,KS)=UUU(L,KS)-CUQTMP*HP(L)*QQ(L,KC) + ENDDO + DO K=2,KS +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + CLQTMP=-DELT*CDZKK(K)*AQ(L,K)*HPI(L) + CUQTMP=-DELT*CDZKKP(K)*AQ(L,K+1)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,K)/(CTURBB1(L,K)*DML(L,K)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,K)/(CTURBB1(L,K)*DML(L,K)*HP(L)))*(1. + & +CTE2*DML(L,K)*DML(L,K)*FPROX(K)) + EQ=1./(CMQTMP-CLQTMP*CU1(L,K-1)) + EQL=1./(CMQLTMP-CLQTMP*CU2(L,K-1)) + CU1(L,K)=CUQTMP*EQ + CU2(L,K)=CUQTMP*EQL +C +C IF(EQ.0) PAUSE +C + UUU(L,K)=(UUU(L,K)-CLQTMP*UUU(L,K-1))*EQ + VVV(L,K)=(VVV(L,K)-CLQTMP*VVV(L,K-1))*EQL + ENDDO + ENDDO + DO K=KS-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UUU(L,K)=UUU(L,K)-CU1(L,K)*UUU(L,K+1) + VVV(L,K)=VVV(L,K)-CU2(L,K)*VVV(L,K+1) + ENDDO + ENDDO + IF(PRINT_SUM)THEN + call collect_in_zero_array(UUU) + call collect_in_zero_array(VVV) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'UUU = ', sum(abs(dble(UUU))) + PRINT*, n,'VVV = ', sum(abs(dble(VVV))) + ENDIF + ENDIF + ELSE +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) + CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)))*(1. + & +CTE2*DML(L,1)*DML(L,1)*FPROX(1)) + EQ=1./CMQTMP + EQL=1./CMQLTMP + CU1(L,1)=CUQTMP*EQ + CU2(L,1)=CUQTMP*EQL + UUU(L,1)=(UUU(L,1)-CLQTMP*HP(L)*QQ(L,0))*EQ + VVV(L,1)=VVV(L,1)*EQL + CUQTMP=-DELT*CDZKKP(KS)*AQ(L,KC)*HPI(L) + UUU(L,KS)=UUU(L,KS)-CUQTMP*HP(L)*QQ(L,KC) + ENDIF + ENDDO + DO K=2,KS +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + CLQTMP=-DELT*CDZKK(K)*AQ(L,K)*HPI(L) + CUQTMP=-DELT*CDZKKP(K)*AQ(L,K+1)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,K)/(CTURBB1(L,K)*DML(L,K)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,K)/(CTURBB1(L,K)*DML(L,K)*HP(L)) + & )*(1.+CTE2*DML(L,K)*DML(L,K)*FPROX(K)) + EQ=1./(CMQTMP-CLQTMP*CU1(L,K-1)) + EQL=1./(CMQLTMP-CLQTMP*CU2(L,K-1)) + CU1(L,K)=CUQTMP*EQ + CU2(L,K)=CUQTMP*EQL +C +C IF(EQ.0) PAUSE +C + UUU(L,K)=(UUU(L,K)-CLQTMP*UUU(L,K-1))*EQ + VVV(L,K)=(VVV(L,K)-CLQTMP*VVV(L,K-1))*EQL + ENDIF + ENDDO + ENDDO + DO K=KS-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + UUU(L,K)=UUU(L,K)-CU1(L,K)*UUU(L,K+1) + VVV(L,K)=VVV(L,K)-CU2(L,K)*VVV(L,K+1) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + MPI_WTIMES(509)=MPI_WTIMES(509)+MPI_TOC(S1TIME) +C + IF(PRINT_SUM)THEN + call collect_in_zero_array(UUU) + call collect_in_zero_array(VVV) + call collect_in_zero_array(FUHU) + call collect_in_zero_array(FVHU) + call collect_in_zero_array(FUHV) + call collect_in_zero_array(FVHV) + call collect_in_zero_array(CU1) + call collect_in_zero_array(CU2) + call collect_in_zero_array(AQ) + call collect_in_zero(HPI) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'UUU = ', sum(abs(dble(UUU))) + PRINT*, n,'VVV = ', sum(abs(dble(VVV))) + PRINT*, n,'FUHU = ', sum(abs(dble(FUHU))) + PRINT*, n,'FVHU = ', sum(abs(dble(FVHU))) + PRINT*, n,'FUHV = ', sum(abs(dble(FUHV))) + PRINT*, n,'FVHV = ', sum(abs(dble(FVHV))) + PRINT*, n,'CU1 = ', sum(abs(dble(CU1))) + PRINT*, n,'CU2 = ', sum(abs(dble(CU2))) + PRINT*, n,'AQ = ', sum(abs(dble(AQ))) + PRINT*, n,'HPI = ', sum(abs(dble(HPI))) + ENDIF + DO K=0,KCM + call collect_in_zero(QQ(:,K)) + call collect_in_zero(QQL(:,K)) + call collect_in_zero(DML(:,K)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'1QQ = ', sum(abs(dble(QQ))) + PRINT*, n,'1QQL = ', sum(abs(dble(QQL))) + PRINT*, n,'1QQL = ', sum(abs(dble(DML))) + ENDIF + ENDIF +C + S1TIME=MPI_TIC() + IF(IDRYTBP.EQ.0)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(QQHDH) + DO L=LMPI2,LMPILA + QQ1(L,K)=QQ(L,K) + QQHDH=UUU(L,K)*HPI(L) + QQ(L,K)=MAX(QQHDH,QQMIN) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(QQHDH,DMLTMP,DELB,DMLMAX) + DO L=LMPI2,LMPILA + QQL1(L,K)=QQL(L,K) + QQHDH=VVV(L,K)*HPI(L) + QQL(L,K)=MAX(QQHDH,QQLMIN) + DMLTMP=QQL(L,K)/QQ(L,K) + DMLTMP=MAX(DMLTMP,DMLMIN) + DELB=B(L,K)-B(L,K+1) + IF(DELB.GT.BSMALL.AND.ISTOPT(0).EQ.0)THEN + DMLMAX=0.53*SQRT(QQ(L,K)/(G*HP(L)*DZIG(K)*DELB)) + DML(L,K)=MIN(DMLMAX,DMLTMP) + ELSE + DML(L,K)=DMLTMP + ENDIF + ENDDO + ENDDO + ELSE + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(QQHDH) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQ1(L,K)=QQ(L,K) + QQHDH=UUU(L,K)*HPI(L) + QQ(L,K)=MAX(QQHDH,QQMIN) + ENDIF + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(QQHDH,DMLTMP,DELB,DMLMAX) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQL1(L,K)=QQL(L,K) + QQHDH=VVV(L,K)*HPI(L) + QQL(L,K)=MAX(QQHDH,QQLMIN) + DMLTMP=QQL(L,K)/QQ(L,K) + DMLTMP=MAX(DMLTMP,DMLMIN) + DELB=B(L,K)-B(L,K+1) + IF(DELB.GT.BSMALL.AND.ISTOPT(0).EQ.0)THEN + DMLMAX=0.53*SQRT(QQ(L,K)/(G*HP(L)*DZIG(K)*DELB)) + DML(L,K)=MIN(DMLMAX,DMLTMP) + ELSE + DML(L,K)=DMLTMP + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +C + MPI_WTIMES(510)=MPI_WTIMES(510)+MPI_TOC(S1TIME) +C + IF(PRINT_SUM)THEN + DO K=0,KCM + call collect_in_zero(QQ(:,K)) + call collect_in_zero(QQL(:,K)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'2QQ = ', sum(abs(dble(QQ))) + PRINT*, n,'2QQL = ', sum(abs(dble(QQL))) + ENDIF + ENDIF +C +C QQMXSV=-1.E+12 +C QQMNSV=1.E+12 +C QQLMXSV=-1.E+12 +C QQLMNSV=1.E+12 +C + S1TIME=MPI_TIC() + DO K=1,KS + DO LL=1,NCBS + L=LCBS(LL) + LN=LNC(L) + QQ(L,K)=QQ(LN,K) + QQL(L,K)=QQL(LN,K) + DML(L,K)=DML(LN,K) + ENDDO + ENDDO + DO K=1,KS + DO LL=1,NCBW + L=LCBW(LL) + QQ(L,K)=QQ(L+1,K) + QQL(L,K)=QQL(L+1,K) + DML(L,K)=DML(L+1,K) + ENDDO + ENDDO + DO K=1,KS + DO LL=1,NCBE + L=LCBE(LL) + QQ(L,K)=QQ(L-1,K) + QQL(L,K)=QQL(L-1,K) + DML(L,K)=DML(L-1,K) + ENDDO + ENDDO + DO K=1,KS + DO LL=1,NCBN + L=LCBN(LL) + LS=LSC(L) + QQ(L,K)=QQ(LS,K) + QQL(L,K)=QQL(LS,K) + DML(L,K)=DML(LS,K) + ENDDO + ENDDO +C *** DSLLC BEGIN BLOCK + MPI_WTIMES(511)=MPI_WTIMES(511)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + QQSQR(L,K)=SQRT(QQ(L,K)) ! *** DSLLC + ENDDO + ENDDO + MPI_WTIMES(512)=MPI_WTIMES(512)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + DO K=0,KCM + CALL broadcast_boundary(QQ(:,K),ic) + CALL broadcast_boundary(QQ1(:,K),ic) + CALL broadcast_boundary(QQL(:,K),ic) + CALL broadcast_boundary(QQL1(:,K),ic) + CALL broadcast_boundary(QQSQR(:,K),ic) + CALL broadcast_boundary(DML(:,K),ic) + ENDDO + MPI_WTIMES(515)=MPI_WTIMES(515)+MPI_TOC(S1TIME) +C + IF(PRINT_SUM)THEN + DO K=0,KCM + call collect_in_zero(QQ(:,K)) + call collect_in_zero(QQL(:,K)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'3QQ = ', sum(abs(dble(QQ))) + PRINT*, n,'3QQL = ', sum(abs(dble(QQL))) + ENDIF + ENDIF + call mpi_barrier(mpi_comm_world,ierr) +C +C *** DSLLC END BLOCK +C 110 FORMAT(' I J QQ BOT QQ MID QQ SURF', +C & ' PROD+ADV 1./DIAGON') +C 111 FORMAT(2I5,5E14.5) +C 600 FORMAT('N,QX,QN,QLX,QLN,CX,CN=',I5,6E12.4) +C 601 FORMAT('NEG QQ I,J,K,QQ=',3I5,E13.5) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2T_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2T_mpi.for new file mode 100644 index 000000000..bd5b8a1cc --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQQ2T_mpi.for @@ -0,0 +1,664 @@ + SUBROUTINE CALQQ2T_mpi (ISTL_) +C +C CHANGE RECORD +C FIXED DYNAMIC TIME STEPPING +C ** SUBROUTINE CALQQ CALCULATES THE TURBULENT INTENSITY SQUARED AT +C ** TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES THE NUMBER OF +C ** TIME LEVELS INVOLVED +C + USE GLOBAL + USE MPI + + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + DELTD2=0.5*DT + DELTI=1./DELT + ELSE + DELT=DTDYN + DELTD2=0.5*DTDYN + DELTI=1./DELT + END IF + S2TL=0.0 + BSMALL=1.E-12 + + S1TIME=MPI_TIC() + DO K=0,KCM + CALL broadcast_boundary(QQ(:,K),ic) + CALL broadcast_boundary(QQL(:,K),ic) + ENDDO + MPI_WTIMES(513)=MPI_WTIMES(513)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + QQ2(L,K)=QQ(L,K)+QQ(L,K) + QQL2(L,K)=QQL(L,K)+QQL(L,K) + ENDDO + ENDDO + MPI_WTIMES(501)=MPI_WTIMES(501)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + UUU(L,KC)=0. + VVV(L,KC)=0. + FUHU(L,KC)=0. + FUHV(L,KC)=0. + FVHU(L,KC)=0. + FUHV(L,KC)=0. + ENDDO + MPI_WTIMES(502)=MPI_WTIMES(502)+MPI_TOC(S1TIME) +C +C ** CALCULATE ADVECTIVE FLUXES BY UPWIND DIFFERENCE WITH TRANSPORT +C ** AVERAGED BETWEEN (N) AND (N+1) AND TRANSPORTED FIELD AT (N) OR +C ** TRANSPORT BETWEEN (N-1) AND (N+1) AND TRANSPORTED FIELD AT (N-1) +C ** FOR ISTL EQUAL TO 2 AND 3 RESPECTIVELY +C ** FUHQQ=FUHU, FVHQQ=FVHU, FUHQQL=FUHV, FVHQQL=FVHV +C + S1TIME=MPI_TIC() + IF(IDRYTBP.EQ.0)THEN + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(WB) + DO L=LMPI2,LMPILA + WB=0.5*DXYP(L)*(W2(L,K-1)+W2(L,K)) + FWQQ(L,K)=MAX(WB,0.)*QQ(L,K-1) + & +MIN(WB,0.)*QQ(L,K) + FWQQL(L,K)=MAX(WB,0.)*QQL(L,K-1)*H1P(L) + & +MIN(WB,0.)*QQL(L,K)*H1P(L) + ENDDO + ENDDO + ELSE + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(WB) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + WB=0.5*DXYP(L)*(W2(L,K-1)+W2(L,K)) + FWQQ(L,K)=MAX(WB,0.)*QQ(L,K-1) + & +MIN(WB,0.)*QQ(L,K) + FWQQL(L,K)=MAX(WB,0.)*QQL(L,K-1)*H1P(L) + & +MIN(WB,0.)*QQL(L,K)*H1P(L) + ELSE + FWQQ(L,K)=0. + FWQQL(L,K)=0. + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(503)=MPI_WTIMES(503)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + IF(IDRYTBP.EQ.0)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LS,UHUW,VHVW) + DO L=LMPI2,LMPILA + LS=LSC(L) + UHUW=0.5*(UHDY2(L,K)+UHDY2(L,K+1)) + VHVW=0.5*(VHDX2(L,K)+VHDX2(L,K+1)) + FUHU(L,K)=MAX(UHUW,0.)*QQ(L-1,K) + & +MIN(UHUW,0.)*QQ(L,K) + FVHU(L,K)=MAX(VHVW,0.)*QQ(LS,K) + & +MIN(VHVW,0.)*QQ(L,K) + FUHV(L,K)=MAX(UHUW,0.)*QQL(L-1,K)*H1P(L-1) + & +MIN(UHUW,0.)*QQL(L,K)*H1P(L) + FVHV(L,K)=MAX(VHVW,0.)*QQL(LS,K)*H1P(LS) + & +MIN(VHVW,0.)*QQL(L,K)*H1P(L) + ENDDO + ENDDO + ELSE + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LS,UHUW,VHVW) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LS=LSC(L) + UHUW=0.5*(UHDY2(L,K)+UHDY2(L,K+1)) + VHVW=0.5*(VHDX2(L,K)+VHDX2(L,K+1)) + FUHU(L,K)=MAX(UHUW,0.)*QQ(L-1,K) + & +MIN(UHUW,0.)*QQ(L,K) + FVHU(L,K)=MAX(VHVW,0.)*QQ(LS,K) + & +MIN(VHVW,0.)*QQ(L,K) + FUHV(L,K)=MAX(UHUW,0.)*QQL(L-1,K)*H1P(L-1) + & +MIN(UHUW,0.)*QQL(L,K)*H1P(L) + FVHV(L,K)=MAX(VHVW,0.)*QQL(LS,K)*H1P(LS) + & +MIN(VHVW,0.)*QQL(L,K)*H1P(L) + ELSE + FUHU(L,K)=0. + FUHV(L,K)=0. + FVHU(L,K)=0. + FUHV(L,K)=0. + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(504)=MPI_WTIMES(504)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + CALL broadcast_boundary_array(FUHU,ic) + CALL broadcast_boundary_array(FVHU,ic) + CALL broadcast_boundary_array(FUHV,ic) + CALL broadcast_boundary_array(FVHV,ic) + MPI_WTIMES(514)=MPI_WTIMES(514)+MPI_TOC(S1TIME) +C +C ** CALCULATE PRODUCTION, LOAD BOUNDARY CONDITIONS AND SOLVE +C ** TRANSPORT EQUATIONS +C ** FUHQQ=FUHU, FVHQQ=FVHU, FUHQQL=FUHV, FVHQQL=FVHV +C ** CU1=CUQ, CU2=CUQL, UUU=QQH, VVV=QQLH +C + S1TIME=MPI_TIC() + DO K=1,KC + DO LL=1,NCBS + L=LCBS(LL) + LN=LNC(L) + IF(FVHU(LN,K).GT.0)THEN + FVHU(LN,K)=0.0 + FVHV(LN,K)=0.0 + ENDIF + ENDDO + DO LL=1,NCBW + L=LCBW(LL) + IF(FUHU(L+1,K).GT.0)THEN + FUHU(L+1,K)=0.0 + FUHV(L+1,K)=0.0 + ENDIF + ENDDO + DO LL=1,NCBE + L=LCBE(LL) + IF(FUHU(L,K).LT.0.)THEN + FUHU(L,K)=0.0 + FUHV(L,K)=0.0 + ENDIF + ENDDO + DO LL=1,NCBN + L=LCBN(LL) + IF(FVHU(L,K).LT.0.)THEN + FVHU(L,K)=0.0 + FVHV(L,K)=0.0 + ENDIF + ENDDO + ENDDO + MPI_WTIMES(505)=MPI_WTIMES(505)+MPI_TOC(S1TIME) + + + S1TIME=MPI_TIC() + IF(ISWAVE.LE.1.OR.ISWAVE.EQ.3)THEN + IF(IDRYTBP.EQ.0)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + LN=LNC(L) + UUU(L,K)=QQ(L,K)*H1P(L) + & +DELT*(FUHU(L,K)-FUHU(L+1,K)+FVHU(L,K)-FVHU(LN,K) + & +(FWQQ(L,K)-FWQQ(L,K+1))*DZIG(K))*DXYIP(L) + VVV(L,K)=QQL(L,K)*H1P(L)*H1P(L) + & +DELT*(FUHV(L,K)-FUHV(L+1,K)+FVHV(L,K)-FVHV(LN,K) + & +(FWQQL(L,K)-FWQQL(L,K+1))*DZIG(K))*DXYIP(L) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UUU(L,K)=MAX(UUU(L,K),0.) + VVV(L,K)=MAX(VVV(L,K),0.) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN,LS,PQQB,PQQU,PQQ,PQQL) + DO L=LMPI2,LMPILA + LN=LNC(L) + LS=LSC(L) + PQQB=AB(L,K)*GP*HP(L)*DZIG(K)*(B(L,K+1)-B(L,K)) + PQQU=AV(L,K)*DZIGSD4(K)*(U(L+1,K+1)-U(L+1,K)+U(L,K+1)- + & U(L,K))**2+AV(L,K)*DZIGSD4(K)*(V(LN,K+1)-V(LN,K)+V( + & L,K+1)-V(L,K))**2 + PQQ=DELT*(PQQB+PQQU) + UUU(L,K)=UUU(L,K)+2.*PQQ + PQQL=DELT*H1P(L)*(CTE3*PQQB+CTE1*PQQU) + VVV(L,K)=VVV(L,K)+DML(L,K)*PQQL + ENDDO + ENDDO + ELSE + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LN=LNC(L) + UUU(L,K)=QQ(L,K)*H1P(L) + & +DELT*(FUHU(L,K)-FUHU(L+1,K)+FVHU(L,K)-FVHU(LN,K) + & +(FWQQ(L,K)-FWQQ(L,K+1))*DZIG(K))*DXYIP(L) + VVV(L,K)=QQL(L,K)*H1P(L)*H1P(L) + & +DELT*(FUHV(L,K)-FUHV(L+1,K)+FVHV(L,K)-FVHV(LN,K) + & +(FWQQL(L,K)-FWQQL(L,K+1))*DZIG(K))*DXYIP(L) + + UUU(L,K)=MAX(UUU(L,K),0.) + VVV(L,K)=MAX(VVV(L,K),0.) + ELSE + UUU(L,K)=0.0 + VVV(L,K)=0.0 + ENDIF + ENDDO + ENDDO +C + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN,LS,PQQB,PQQU,PQQ,PQQL) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LN=LNC(L) + LS=LSC(L) + PQQB=AB(L,K)*GP*HP(L)*DZIG(K)*(B(L,K+1)-B(L,K)) + PQQU=AV(L,K)*DZIGSD4(K)*(U(L+1,K+1)-U(L+1,K)+U(L,K+1) + & -U(L,K))**2+AV(L,K)*DZIGSD4(K)*(V(LN,K+1)-V(LN,K) + & +V(L,K+1)-V(L,K))**2 + PQQ=DELT*(PQQB+PQQU) + UUU(L,K)=UUU(L,K)+2.*PQQ + PQQL=DELT*H1P(L)*(CTE3*PQQB+CTE1*PQQU) + VVV(L,K)=VVV(L,K)+DML(L,K)*PQQL + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + MPI_WTIMES(506)=MPI_WTIMES(506)+MPI_TOC(S1TIME) +C +C *** DSLLC BEGIN BLOCK +C + S1TIME=MPI_TIC() + IF(ISWAVE.EQ.2)THEN + IF(N.LT.NTSWV)THEN + TMPVAL=FLOAT(N)/FLOAT(NTSWV) + WVFACT=0.5-0.5*COS(PI*TMPVAL) + ELSE + WVFACT=1.0 + ENDIF + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR1W(L,K)=WVDTKEM(K)*WVDISP(L,K)+WVDTKEP(K)*WVDISP(L,K+1) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN,LS,PQQB,PQQU,PQQV,PQQW,PQQ,PQQL,FFTMP) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LN=LNC(L) + LS=LSC(L) + PQQB=AB(L,K)*GP*HP(L)*DZIG(K)*(B(L,K+1)-B(L,K)) + PQQU=AV(L,K)*DZIGSD4(K)* + & (U(L+1,K+1)-U(L+1,K)+U(L,K+1)-U(L,K))**2 + PQQV=AV(L,K)*DZIGSD4(K)* + & (V(LN,K+1)-V(LN,K)+V(L,K+1)-V(L,K))**2 + PQQW= WVFACT*TVAR1W(L,K) + PQQ=DELT*(PQQU+PQQV+PQQB+PQQW) + FFTMP=MAX(FUHU(L,K)-FUHU(L+1,K)+FVHU(L,K)-FVHU(LN,K) + + & (FWQQ(L,K)-FWQQ(L,K+1))*DZIG(K),0.) + UUU(L,K)=QQ(L,K)*H1P(L)+DELT*FFTMP*DXYIP(L) + 2.*PQQ + PQQL=DELT*H1P(L)*(CTE3*PQQB+CTE1*(PQQU+PQQV+PQQW)) + FFTMP=MAX(FUHV(L,K)-FUHV(L+1,K)+FVHV(L,K)-FVHV(LN,K) + + & (FWQQL(L,K)-FWQQL(L,K+1))*DZIG(K),0.) + VVV(L,K)=QQL(L,K)*H1P(L)*H1P(L)+DELT*FFTMP*DXYIP(L) + + & DML(L,K)*PQQL + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(507)=MPI_WTIMES(507)+MPI_TOC(S1TIME) +C +C *** DSLLC END BLOCK +C + S1TIME=MPI_TIC() + IF(KC.LE.2)THEN + IF(IDRYTBP.EQ.0)THEN +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) + CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)))*(1. + & +CTE2*DML(L,1)*DML(L,1)*FPROX(1)) + EQ=1./CMQTMP + EQL=1./CMQLTMP + CU1(L,1)=CUQTMP*EQ + CU2(L,1)=CUQTMP*EQL + UUU(L,1)=(UUU(L,1)-CLQTMP*HP(L)*QQ(L,0) + & -CUQTMP*HP(L)*QQ(L,KC))*EQ + VVV(L,1)=VVV(L,1)*EQL + ENDDO + ELSE +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) + CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)))*(1. + & +CTE2*DML(L,1)*DML(L,1)*FPROX(1)) + EQ=1./CMQTMP + EQL=1./CMQLTMP + CU1(L,1)=CUQTMP*EQ + CU2(L,1)=CUQTMP*EQL + UUU(L,1)=(UUU(L,1)-CLQTMP*HP(L)*QQ(L,0) + & -CUQTMP*HP(L)*QQ(L,KC))*EQ + VVV(L,1)=VVV(L,1)*EQL + ENDIF + ENDDO + ENDIF + ENDIF + MPI_WTIMES(508)=MPI_WTIMES(508)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(KC.GT.2)THEN + IF(IDRYTBP.EQ.0)THEN +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) + CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)))*(1. + & +CTE2*DML(L,1)*DML(L,1)*FPROX(1)) + EQ=1./CMQTMP + EQL=1./CMQLTMP + CU1(L,1)=CUQTMP*EQ + CU2(L,1)=CUQTMP*EQL + UUU(L,1)=(UUU(L,1)-CLQTMP*HP(L)*QQ(L,0))*EQ + VVV(L,1)=VVV(L,1)*EQL + CUQTMP=-DELT*CDZKKP(KS)*AQ(L,KC)*HPI(L) + UUU(L,KS)=UUU(L,KS)-CUQTMP*HP(L)*QQ(L,KC) + ENDDO + DO K=2,KS +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + CLQTMP=-DELT*CDZKK(K)*AQ(L,K)*HPI(L) + CUQTMP=-DELT*CDZKKP(K)*AQ(L,K+1)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,K)/(CTURBB1(L,K)*DML(L,K)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,K)/(CTURBB1(L,K)*DML(L,K)*HP(L)))*(1. + & +CTE2*DML(L,K)*DML(L,K)*FPROX(K)) + EQ=1./(CMQTMP-CLQTMP*CU1(L,K-1)) + EQL=1./(CMQLTMP-CLQTMP*CU2(L,K-1)) + CU1(L,K)=CUQTMP*EQ + CU2(L,K)=CUQTMP*EQL + UUU(L,K)=(UUU(L,K)-CLQTMP*UUU(L,K-1))*EQ + VVV(L,K)=(VVV(L,K)-CLQTMP*VVV(L,K-1))*EQL + ENDDO + ENDDO + DO K=KS-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UUU(L,K)=UUU(L,K)-CU1(L,K)*UUU(L,K+1) + VVV(L,K)=VVV(L,K)-CU2(L,K)*VVV(L,K+1) + ENDDO + ENDDO + ELSE +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + CLQTMP=-DELT*CDZKK(1)*AQ(L,1)*HPI(L) + CUQTMP=-DELT*CDZKKP(1)*AQ(L,2)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,1)/(CTURBB1(L,1)*DML(L,1)*HP(L)))*(1. + & +CTE2*DML(L,1)*DML(L,1)*FPROX(1)) + EQ=1./CMQTMP + EQL=1./CMQLTMP + CU1(L,1)=CUQTMP*EQ + CU2(L,1)=CUQTMP*EQL + UUU(L,1)=(UUU(L,1)-CLQTMP*HP(L)*QQ(L,0))*EQ + VVV(L,1)=VVV(L,1)*EQL + CUQTMP=-DELT*CDZKKP(KS)*AQ(L,KC)*HPI(L) + UUU(L,KS)=UUU(L,KS)-CUQTMP*HP(L)*QQ(L,KC) + ENDIF + ENDDO + DO K=2,KS +!$OMP PARALLEL DO PRIVATE(CLQTMP,CUQTMP,CMQTMP,CMQLTMP,EQ,EQL) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + CLQTMP=-DELT*CDZKK(K)*AQ(L,K)*HPI(L) + CUQTMP=-DELT*CDZKKP(K)*AQ(L,K+1)*HPI(L) + CMQTMP=1.-CLQTMP-CUQTMP + & +2.*DELT*QQSQR(L,K)/(CTURBB1(L,K)*DML(L,K)*HP(L)) + CMQLTMP=1.-CLQTMP-CUQTMP + & +DELT*(QQSQR(L,K)/(CTURBB1(L,K)*DML(L,K)*HP(L)) + & )*(1.+CTE2*DML(L,K)*DML(L,K)*FPROX(K)) + EQ=1./(CMQTMP-CLQTMP*CU1(L,K-1)) + EQL=1./(CMQLTMP-CLQTMP*CU2(L,K-1)) + CU1(L,K)=CUQTMP*EQ + CU2(L,K)=CUQTMP*EQL + UUU(L,K)=(UUU(L,K)-CLQTMP*UUU(L,K-1))*EQ + VVV(L,K)=(VVV(L,K)-CLQTMP*VVV(L,K-1))*EQL + ENDIF + ENDDO + ENDDO + DO K=KS-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + UUU(L,K)=UUU(L,K)-CU1(L,K)*UUU(L,K+1) + VVV(L,K)=VVV(L,K)-CU2(L,K)*VVV(L,K+1) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + MPI_WTIMES(509)=MPI_WTIMES(509)+MPI_TOC(S1TIME) +C + IF(PRINT_SUM)THEN + call collect_in_zero_array(UUU) + call collect_in_zero_array(VVV) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'UUU = ', sum(abs(dble(UUU))) + PRINT*, n,'VVV = ', sum(abs(dble(VVV))) + ENDIF + DO K=0,KCM + call collect_in_zero(QQ(:,K)) + call collect_in_zero(QQL(:,K)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'1QQ = ', sum(abs(dble(QQ))) + PRINT*, n,'1QQL = ', sum(abs(dble(QQL))) + ENDIF + ENDIF +C + S1TIME=MPI_TIC() + IF(IDRYTBP.EQ.0)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(QQHDH) + DO L=LMPI2,LMPILA + QQ1(L,K)=QQ(L,K) + QQHDH=UUU(L,K)*HPI(L) + QQ(L,K)=MAX(QQHDH,QQMIN) + ENDDO + ENDDO +C +C ** ORIGINAL FORM MODIFED FOR DIMENSIONAL LENGHT SCALE TRANSPORT +C + IF(ISTOPT(0).EQ.1)THEN + DO K=1,KS +!!$OMP PARALLEL DO PRIVATE(QQHDH,DMLTMP,DELB,DMLMAX) + DO L=LMPI2,LMPILA + QQL1(L,K)=QQL(L,K) + QQHDH=VVV(L,K)*HPI(L)*HPI(L) + QQL(L,K)=MAX(QQHDH,QQLMIN) + DMLTMP=QQL(L,K)/QQ(L,K) + DMLTMP=MAX(DMLTMP,DMLMIN) + DELB=B(L,K)-B(L,K+1) + IF(DELB.GT.0.0)THEN + DMLMAX=0.53*SQRT(QQ(L,K)/(G*HP(L)*DZIG(K)*DELB)) + DML(L,K)=MIN(DMLMAX,DMLTMP) + ELSE + DML(L,K)=DMLTMP + ENDIF + ENDDO + ENDDO + ENDIF +C +C ** BUCHARD'S MODIFED CLOSURE FOR DIMENSIONAL LENGHT SCALE TRANSPORT +C + IF(ISTOPT(0).EQ.2)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(QQHDH,DMLTMP) + DO L=LMPI2,LMPILA + QQL1(L,K)=QQL(L,K) + QQHDH=VVV(L,K)*HPI(L)*HPI(L) + QQL(L,K)=MAX(QQHDH,QQLMIN) + DMLTMP=QQL(L,K)/QQ(L,K) + DML(L,K)=MAX(DMLTMP,DMLMIN) + ENDDO + ENDDO + ENDIF + ELSE + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(QQHDH) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQ1(L,K)=QQ(L,K) + QQHDH=UUU(L,K)*HPI(L) + QQ(L,K)=MAX(QQHDH,QQMIN) + ENDIF + ENDDO + ENDDO +C +C ** ORIGINAL FORM MODIFED FOR DIMENSIONAL LENGHT SCALE TRANSPORT +C + IF(ISTOPT(0).EQ.1)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(QQHDH,DMLTMP,DELB,DMLMAX) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQL1(L,K)=QQL(L,K) + QQHDH=VVV(L,K)*HPI(L)*HPI(L) + QQL(L,K)=MAX(QQHDH,QQLMIN) + DMLTMP=QQL(L,K)/QQ(L,K) + DMLTMP=MAX(DMLTMP,DMLMIN) + DELB=B(L,K)-B(L,K+1) + IF(DELB.GT.0.0)THEN + DMLMAX=0.53*SQRT(QQ(L,K)/(G*HP(L)*DZIG(K)*DELB)) + DML(L,K)=MIN(DMLMAX,DMLTMP) + ELSE + DML(L,K)=DMLTMP + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +C +C ** BUCHARD'S MODIFED CLOSURE FOR DIMENSIONAL LENGHT SCALE TRANSPORT +C + IF(ISTOPT(0).EQ.2)THEN + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(QQHDH,DMLTMP) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + QQL1(L,K)=QQL(L,K) + QQHDH=VVV(L,K)*HPI(L)*HPI(L) + QQL(L,K)=MAX(QQHDH,QQLMIN) + DMLTMP=QQL(L,K)/QQ(L,K) + DML(L,K)=MAX(DMLTMP,DMLMIN) + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + MPI_WTIMES(510)=MPI_WTIMES(510)+MPI_TOC(S1TIME) +C + IF(PRINT_SUM)THEN + DO K=0,KCM + call collect_in_zero(QQ(:,K)) + call collect_in_zero(QQL(:,K)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'2QQ = ', sum(abs(dble(QQ))) + PRINT*, n,'2QQL = ', sum(abs(dble(QQL))) + ENDIF + ENDIF +C +C QQMXSV=-1.E+12 +C QQMNSV=1.E+12 +C QQLMXSV=-1.E+12 +C QQLMNSV=1.E+12 +C + S1TIME=MPI_TIC() + DO K=1,KS + DO LL=1,NCBS + L=LCBS(LL) + LN=LNC(L) + QQ(L,K)=QQ(LN,K) + QQL(L,K)=QQL(LN,K) + DML(L,K)=DML(LN,K) + ENDDO + ENDDO + DO K=1,KS + DO LL=1,NCBW + L=LCBW(LL) + QQ(L,K)=QQ(L+1,K) + QQL(L,K)=QQL(L+1,K) + DML(L,K)=DML(L+1,K) + ENDDO + ENDDO + DO K=1,KS + DO LL=1,NCBE + L=LCBE(LL) + QQ(L,K)=QQ(L-1,K) + QQL(L,K)=QQL(L-1,K) + DML(L,K)=DML(L-1,K) + ENDDO + ENDDO + DO K=1,KS + DO LL=1,NCBN + L=LCBN(LL) + LS=LSC(L) + QQ(L,K)=QQ(LS,K) + QQL(L,K)=QQL(LS,K) + DML(L,K)=DML(LS,K) + ENDDO + ENDDO +C *** DSLLC BEGIN BLOCK + MPI_WTIMES(511)=MPI_WTIMES(511)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + QQSQR(L,K)=SQRT(QQ(L,K)) ! *** DSLLC + ENDDO + ENDDO + MPI_WTIMES(512)=MPI_WTIMES(512)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + DO K=0,KCM + CALL broadcast_boundary(QQ(:,K),ic) + CALL broadcast_boundary(QQ1(:,K),ic) + CALL broadcast_boundary(QQL(:,K),ic) + CALL broadcast_boundary(QQL1(:,K),ic) + CALL broadcast_boundary(QQSQR(:,K),ic) + CALL broadcast_boundary(DML(:,K),ic) + ENDDO + MPI_WTIMES(515)=MPI_WTIMES(515)+MPI_TOC(S1TIME) +C + IF(PRINT_SUM)THEN + DO K=0,KCM + call collect_in_zero(QQ(:,K)) + call collect_in_zero(QQL(:,K)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'3QQ = ', sum(abs(dble(QQ))) + PRINT*, n,'3QQL = ', sum(abs(dble(QQL))) + ENDIF + ENDIF + call mpi_barrier(mpi_comm_world,ierr) +C +C *** DSLLC END BLOCK +C 110 FORMAT(' I J QQ BOT QQ MID QQ SURF', +C & ' PROD+ADV 1./DIAGON') +C 111 FORMAT(2I5,5E14.5) +C 600 FORMAT('N,QX,QN,QLX,QLN,CX,CN=',I5,6E12.4) +C 601 FORMAT('NEG QQ I,J,K,QQ=',3I5,E13.5) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQVS.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQVS.for index b20b2c5a2..4f7b92c85 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQVS.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQVS.for @@ -5,7 +5,7 @@ C ** SUBROUTINE CALQVS UPDATES TIME VARIABLE VOLUME SOURCES C USE GLOBAL - REAL T1TMP, SECNDS + REAL T1TMP,T2TMP INTEGER*4 NS ! *** PMC @@ -37,79 +37,51 @@ C GWCSERT(0,NC)=0. ENDDO -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA QGW(L)=0.0 END DO IF(ISTRAN(5).GT.0)THEN DO NC=1,NCTMP - DO L=LF,LL + DO L=2,LA CONGW(L,NC)=0.0 END DO END DO ENDIF -c - enddo ENDIF C C ** INITIALIZE TOTAL FLOW SERIES C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - DO L=LF,LL + DO L=1,LC QSUM1E(L)=QSUME(L) ! *** DSLLC SINGLE LINE QSUME(L)=0. ENDDO -c - enddo ! *** SELECTIVE ZEROING IF(KC.GT.1)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c IF(NGWSER.GT.0.OR.ISGWIT.NE.0)THEN - DO L=LF,LL + DO L=1,LC QSUM(L,1)=0. ENDDO ENDIF ! *** ZERO EVAP/RAINFALL - DO L=LF,LL + DO L=1,LC QSUM(L,KC)=0. ENDDO -c - enddo ! *** ZERO ALL DEFINED BC'S - DO K=1,KC DO NS=1,NBCS L=LBCS(NS) + DO K=1,KC QSUM(L,K)=0. ENDDO ENDDO ELSE ! *** SINGLE LAYER -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - DO L=LF,LL + DO L=1,LC QSUM(L,1)=0. ENDDO -c - enddo ENDIF C C ** VOLUME SOURCE/SINK INTERPOLATION @@ -204,40 +176,26 @@ C GWCSERT(NC,NS)=WTM1*GWCSER(M1,NC,NS)+WTM2*GWCSER(M2,NC,NS) END DO ENDDO -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA QGW(L)=GWFAC(L)*GWSERT(NGWSL(L)) END DO IF(ISTRAN(5).GT.0)THEN DO NC=1,NCTMP - DO L=LF,LL + DO L=2,LA CONGW(L,NC)=GWCSERT(NC,NGWSL(L)) END DO END DO ENDIF -c - enddo ENDIF ! *** CONSTANT GW LOSSES IF(ISGWIT.EQ.3)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA IF(H1P(L).GE.HDRY)THEN !VOLOUTO=VOLOUTO+RIFTR(L)*DTIM QSUM(L,1)=QSUM(L,1)-RIFTR(L) ENDIF ENDDO -c - enddo !IF((H1P(343).GE.HDRY.or.HP(343).GE.HDRY).and.TIMEDAY.GT.6.5)THEN ! VOLOUTE=VOLOUTE+RIFTR(L)*DTIM ! WRITE(99,*)N,TIMEDAY,RIFTR(L),H1P(L),HP(L),VOLOUTE @@ -246,7 +204,7 @@ c C C ** CONTROL STRUCTURES AND TIDAL INLETS C - T1TMP=SECNDS(0.0) + CALL CPU_TIME(T1TMP) DO NCTL=1,NQCTL IF(NQCTYP(NCTL).LE.1)THEN NCTLT=NQCTLQ(NCTL) @@ -430,7 +388,8 @@ C { GEOSR 2010.5.6 GATE NORMAL FORMULA ENDIF ENDIF C } GEOSR 2010.5.6 GATE NORMAL FORMULA - TQCTL=TQCTL+SECNDS(T1TMP) + CALL CPU_TIME(T2TMP) + TQCTL=TQCTL+T2TMP-T1TMP C C ** FLOW WITHDRAWAL AND RETURN C @@ -564,14 +523,9 @@ C C C ** GROUND WATER INTERACTION, EVAPORATION AND RAINFALL C -!$OMP PARALLEL DO PRIVATE(LF,LL,SVPW) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(ISGWIE.EQ.0)THEN IF(EVAPCVT.LT.0.)THEN - DO L=LF,LL + DO L=2,LA SVPW=(10.**((0.7859+0.03477*TEM(L,KC))/ & (1.+0.00412*TEM(L,KC)))) EVAPT(L)=CLEVAP(L)*0.7464E-3*WINDST(L)*(SVPW-VPA(L))/PATMT(L) @@ -579,33 +533,24 @@ c QSUM(L,KC)=QSUM(L,KC)+DXYP(L)*(RAINT(L)-EVAPT(L)) ENDDO ELSE - DO L=LF,LL + DO L=2,LA IF(HP(L).LT.HWET) EVAPT(L)=0. QSUM(L,KC)=QSUM(L,KC)+DXYP(L)*(RAINT(L)-EVAPT(L)) ENDDO ENDIF ELSE - DO L=LF,LL + DO L=2,LA QSUM(L,KC)=QSUM(L,KC)+DXYP(L)*RAINT(L) ENDDO ENDIF -c - enddo C C ** DETERMINE NET EXTERNAL VOLUME SOURCE/SINK C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=1,LC QSUME(L)=QSUME(L)+QSUM(L,K) ENDDO ENDDO -c - enddo C C ** UPDATE ZERO DIMENSION VOLUME BALANCE C VOLADD=0. @@ -706,14 +651,14 @@ C ENDIF 101 FORMAT(' SOURCE/SINK DIAGNOSTICS AT TIME STEP =',I8,//) 102 FORMAT(3X,'CONST NQSIJ SOURCE/SINK FLOW AT I =',I5,' J =',I5,/) - 103 FORMAT(5X,'K =',I5,5X,'QSS(K) = ',E12.4,5X,'CQS(K,1) = ',E12.4, - & 5X,'CQS(K,5) = ',E12.4) - 203 FORMAT(5X,'K =',I5,5X,'QSS(K) = ',E12.4,5X,'CQS(K, ) = ', - & 5X, 12E12.4) +C 103 FORMAT(5X,'K =',I5,5X,'QSS(K) = ',E12.4,5X,'CQS(K,1) = ',E12.4, +C & 5X,'CQS(K,5) = ',E12.4) +C 203 FORMAT(5X,'K =',I5,5X,'QSS(K) = ',E12.4,5X,'CQS(K, ) = ', +C & 5X, 12E12.4) 104 FORMAT(/) 105 FORMAT(3X,'TIME VAR NQSIJ SOURCE/SINK FLOW AT I =',I5,' J=',I5,/) - 106 FORMAT(5X,'K =',I5,5X,'QSERT(K) = ',E12.4, - & 5X,'CSERT(K,1) = ',E12.4,5X,'CSERT(K,5) = ',E12.4) +C 106 FORMAT(5X,'K =',I5,5X,'QSERT(K) = ',E12.4, +C & 5X,'CSERT(K,1) = ',E12.4,5X,'CSERT(K,5) = ',E12.4) 206 FORMAT(5X,'NQ,LQ =',2I4,7X,'QSERT() = ',12E12.4) 207 FORMAT(5X,'NQ,NT,NCQ =',3I4,3X,'CSERT() = ',12E12.4) 216 FORMAT(5X,'NQ,LQ =',2I4,3X,'QSS() = ',12E12.4) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQVS_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQVS_mpi.for new file mode 100644 index 000000000..37e6e73a8 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALQVS_mpi.for @@ -0,0 +1,753 @@ + SUBROUTINE CALQVS_mpi (ISTL_) +C +C CHANGE RECORD +C ** SUBROUTINE CALQVS UPDATES TIME VARIABLE VOLUME SOURCES +C + USE GLOBAL + USE MPI + + REAL T1TMP,T2TMP + INTEGER*4 NS + + ! *** PMC + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + ELSE + DELT=DTDYN + END IF + ELSE + DELT=DT2 + ENDIF + ! *** PMC +C +C ** INITIALIZE NULL (0) FLOW SERIES +C + S1TIME=MPI_TIC() +C + GWSERT(0)=0. + QWRSERT(0)=0. + QSERTCELL=0.0 + DO K=1,KC + QSERT(K,0)=0. + QCTLT(K,0)=0. + QCTLTO(K,0)=0. + ENDDO + + IF(NGWSER.GE.1)THEN + NCTMP=4+NSED+NSND+NTOX + DO NC=1,NCTMP + GWCSERT(0,NC)=0. + ENDDO + + DO L=2,LA + QGW(L)=0.0 + END DO + IF(ISTRAN(5).GT.0)THEN + DO NC=1,NCTMP + DO L=2,LA + CONGW(L,NC)=0.0 + END DO + END DO + ENDIF + ENDIF +C +C ** INITIALIZE TOTAL FLOW SERIES +C + DO L=1,LC + QSUM1E(L)=QSUME(L) ! *** DSLLC SINGLE LINE + QSUME(L)=0. + ENDDO + + ! *** SELECTIVE ZEROING + IF(KC.GT.1)THEN + IF(NGWSER.GT.0.OR.ISGWIT.NE.0)THEN + DO L=1,LC + QSUM(L,1)=0. + ENDDO + ENDIF + + ! *** ZERO EVAP/RAINFALL + DO L=1,LC + QSUM(L,KC)=0. + ENDDO + + ! *** ZERO ALL DEFINED BC'S + DO NS=1,NBCS + L=LBCS(NS) + DO K=1,KC + QSUM(L,K)=0. + ENDDO + ENDDO + + ELSE + ! *** SINGLE LAYER + DO L=1,LC + QSUM(L,1)=0. + ENDDO + ENDIF +C + MPI_WTIMES(1201)=MPI_WTIMES(1201)+MPI_TOC(S1TIME) +C +C ** VOLUME SOURCE/SINK INTERPOLATION +C + S1TIME=MPI_TIC() +C + DO NS=1,NQSER + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + CTIM=DT*(FLOAT(N)-0.5)/TCQSER(NS) + & +TBEGIN*(TCON/TCQSER(NS)) + ELSE + CTIM=TIMESEC/TCQSER(NS) + ENDIF + ELSE + IF(ISDYNSTP.EQ.0)THEN + CTIM=DT*FLOAT(N-1)/TCQSER(NS)+TBEGIN*(TCON/TCQSER(NS)) + ELSE + CTIM=TIMESEC/TCQSER(NS) + ENDIF + ENDIF + M1=MQTLAST(NS) + 100 CONTINUE + M2=M1+1 +! IF(M2.GT.NDQSER)THEN + IF(CTIM.GT.TQSER(M2,NS))THEN + M1=M2 + GOTO 100 +! ENDIF + ELSE + MQTLAST(NS)=M1 + ENDIF + TDIFF=TQSER(M2,NS)-TQSER(M1,NS) + WTM1=(TQSER(M2,NS)-CTIM)/TDIFF + WTM2=(CTIM-TQSER(M1,NS))/TDIFF + DO K=1,KC + QSERT(K,NS)=WTM1*QSER(M1,K,NS)+WTM2*QSER(M2,K,NS) + ENDDO + ENDDO + IF(N.EQ.1)THEN + DO LL=1,NQSIJ + L=LQS(LL) + ITYP=LCT(L) + IF(ITYP.LE.0.OR.ITYP.GE.8)THEN + IF(MYRANK.EQ.0) WRITE(6,6111)LL,IQS(LL),JQS(LL) + IF(MYRANK.EQ.0) WRITE(8,6111)LL,IQS(LL),JQS(LL) + ENDIF + ENDDO + ENDIF + DO LL=1,NQSIJ + NS=NQSERQ(LL) + L=LQS(LL) + DO K=1,KC + ! *** PMC START + ! *** APPLY MULTIPLIERS HERE TO CORRECT MASS BALANCE PROBLEMS + QSS(K,LL) =QSS(K,LL) *RQSMUL(LL) + QSERCELL(K,LL)=QSERT(K,NS)*RQSMUL(LL)*QFACTOR(LL) + QSUM(L,K)=QSUM(L,K)+QSS(K,LL)+QSERCELL(K,LL) + ! *** PMC END + ENDDO + ENDDO +C + MPI_WTIMES(1202)=MPI_WTIMES(1202)+MPI_TOC(S1TIME) +C +C ** GROUNDWATER SOURCE/SINK INTERPOLATION +C + S1TIME=MPI_TIC() +C + IF(NGWSER.GE.1)THEN + NCTMP=4+NSED+NSND+NTOX + DO NS=1,NGWSER + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + CTIM=DT*(FLOAT(N)-0.5)/TCGWSER(NS) + & +TBEGIN*(TCON/TCGWSER(NS)) + ELSE + CTIM=TIMESEC/TCGWSER(NS) + ENDIF + ELSE + IF(ISDYNSTP.EQ.0)THEN + CTIM=DT*FLOAT(N-1)/TCQSER(NS)+TBEGIN*(TCON/TCQSER(NS)) + ELSE + CTIM=TIMESEC/TCGWSER(NS) + ENDIF + ENDIF + M1=MGWTLAST(NS) + 700 CONTINUE + M2=M1+1 + IF(CTIM.GT.TGWSER(M2,NS))THEN + M1=M2 + GOTO 700 + ELSE + MGWTLAST(NS)=M1 + ENDIF + TDIFF=TGWSER(M2,NS)-TGWSER(M1,NS) + WTM1=(TGWSER(M2,NS)-CTIM)/TDIFF + WTM2=(CTIM-TGWSER(M1,NS))/TDIFF + GWSERT(NS)=WTM1*GWSER(M1,NS)+WTM2*GWSER(M2,NS) + DO NC=1,NCTMP + GWCSERT(NC,NS)=WTM1*GWCSER(M1,NC,NS)+WTM2*GWCSER(M2,NC,NS) + END DO + ENDDO + DO L=2,LA + QGW(L)=GWFAC(L)*GWSERT(NGWSL(L)) + END DO + IF(ISTRAN(5).GT.0)THEN + DO NC=1,NCTMP + DO L=2,LA + CONGW(L,NC)=GWCSERT(NC,NGWSL(L)) + END DO + END DO + ENDIF + ENDIF +C + MPI_WTIMES(1203)=MPI_WTIMES(1203)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +C + ! *** CONSTANT GW LOSSES + IF(ISGWIT.EQ.3)THEN + DO L=2,LA + IF(H1P(L).GE.HDRY)THEN + !VOLOUTO=VOLOUTO+RIFTR(L)*DTIM + QSUM(L,1)=QSUM(L,1)-RIFTR(L) + ENDIF + ENDDO + !IF((H1P(343).GE.HDRY.or.HP(343).GE.HDRY).and.TIMEDAY.GT.6.5)THEN + ! VOLOUTE=VOLOUTE+RIFTR(L)*DTIM + ! WRITE(99,*)N,TIMEDAY,RIFTR(L),H1P(L),HP(L),VOLOUTE + !ENDIF + ENDIF +C + MPI_WTIMES(1204)=MPI_WTIMES(1204)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +C +C ** CONTROL STRUCTURES AND TIDAL INLETS +C + CALL CPU_TIME(T1TMP) + DO NCTL=1,NQCTL + IF(NQCTYP(NCTL).LE.1)THEN + NCTLT=NQCTLQ(NCTL) + RQDW=1. + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + LU=LIJ(IU,JU) + HUP=HP(LU)+BELV(LU)+HCTLUA(NCTLT) + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + IF(ID.EQ.0.AND.JD.EQ.0)THEN + LD=LC + HDW=0. + RQDW=0. + ELSE + LD=LIJ(ID,JD) + HDW=HP(LD)+BELV(LD)+HCTLDA(NCTLT) + ENDIF + DELH=HCTLUM(NCTLT)*HUP-HCTLDM(NCTLT)*HDW + IF(NQCTYP(NCTL).EQ.0.AND.AQCTL(NCTLT).GT.0.0)THEN + IF(HUP.LT.AQCTL(NCTLT)) DELH=-100. + ENDIF + IF(DELH.LE.0.OR.HP(LU).LT.HWET)THEN + DO K=1,KC + QCTLT(K,NCTL)=0. + ENDDO + ELSE + IF(NQCTYP(NCTL).EQ.1)DELH=SQRT(DELH) + M1=0 + M2=1 + 500 M1=M1+1 + M2=M2+1 + IF(M2.GT.MQCTL(NCTLT).AND.MYRANK.EQ.0)THEN + WRITE(6,6666) + WRITE(6,6667)NCTL,NCTLT,IU,JU,ID,JD + WRITE(6,6668)HUP,HP(LU),HDW,HP(LD) + WRITE(8,6666) + WRITE(8,6667)NCTL,NCTLT,IU,JU,ID,JD + WRITE(8,6668)HUP,HP(LU),HDW,HP(LD) + STOP + ENDIF + IF(DELH.GE.HDIFCTL(M1,NCTLT).AND.DELH.LE.HDIFCTL(M2,NCTLT) + & )THEN + TDIFF=HDIFCTL(M2,NCTLT)-HDIFCTL(M1,NCTLT) + WTM1=(HDIFCTL(M2,NCTLT)-DELH)/TDIFF + WTM2=(DELH-HDIFCTL(M1,NCTLT))/TDIFF + DO K=1,KC + QCTLT(K,NCTL)=WTM1*QCTL(M1,1,K,NCTLT) + & +WTM2*QCTL(M2,1,K,NCTLT) + ENDDO + ELSE + GOTO 500 + ENDIF + ENDIF + IF(NQCTYP(NCTL).EQ.1)THEN + IF(ISTL_.EQ.3)THEN + DO K=1,KC + QCTLST(K,NCTL)=QCTLT(K,NCTL) + TMPVAL=QCTLTO(K,NCTL) + & +DT*AQCTL(NCTLT)*QCTLST(K,NCTL)*QCTLST(K,NCTL) + QCTLT(K,NCTL)=TMPVAL/(1.+DT*AQCTL(NCTLT)*QCTLTO(K,NCTL)) + QCTLTO(K,NCTL)=QCTLT(K,NCTL) + QCTLSTO(K,NCTL)=QCTLST(K,NCTL) + ENDDO + ELSE + DO K=1,KC + QCTLST(K,NCTL)=QCTLT(K,NCTL) + TMPVAL=QCTLTO(K,NCTL) + & +DT*AQCTL(NCTLT)*QCTLST(K,NCTL)*QCTLST(K,NCTL) + QCTLT(K,NCTL)=TMPVAL/(1.+DT*AQCTL(NCTLT)*QCTLTO(K,NCTL)) + QCTLT(K,NCTL)=0.5*(QCTLT(K,NCTL)+QCTLTO(K,NCTL)) + ENDDO + ENDIF + ENDIF + QCTLMAX=(HP(LU)-HDRY)*DXYP(LU)/(DELT*FLOAT(KC)) + DO K=1,KC + QCTLT(K,NCTL)=MIN(QCTLT(K,NCTL),QCTLMAX) + ENDDO + DO K=1,KC + ! *** PMC START - CORRECTED VOLUME MULTIPLIER TO FIX MASS BALANCE PROBLEM + QCTLT(K,NCTL)=QCTLT(K,NCTL)*RQCMUL(NCTL) + QSUM(LU,K)=QSUM(LU,K)-QCTLT(K,NCTL) + QSUM(LD,K)=QSUM(LD,K)+QCTLT(K,NCTL)*RQDW + ! *** PMC END + ENDDO + IPMC=0 + ENDIF + ENDDO +C + MPI_WTIMES(1205)=MPI_WTIMES(1205)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +C + DO NCTL=1,NQCTL + IF(NQCTYP(NCTL).EQ.2)THEN + NCTLT=NQCTLQ(NCTL) + RQDW=1. + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + LU=LIJ(IU,JU) + HUP=HP(LU)+BELV(LU)+HCTLUA(NCTLT) + IF(HUP.LT.HDIFCTL(1,NCTLT).OR.HP(LU).LT.HWET)THEN + DO K=1,KC + QCTLT(K,NCTL)=0. + ENDDO + GOTO 560 + ENDIF + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + LD=LIJ(ID,JD) + HDW=HP(LD)+BELV(LD)+HCTLDA(NCTLT) + HTMPD=HDIFCTD(1,NCTLT)+0.001 + HDW=MAX(HDW,HTMPD) + MU1=0 + MU2=1 + MD1=0 + MD2=1 + 555 MU1=MU1+1 + MU2=MU1+1 + IF(MU2.GT.MQCTL(NCTLT).AND.MYRANK.EQ.0)THEN + WRITE(6,6676) + WRITE(6,6677)NCTL,NCTLT,IU,JU,ID,JD + WRITE(6,6678)HUP,HP(LU),HDW,HP(LD) + WRITE(6,6679)HDIFCTL(1,NCTLT),HDIFCTL(MQCTL(NCTLT),NCTLT), + & HDIFCTD(1,NCTLT),HDIFCTD(MQCTL(NCTLT),NCTLT) + WRITE(8,6676) + WRITE(8,6677)NCTL,NCTLT,IU,JU,ID,JD + WRITE(8,6678)HUP,HP(LU),HDW,HP(LD) + WRITE(8,6679)HDIFCTL(1,NCTLT),HDIFCTL(MQCTL(NCTLT),NCTLT), + & HDIFCTD(1,NCTLT),HDIFCTD(MQCTL(NCTLT),NCTLT) + STOP + ENDIF + IF(HUP.GE.HDIFCTL(MU1,NCTLT).AND.HUP.LE.HDIFCTL(MU2,NCTLT))THEN + TDIFFU=HDIFCTL(MU2,NCTLT)-HDIFCTL(MU1,NCTLT) + WTM1U=(HDIFCTL(MU2,NCTLT)-HUP)/TDIFFU + WTM2U=(HUP-HDIFCTL(MU1,NCTLT))/TDIFFU + ELSE + GOTO 555 + ENDIF + 556 MD1=MD1+1 + MD2=MD1+1 + IF(MD2.GT.MQCTL(NCTLT).AND.MYRANK.EQ.0)THEN + WRITE(6,6686) + WRITE(6,6687)NCTL,NCTLT,IU,JU,ID,JD + WRITE(6,6688)HUP,HP(LU),HDW,HP(LD) + WRITE(6,6679)HDIFCTL(1,NCTLT),HDIFCTL(MQCTL(NCTLT),NCTLT), + & HDIFCTD(1,NCTLT),HDIFCTD(MQCTL(NCTLT),NCTLT) + WRITE(8,6686) + WRITE(8,6687)NCTL,NCTLT,IU,JU,ID,JD + WRITE(8,6688)HUP,HP(LU),HDW,HP(LD) + WRITE(8,6679)HDIFCTL(1,NCTLT),HDIFCTL(MQCTL(NCTLT),NCTLT), + & HDIFCTD(1,NCTLT),HDIFCTD(MQCTL(NCTLT),NCTLT) + STOP + ENDIF + IF(HDW.GE.HDIFCTD(MD1,NCTLT).AND.HDW.LE.HDIFCTD(MD2,NCTLT))THEN + TDIFFD=HDIFCTD(MD2,NCTLT)-HDIFCTD(MD1,NCTLT) + WTM1D=(HDIFCTD(MD2,NCTLT)-HDW)/TDIFFD + WTM2D=(HDW-HDIFCTD(MD1,NCTLT))/TDIFFD + ELSE + GOTO 556 + ENDIF + DO K=1,KC + QCTLT(K,NCTL)=WTM1U*( WTM1D*QCTL(MU1,MD1,K,NCTLT) + & +WTM2D*QCTL(MU1,MD2,K,NCTLT) ) + & +WTM2U*( WTM1D*QCTL(MU2,MD1,K,NCTLT) + & +WTM2D*QCTL(MU2,MD2,K,NCTLT) ) + ENDDO + 560 CONTINUE + QCTLMAX=(HP(LU)-HDRY)*DXYP(LU)/(DELT*FLOAT(KC)) + DO K=1,KC + QCTLT(K,NCTL)=MIN(QCTLT(K,NCTL),QCTLMAX) + ENDDO + DO K=1,KC + ! *** PMC START - CORRECTED VOLUME MULTIPLIER TO FIX MASS BALANCE PROBLEM + QCTLT(K,NCTL)=QCTLT(K,NCTL)*RQCMUL(NCTL) + QSUM(LU,K)=QSUM(LU,K)-QCTLT(K,NCTL) + QSUM(LD,K)=QSUM(LD,K)+QCTLT(K,NCTL)*RQDW + ! *** PMC END + ENDDO + ENDIF + ENDDO +C { GEOSR 2010.5.6 GATE NORMAL FORMULA + MPI_WTIMES(1206)=MPI_WTIMES(1206)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +C + IF (NQCTL.GE.1) THEN + IF (NQCTYP(1).GE.3) THEN + CALL CGATEFLX + ENDIF + ENDIF +C + MPI_WTIMES(1207)=MPI_WTIMES(1207)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +C +C } GEOSR 2010.5.6 GATE NORMAL FORMULA + CALL CPU_TIME(T2TMP) + TQCTL=TQCTL+T2TMP-T1TMP +C +C ** FLOW WITHDRAWAL AND RETURN +C + NTMP=4+NSED+NSND+NTOX + IF(ISTRAN(8).GT.0)NTMP=NTMP+NWQV + + DO NC=1,NTMP + CQWRSERT(0,NC)=0. + ENDDO + DO NS=1,NQWRSR + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + CTIM=DT*(FLOAT(N)-0.5)/TCQWRSR(NS) + & +TBEGIN*(TCON/TCQWRSR(NS)) + ELSE + CTIM=TIMESEC/TCQWRSR(NS) + ENDIF + ELSE + IF(ISDYNSTP.EQ.0)THEN + CTIM=DT*FLOAT(N-1)/TCQWRSR(NS)+TBEGIN*(TCON/TCQWRSR(NS)) + ELSE + CTIM=TIMESEC/TCQWRSR(NS) + ENDIF + ENDIF + M1=MQWRTLST(NS) + 200 CONTINUE + M2=M1+1 + IF(CTIM.GT.TQWRSER(M2,NS))THEN + M1=M2 + GOTO 200 + ELSE + MQWRTLST(NS)=M1 + ENDIF + TDIFF=TQWRSER(M2,NS)-TQWRSER(M1,NS) + WTM1=(TQWRSER(M2,NS)-CTIM)/TDIFF + WTM2=(CTIM-TQWRSER(M1,NS))/TDIFF + QWRSERT(NS)=WTM1*QWRSER(M1,NS)+WTM2*QWRSER(M2,NS) + DO NC=1,NTMP + CQWRSERT(NS,NC)=WTM1*CQWRSER(M1,NS,NC)+WTM2*CQWRSER(M2,NS,NC) + ENDDO + ENDDO +C + MPI_WTIMES(1208)=MPI_WTIMES(1208)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +C + IF(NQWR.GT.0)THEN + DO NWR=1,NQWR + IU=IQWRU(NWR) + JU=JQWRU(NWR) + KU=KQWRU(NWR) + ID=IQWRD(NWR) + JD=JQWRD(NWR) + KD=KQWRD(NWR) + LU=LIJ(IU,JU) + LD=LIJ(ID,JD) + NS=NQWRSERQ(NWR) + QSUM(LU,KU)=QSUM(LU,KU)-QWR(NWR)-QWRSERT(NS) + QSUM(LD,KD)=QSUM(LD,KD)+QWR(NWR)+QWRSERT(NS) + ENDDO + ENDIF +C + MPI_WTIMES(1209)=MPI_WTIMES(1209)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +C +C ** CALL JPEFDC AND PLACE JET-PLUME VOLUMES SOURCES +C + IF(NQJPIJ.GT.0.AND.N.EQ.1) CALL JPEFDC + IF(NQJPIJ.GT.0.AND.ISTL_.EQ.3)THEN + IF(NUDJPC(1).EQ.NUDJP(1))THEN + CALL JPEFDC + NUDJPC(1)=1 + ELSE + NUDJPC(1)=NUDJPC(1)+1 + ENDIF + ENDIF + IF(NQJPIJ.GT.0.AND.IS2TIM.GE.1)THEN + IF(NUDJPC(1).EQ.NUDJP(1))THEN + CALL JPEFDC + NUDJPC(1)=1 + ELSE + NUDJPC(1)=NUDJPC(1)+1 + ENDIF + ENDIF +C + MPI_WTIMES(1210)=MPI_WTIMES(1210)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +C +C ** PLACE JET-PLUME VOLUMES SOURCES +C + IF(NQJPIJ.GT.0)THEN + DO NJP=1,NQJPIJ + IF(ICALJP(NJP).EQ.1)THEN + RPORTS=FLOAT(NPORTJP(NJP)) + LJP=LIJ(IQJP(NJP),JQJP(NJP)) + KTMP=KEFFJP(NJP) +C +C QVJPTMP = JETPLUME DISCHARGE PER PORT +C + QVJPTMP=QQCJP(NJP) + DO K=1,KC + QVJPTMP=QVJPTMP+QSERT(K,NQSERJP(NJP)) + ENDDO +C +C SUBTRACT THE ENTRAINMENT FROM EACH LAYER +C + DO K=1,KC + QSUM(LJP,K)=QSUM(LJP,K)-RPORTS*QJPENT(K,NJP) + ENDDO +C +C PLACE DISCHARGE AND TOTAL ENTRAINMENT AT EFFECTIVE LOCATION +C + QSUM(LJP,KTMP)=QSUM(LJP,KTMP)+RPORTS*(QVJPTMP+QJPENTT(NJP)) + ENDIF + IF(ICALJP(NJP).EQ.2)THEN + RPORTS=FLOAT(NPORTJP(NJP)) + LJP=LIJ(IQJP(NJP),JQJP(NJP)) + KTMP=KEFFJP(NJP) +C +C QVJPTMP = JETPLUME DISCHARGE PER PORT +C + QVJPTMP=QWRCJP(NJP)+QWRSERT(NQWRSERJP(NJP)) +C +C SUBTRACT ENTRAIMENT FROM EACH LAYER +C + DO K=1,KC + QSUM(LJP,K)=QSUM(LJP,K)-RPORTS*QJPENT(K,NJP) + ENDDO +C +C PLACE DISCHARGE AND TOTAL ENTRAINMENT AT EFFECTIVE LOCATION +C + QSUM(LJP,KTMP)=QSUM(LJP,KTMP)+RPORTS*(QVJPTMP+QJPENTT(NJP)) +C +C REMOVE DISCHARGE FROM UPSTREAM INTAKE CELL +C + LU=LIJ(IUPCJP(NJP),JUPCJP(NJP)) + KU=KUPCJP(NJP) + QSUM(LU,KU)=QSUM(LU,KU)-RPORTS*QVJPTMP + ENDIF + ENDDO + ENDIF +C + MPI_WTIMES(1211)=MPI_WTIMES(1211)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +C +C ** GROUND WATER INTERACTION, EVAPORATION AND RAINFALL +C + IF(ISGWIE.EQ.0)THEN + IF(EVAPCVT.LT.0.)THEN + DO L=2,LA + SVPW=(10.**((0.7859+0.03477*TEM(L,KC))/ + & (1.+0.00412*TEM(L,KC)))) + EVAPT(L)=CLEVAP(L)*0.7464E-3*WINDST(L)*(SVPW-VPA(L))/PATMT(L) + IF(HP(L).LT.HWET) EVAPT(L)=0. + QSUM(L,KC)=QSUM(L,KC)+DXYP(L)*(RAINT(L)-EVAPT(L)) + ENDDO + ELSE + DO L=2,LA + IF(HP(L).LT.HWET) EVAPT(L)=0. + QSUM(L,KC)=QSUM(L,KC)+DXYP(L)*(RAINT(L)-EVAPT(L)) + ENDDO + ENDIF + ELSE + DO L=2,LA + QSUM(L,KC)=QSUM(L,KC)+DXYP(L)*RAINT(L) + ENDDO + ENDIF +C +C ** DETERMINE NET EXTERNAL VOLUME SOURCE/SINK +C + DO K=1,KC + DO L=1,LC + QSUME(L)=QSUME(L)+QSUM(L,K) + ENDDO + ENDDO +C + MPI_WTIMES(1212)=MPI_WTIMES(1212)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +C +C ** UPDATE ZERO DIMENSION VOLUME BALANCE +C VOLADD=0. +C ** WRITE DIAGNOSTIC FILE FOR VOLUME SOURCES,SINKS, ETC +C + ITMPD=0 + IF(ISDIQ.EQ.2.AND.ISTL_.EQ.2) ITMPD=1 + IF(ISDIQ.EQ.1) ITMPD=1 + NTT=4+NTOX+NSED+NSND + IF(ITMPD.EQ.1.AND.DEBUG)THEN + IF(MYRANK.EQ.0)THEN + IF(N.EQ.NTSPTC.OR.N.EQ.1)THEN + OPEN(1,FILE='QDIAG.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='QDIAG1.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='QDIAG1.OUT',STATUS='UNKNOWN') + ELSE + OPEN(1,FILE='QDIAG.OUT',POSITION='APPEND',STATUS='UNKNOWN') + ENDIF + WRITE(1,101)N + DO LL=1,NQSIJ + NQSTMP=NQSERQ(LL) + NCSTMP=NCSERQ(LL,1) + L=LQS(LL) + I=IL(L) + J=JL(L) + WRITE(1,102)I,J + WRITE(1,216)LL,L,(QSS(K,LL),K=1,KC) + DO NT=1,NTT + WRITE(1,217)LL,NT,(CQS(K,LL,NT),K=1,KC) + ENDDO + WRITE(1,104) + WRITE(1,105)I,J + WRITE(1,206)LL,L,(QSERCELL(K,LL),K=1,KC) + DO NT=1,NTT + NCSTMP=NCSERQ(LL,NT) + WRITE(1,207)LL,NT,NCSTMP,(CSERT(K,NCSTMP,NT),K=1,KC) + ENDDO + WRITE(1,104) + ENDDO + DO NCTL=1,NQCTL + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + NCTLT=NQCTLQ(NCTL) + IF(IU.EQ.0.AND.JU.EQ.0)THEN + LU=0 + HUP=0. + ELSE + LU=LIJ(IU,JU) + HUP=HP(LU)+BELV(LU)+HCTLUA(NCTLT) + ENDIF + IF(ID.EQ.0.AND.JD.EQ.0)THEN + LD=0 + HDW=0. + ELSE + LD=LIJ(ID,JD) + HDW=HP(LD)+BELV(LD)+HCTLDA(NCTLT) + ENDIF + WRITE(1,107)IU,JU,LU,NCTLT,HUP + DO K=1,KC + WRITE(1,108)K,QCTLT(K,NCTL) + ENDDO + WRITE(1,104) + WRITE(1,109)ID,JD,LD,NCTLT,HDW + DO K=1,KC + WRITE(1,108)K,QCTLT(K,NCTL) + ENDDO + WRITE(1,104) + ENDDO + DO NWR=1,NQWR + IU=IQWRU(NWR) + JU=JQWRU(NWR) + KU=KQWRU(NWR) + ID=IQWRD(NWR) + JD=JQWRD(NWR) + KD=KQWRD(NWR) + LU=LIJ(IU,JU) + LD=LIJ(ID,JD) + NQSTMP=NQWRSERQ(NWR) + WRITE(1,110)IU,JU + WRITE(1,111)KU,QWR(NWR),CQWR(NWR,1),CQWR(NWR,2) + WRITE(1,104) + WRITE(1,112)ID,JD + WRITE(1,111)KD,QWR(NWR),CQWR(NWR,1),CQWR(NWR,2) + WRITE(1,104) + WRITE(1,113)IU,JU + WRITE(1,114)KU,QWRSERT(NQSTMP),CQWRSERT(NQSTMP,1), + & CQWRSERT(NQSTMP,2) + WRITE(1,104) + WRITE(1,115)ID,JD + WRITE(1,114)KD,QWRSERT(NQSTMP),CQWRSERT(NQSTMP,1), + & CQWRSERT(NQSTMP,2) + WRITE(1,104) + ENDDO + CLOSE(1) + ENDIF + ENDIF +C + MPI_WTIMES(1213)=MPI_WTIMES(1213)+MPI_TOC(S1TIME) +C + 101 FORMAT(' SOURCE/SINK DIAGNOSTICS AT TIME STEP =',I8,//) + 102 FORMAT(3X,'CONST NQSIJ SOURCE/SINK FLOW AT I =',I5,' J =',I5,/) +C 103 FORMAT(5X,'K =',I5,5X,'QSS(K) = ',E12.4,5X,'CQS(K,1) = ',E12.4, +C & 5X,'CQS(K,5) = ',E12.4) +C 203 FORMAT(5X,'K =',I5,5X,'QSS(K) = ',E12.4,5X,'CQS(K, ) = ', +C & 5X, 12E12.4) + 104 FORMAT(/) + 105 FORMAT(3X,'TIME VAR NQSIJ SOURCE/SINK FLOW AT I =',I5,' J=',I5,/) +C 106 FORMAT(5X,'K =',I5,5X,'QSERT(K) = ',E12.4, +C & 5X,'CSERT(K,1) = ',E12.4,5X,'CSERT(K,5) = ',E12.4) + 206 FORMAT(5X,'NQ,LQ =',2I4,7X,'QSERT() = ',12E12.4) + 207 FORMAT(5X,'NQ,NT,NCQ =',3I4,3X,'CSERT() = ',12E12.4) + 216 FORMAT(5X,'NQ,LQ =',2I4,3X,'QSS() = ',12E12.4) + 217 FORMAT(5X,'NQ,NT =',2I4,3X,'CQS() = ',12E12.4) + 107 FORMAT(3X,'UPSTRM CONTROLED SINK FLOW AT I =',I5,' J =',I5, + & ' L =',I5,' NQCTLT =',I5,' HUP = ',E12.4/) + 108 FORMAT(5X,'K =',I5,5X,'QCTL(K) = ',2E12.4) + 109 FORMAT(3X,'DWNSTRM CONTROLED SOURCE FLOW AT I =',I5,' J =',I5, + & ' L =',I5,' NQCTLT =',I5,' HDW = ',E12.4/) + 110 FORMAT(3X,'UPSTRM CONST WITHDRW SINK FLOW AT I =',I5,' J =',I5,/) + 111 FORMAT(5X,'K =',I5,5X,'QWR(K) = ',E12.4, + & 5X,'CQWR(1) = ',E12.4,5X,'CQWR(2) = ',E12.4) + 112 FORMAT(3X,'DWNSTRM CONST RETN SOURCE FLOW AT I =',I5,' J =',I5,/) + 113 FORMAT(3X,'UPSTRM VAR WITHDRW SINK FLOW AT I =',I5,' J =',I5,/) + 114 FORMAT(5X,'K =',I5,5X,'QSERT(K) = ',E12.4, + & 5X,'CSERT(K,1) = ',E12.4,5X,'CSERT(K,2) = ',E12.4) + 115 FORMAT(3X,'DWNSTRM VAR RETN SOURCE FLOW AT I =',I5,' J =',I5,/) + 6666 FORMAT(' SINGLE VAL CONTROL STRUCTURE TABLE OUT OF BOUNDS ') + 6667 FORMAT(' NCTL,NCTLT,IU,JU,ID,JD = ',6I5) + 6668 FORMAT(' SELU,HU,SELD,HD = ',4(2X,E12.4)) + 6676 FORMAT(' DOUBLE VAL CONTROL STRUCTURE TABLE OUT OF BOUNDS, UP ') + 6677 FORMAT(' NCTL,NCTLT,IU,JU,ID,JD = ',6I5) + 6678 FORMAT(' SELU,HU,SELD,HD = ',4(2X,E12.4)) + 6679 FORMAT(' HUF,HUL,HDF,HDL = ',4(2X,E12.4)) + 6686 FORMAT(' DOUBLE VAL CONTROL STRUCTURE TABLE OUT OF BOUNDS, DW ') + 6687 FORMAT(' NCTL,NCTLT,IU,JU,ID,JD = ',6I5) + 6688 FORMAT(' SELU,HU,SELD,HD = ',4(2X,E12.4)) + 6111 FORMAT(' INVALID NQSIJ LOCATION, NQSIJ,I,J = ',3I5) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSED.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSED.for index ce021ebcd..85d555859 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSED.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSED.for @@ -5,6 +5,7 @@ C ** SUBROUTINE CALSED CALCULATES COHESIVE SEDIMENT SETTLING, C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX C USE GLOBAL + USE MPI C C**********************************************************************C C @@ -802,7 +803,7 @@ C C C WRITE(11,6111)TIME,(WSETA(857,K,1),K=0,KS) C WRITE(41,6111)TIME,(STRESSS(K),K=0,KS) - 6111 FORMAT(F10.2,10E12.4) +C6111 FORMAT(F10.2,10E12.4) C C----------------------------------------------------------------------C C @@ -1053,6 +1054,7 @@ CDIAG 104 FORMAT(' N,NS,I,J,SEDBMN,SEDBSMN = ',4I5,4E13.4) CDIAG 105 FORMAT(' N,NS,I,J,SEDFMX,SEDFSMX = ',4I5,4E13.4) CDIAG 106 FORMAT(' N,NS,I,J,SEDFMN,SEDFSMN = ',4I5,4E13.4) C + IF(DEBUG.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='NEGSEDSND.OUT',POSITION='APPEND') C DO NS=1,NSED @@ -1060,7 +1062,8 @@ C DO L=2,LA IF(SED(L,K,NS).LT.-1.0)THEN WRITE(1,107)TIME,NS,IL(L),JL(L),K,SED(L,K,NS) - PAUSE + PRINT *, "Application suspended. Hit ENTER to continue" + READ(*,*) ENDIF ENDDO ENDDO @@ -1071,12 +1074,14 @@ C IF(SEDB(L,KBT(L),NS).LT.0.)THEN WRITE(1,108)TIME,NS,IL(L),JL(L),KBT(L),SEDB(L,KBT(L),NS), & SEDF(L,0,NS) - PAUSE + PRINT *, "Application suspended. Hit ENTER to continue" + READ(*,*) ENDIF ENDDO ENDDO C CLOSE(1) + ENDIF C C ** ACCUMULATE NET POSTIVE AND NEGATIVE COHESIVE SEDIMENT FLUXES C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSFT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSFT.for index f7de783cf..f80031a1d 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSFT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSFT.for @@ -10,6 +10,8 @@ C ! *** DSLLC BEGIN BLOCK REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WTFKB REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WTFKC + INTEGER ISDARK + ISDARK=0 IF(.NOT.ALLOCATED(WTFKB))THEN ALLOCATE(WTFKB(KCM)) ALLOCATE(WTFKC(KCM)) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSFT_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSFT_mpi.for new file mode 100644 index 000000000..b685f9d1a --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSFT_mpi.for @@ -0,0 +1,354 @@ + SUBROUTINE CALSFT_mpi(ISTL_,IS2TL_) +C +C CHANGE RECORD +C ** SUBROUTINE CALSFT CALCULATES THE TRANSPORT OF SHELL FISH LARVAE +C ** AT TIME LEVEL (N+1). +C ** CALLED ONLY ON ODD THREE TIME LEVEL STEPS (PMC - NO, CALLED IN BOTH HDMT & HDMT2T) +C + USE GLOBAL + USE MPI + + ! *** DSLLC BEGIN BLOCK + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WTFKB + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WTFKC + INTEGER ISDARK + ISDARK=0 + IF(.NOT.ALLOCATED(WTFKB))THEN + ALLOCATE(WTFKB(KCM)) + ALLOCATE(WTFKC(KCM)) + ! *** ZERO LOCAL ARRAYS + WTFKB=0.0 + WTFKC=0.0 + ENDIF + ! *** DSLLC END BLOCK +C +CPMC DELT=DT2 + ! *** PMC + IF(ISTL_.EQ.2)THEN + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + ELSE + DELT=DTDYN + END IF + ELSE + DELT=DT2 + ENDIF + ! *** PMC +C +C ** UPDATED TIME SERIES CONCENTRATION BOUNDARY CONDITIONS +C ** DETERMINE IF CURRENT TIME STEP IS DURING DAYLIGHT OR DARKNESS +C + IF(ISSFLDN.GE.1)THEN + ISDARK=1 + IF(ISDYNSTP.EQ.0)THEN + TIME=(DT*FLOAT(N)+TCON*TBEGIN)/86400. + ELSE + TIME=TIMESEC/86400. + ENDIF + ITIME=INT(TIME) + RTIME=FLOAT(ITIME) + TIMTMP=TIME-RTIME + IF(TIMTMP.GE.TSRSF.AND.TIMTMP.LE.TSSSF) ISDARK=0 + ENDIF +C +C ** DETERMINE IF LOCAL CONDITIONS ARE EBB OR FLOOD +C + IF(ISSFLFE.GE.1)THEN + IF(KC.EQ.1)THEN + WTFKB(1)=1. + WTFKC(1)=0. + ENDIF + IF(KC.EQ.2)THEN + WTFKB(1)=1.0 + WTFKC(1)=0.0 + WTFKB(2)=0.0 + WTFKC(2)=1.0 + ENDIF + IF(KC.EQ.3)THEN + DO K=1,KC + WTFKB(K)=FLOAT(KC-K)/FLOAT(KS) + WTFKC(K)=1.0-WTFKB(K) + ENDDO + ENDIF +C +C ** SET SWITCHES TO EBB +C + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UUU(L,K)=0. + VVV(L,K)=1. + ENDDO + ENDDO +C +C ** RESET SWITCHES FOR FLOOD +C + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LN,FANGTMP,UTMP,VTMP, +!$OMP+ VELEKB,VELNKB,CURANG,ANGDIF) + DO L=LMPI2,LMPILA + LN=LNC(L) + FANGTMP=ACCWFLD(L,1)*WTFKB(K)+ACCWFLD(L,2)*WTFKC(K) + UTMP=0.5*STCUV(L)*(UWQ(L+1,K)+UWQ(L,K)) + VTMP=0.5*STCUV(L)*(VWQ(LN ,K)+VWQ(L,K)) + VELEKB=CUE(L)*UTMP+CVE(L)*VTMP+1.E-12 + VELNKB=CUN(L)*UTMP+CVN(L)*VTMP + CURANG=ATAN2(VELNKB,VELEKB) + ANGDIF=ABS(FANGTMP-CURANG) + IF(ANGDIF.LT.1.5708)THEN + UUU(L,K)=1. + VVV(L,K)=0. + ENDIF + ENDDO + ENDDO + ENDIF +C +C ** SET UP ADVECTION FIELD +C ** SET ATTACHED TO BOTTOM AND NO ADVECTIVE TRANSPORT IN BOTTOM +C ** LAYER DURING EBB IF APPROPRIATE +C + IF(ISSFLFE.GE.1)THEN + IF(SFNTBET.LT.1.)THEN + K=1 +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + LN=LNC(L) + UHDYWQ(L,K)=UUU(L,1)*UHDYWQ(L,1)+SFNTBET*VVV(L,1)*UHDYWQ(L,1) + VHDXWQ(L,K)=UUU(L,1)*UHDYWQ(L,1)+SFNTBET*VVV(L,1)*VHDXWQ(L,1) + UWQ(L,K)=UUU(L,1)*UWQ(L,1)+SFNTBET*VVV(L,1)*UWQ(L,1) + VWQ(L,K)=UUU(L,1)*VWQ(L,1)+SFNTBET*VVV(L,1)*VWQ(L,1) + ENDDO + ENDIF + ENDIF + ! *** COMPUTE SHELLFISH LARVAE ADVECTION + CALL CALTRAN_mpi (ISTL_,IS2TL_,4,4,SFL,SFL2) + !CALL CALTRWQ (4,0,SFL,SFL2) ! PMC +C +C ** SET UP VERTICAL MIGRATION AND SETTLING BEHAVIOR +C ** INITIALIZE VERTICAL VELOCTIY TO TIME DEPENDENT SETTLING VELOCITY +C + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WWQ(L,K)=-WSFLSTT + ENDDO + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WWQ(L,KC)=0. + WWQ(L,0)=0. + ENDDO + IF(ISSFLFE.GE.1.AND.ISSFLDN.GE.1)THEN +C +C ** DAYLIGHT CONDITIONS +C + IF(ISDARK.EQ.0)THEN + DO K=1,KS + RABOVE=FLOAT(KC-K)/FLOAT(KC) +!$OMP PARALLEL DO PRIVATE(HABOVE) + DO L=LMPI2,LMPILA +C +C ** DETERMINE DISTANCE TO SURFACE +C + HABOVE=RABOVE*HWQ(L) + IF(UUU(L,K).GT.0.)THEN +C +C ** FLOOD CONDITION : SWIM UP TO MIN DIST BELOW SURFACE +C + IF(HABOVE.GT.DSFLMNT) WWQ(L,K)=WSFLSMT + ELSE +C +C ** EBB CONDITION : CONTINUE TO SINK OR SWIM UP TO MAX DIST BL SURF +C + IF(HABOVE.GT.DSFLMXT) WWQ(L,K)=WSFLSMT + ENDIF + ENDDO + ENDDO + ENDIF +C +C ** DARK CONDITIONS +C + IF(ISDARK.EQ.1)THEN + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA +C +C ** FLOOD CONDITION : SWIM UP TO SURFACE +C + WWQ(L,K)=VVV(L,K)*WWQ(L,K)+UUU(L,K)*WSFLSMT + ENDDO + ENDDO + ENDIF + ENDIF + IF(SFATBTT.GT.0.)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WWQ(L,0)=-WSFLSTT + ENDDO + ENDIF +C +C ** CALCULATE NET VERTICAL SWIMING OR SETTLING +C + IF(WSFLSMT.EQ.0.) GOTO 100 +C +C ** LIMIT VERTICAL SETTLING AND/OR SWIMMING FOR STABILITY +C + DO K=0,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WWW(L,K)=MIN(WWQ(L,K),0.) + WWW(L,K)=ABS(WWW(L,K)) + WWQ(L,K)=MAX(WWQ(L,K),0.) + ENDDO + ENDDO + TMPVAL=0.25/(DELT*FLOAT(KC)) + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(WMAXX) + DO L=LMPI2,LMPILA + WMAXX=TMPVAL*HWQ(L) + WWW(L,K)=MIN(WWW(L,K),WMAXX) + WWQ(L,K)=MIN(WWQ(L,K),WMAXX) + WWQ(L,K)=WWQ(L,K)-WWW(L,K) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FWU(L,K)=MAX(WWQ(L,K),0.)*SFL(L,K) + & +MIN(WWQ(L,K),0.)*SFL(L,K+1) + ENDDO + ENDDO + IF(SFATBTT.GT.0.)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SFLSBOT(L)=SFLSBOT(L)-DELT*FWU(L,0) + ENDDO + ENDIF + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SFL(L,K)=SFL(L,K) + & +DELT*(FWU(L,K-1)-FWU(L,K))*DZIC(K)/HWQ(L) + ENDDO + ENDDO + GOTO 200 + 100 CONTINUE +C +C ** FULLY IMPLICIT SETTLING IF SWIMMING IS ZERO EVERYWHERE +C ** FULLY IMPLICIT SETTLING IN SURFACE LAYER +C + TMPVAL=DELT*WSFLSTT + DZCIT=TMPVAL/DZC(KC) +!$OMP PARALLEL DO PRIVATE(TMPVAL1) + DO L=LMPI2,LMPILA + TMPVAL1=DZCIT/HWQ(L) + SFL(L,KC)=SFL(L,KC)/(1.+TMPVAL1) + ENDDO +C +C ** FULLY IMPLICIT SETTLING IN REMAINING LAYERS +C + IF(KC.GT.1)THEN + DO K=KS,1,-1 + DZCIT=TMPVAL/DZC(K) +!$OMP PARALLEL DO PRIVATE(TMPVAL1) + DO L=LMPI2,LMPILA + TMPVAL1=DZCIT/HWQ(L) + SFL(L,K)=(SFL(L,K)+TMPVAL1*SFL(L,K+1))/(1.+TMPVAL1) + ENDDO + ENDDO + ENDIF + IF(SFATBTT.GT.0.)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SFLSBOT(L)=SFLSBOT(L)+TMPVAL*SFL(L,1) + ENDDO + ENDIF + 200 CONTINUE +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FWU(L,0)=0. + WWQ(L,0)=0. + WWW(L,0)=0. + ENDDO +C +C ** CALCULATE LINEAR DECAY +C + IF(RKDSFLT.GE.0.)THEN + CDYETMP=1./(1.+DELT*RKDSFLT) + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SFL(L,K)=CDYETMP*SFL(L,K) + ENDDO + ENDDO + ENDIF + IF(KC.EQ.1) GOTO 2000 +C +C ** VERTICAL DIFFUSION CALCULATION +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + HWQI(L)=1./HWQ(L) + ENDDO + RCDZKK=-DELT*CDZKK(1) + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO L=LF,LL + CCUBTMP=RCDZKK*HWQI(L)*AB(L,1) + CCMBTMP=1.-CCUBTMP + EEB=1./CCMBTMP + CU1(L,1)=CCUBTMP*EEB + SFL(L,1)=SFL(L,1)*EEB + ENDDO + ENDDO + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO K=2,KS + RCDZKMK=-DELT*CDZKMK(K) + RCDZKK=-DELT*CDZKK(K) + DO L=LF,LL + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCUBTMP=RCDZKK*HWQI(L)*AB(L,K) + CCMBTMP=1.-CCLBTMP-CCUBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + CU1(L,K)=CCUBTMP*EEB + SFL(L,K)=(SFL(L,K)-CCLBTMP*SFL(L,K-1))*EEB + ENDDO + ENDDO + ENDDO + K=KC + RCDZKMK=-DELT*CDZKMK(K) + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO L=LF,LL + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCMBTMP=1.-CCLBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + SFL(L,K)=(SFL(L,K)-CCLBTMP*SFL(L,K-1))*EEB + ENDDO + ENDDO + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO K=KC-1,1,-1 + DO L=LF,LL + SFL(L,K)=SFL(L,K)-CU1(L,K)*SFL(L,K+1) + ENDDO + ENDDO + ENDDO +C +C ** UPDATE SHELL FISH LARVAE CONCENTRATIONS +C + 2000 CONTINUE + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + SFL2(L,K)=SFL(L,K) + ENDDO + ENDDO + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSND.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSND.for index 12ffb7379..ed67b6ae5 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSND.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSND.for @@ -5,10 +5,11 @@ C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING, C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX C USE GLOBAL + USE MPI IMPLICIT NONE REAL::TIME,GRADSED,SIGP,CRNUM,DUM1,DUM3,DUM4,DIASED3 - REAL::CSDNSET,FSEDMODE,CSNDZEQ,ZEQMIN,CSNDEQC,CSHIELDS,TMPVAL + REAL::FSEDMODE,CSNDZEQ,ZEQMIN,CSNDEQC,CSHIELDS,TMPVAL REAL::CSNDSET,SHIELDS,TOP,BOT,WSFAC,WESE,WESEMX REAL::PROBDEP,WSETMP,WVEL,CLEFT,CRIGHT,SNDBTMP,SEDAVG REAL::AA11,AA12,AA21,AA22,BB11,BB22,DETI,FLUXFAC @@ -181,7 +182,7 @@ C C ENDIF C - 888 FORMAT(2I5,6E12.4) +C 888 FORMAT(2I5,6E12.4) C C**********************************************************************C C @@ -1311,7 +1312,7 @@ C C C**********************************************************************C C - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN IFLAG=0 DO NS=1,NSND DO K=1,KC diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSTEP.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSTEP.for index 35f6c9eb7..b9981af93 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSTEP.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSTEP.for @@ -5,12 +5,21 @@ C ** SUBROUTINE CALSTEP ESTIMATE THE CURRENT MAXIMUM TIME STEP SIZE C ** FORM LINEAR STABILITY CRITERIA AND A FACTOR OF SAFETY C USE GLOBAL + USE MPI REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL1 REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL2 REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL3 REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::QSUBINN REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::QSUBOUT + REAL DTCOMP + REAL QVKTMP + REAL QUKTMP + INTEGER LLOC + LLOC = 0 + DTCOMP = 0.0 + QVKTMP = 0.0 + QUKTMP = 0.0 IF(.NOT.ALLOCATED(DTL1))THEN ALLOCATE(DTL1(LCM)) ALLOCATE(DTL2(LCM)) @@ -139,7 +148,7 @@ C IF(BOT.GT.0.0)THEN DTTMP=TOP/BOT DTL2(L)=MIN(DTL2(L),DTTMP) - IF(DTTMP.LT.0.0)THEN + IF(DTTMP.LT.0.0.AND.MYRANK.EQ.0)THEN WRITE(6,880)IL(L),JL(L),K,TOP,QXPLUS,QYPLUS,QZPLUS, & QXMINS,QYMINS,QZMINS,QSRC WRITE(8,880)IL(L),JL(L),K,TOP,QXPLUS,QYPLUS,QZPLUS, @@ -228,6 +237,7 @@ C ** MAKE A MULTIPLE OF OF DTMIN C TIMEDAY=TIMESEC/86400. IF(DTCOMP.LT.DTMIN)THEN ! *** DSLLC SINGLE LINE + IF(MYRANK.EQ.0)THEN WRITE(8,800)TIMEDAY,DTTMP,DTMIN,IL(LLOC),JL(LLOC) WRITE(6,800)TIMEDAY,DTTMP,DTMIN,IL(LLOC),JL(LLOC) WRITE(8,801)IL(L1LOC),JL(L1LOC),DTL1MN @@ -236,6 +246,7 @@ C WRITE(6,802)IL(L2LOC),JL(L2LOC),DTL2MN WRITE(8,803)IL(L3LOC),JL(L3LOC),DTL3MN WRITE(6,803)IL(L3LOC),JL(L3LOC),DTL3MN + ENDIF DTTMP=DTMIN C *** DSLLC BEGIN BLOCK ELSEIF(DTTMP.LT.DTMIN)THEN @@ -273,7 +284,7 @@ C C ** ADJUST INCREMENT FOR N TO LAND EVENLY ON NTSPTC C RTCTMP=FLOAT(N)/FLOAT(NTSPTC) - NTCTMP=RTCTMP + NTCTMP=INT(RTCTMP,KIND(NTCTMP)) NTMP=(1+NTCTMP)*NTSPTC-N IF(NINCRMT.GT.NTMP)THEN NINCRMT=NTMP @@ -282,14 +293,14 @@ C C C ** WRITE TO TIME STEP LOG FILE C - 100 FORMAT(5I5,5F12.5,E13.5) - 101 FORMAT(3I5,E13.5) +C 100 FORMAT(5I5,5F12.5,E13.5) +C 101 FORMAT(3I5,E13.5) 800 FORMAT(' TIME,DTDYN,DTMIN,I,J = ',F12.5,2E12.4,2I7) 801 FORMAT(' MOM ADV,I,J,DTM = ',2I5,E13.4) 802 FORMAT(' MASS ADV,I,J,DTM = ',2I5,E13.4) 803 FORMAT(' CURV ACC,I,J,DTM = ',2I5,E13.4) 880 FORMAT(3I5,8E13.4) - 8899 FORMAT(' DT3 ERROR ',2I5,6E13.5) +C8899 FORMAT(' DT3 ERROR ',2I5,6E13.5) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSTEPD.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSTEPD.for index d78b07fcf..d7d85aef9 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSTEPD.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALSTEPD.for @@ -5,12 +5,21 @@ C ** SUBROUTINE CALSTEP ESTIMATE THE CURRENT MAXIMUM TIME STEP SIZE C ** FORM LINEAR STABILITY CRITERIA AND A FACTOR OF SAFETY C USE GLOBAL + USE MPI REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL1 REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL2 REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DTL3 REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::QSUBINN REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::QSUBOUT + REAL DTCOMP + REAL QVKTMP + REAL QUKTMP + INTEGER LLOC + LLOC = 0 + DTCOMP = 0.0 + QVKTMP = 0.0 + QUKTMP = 0.0 IF(.NOT.ALLOCATED(DTL1))THEN ALLOCATE(DTL1(LCM)) ALLOCATE(DTL2(LCM)) @@ -148,7 +157,7 @@ C IF(BOT.GT.0.0)THEN DTTMP=TOP/BOT DTL2(L)=MIN(DTL2(L),DTTMP) - IF(DTTMP.LT.0.0)THEN + IF(DTTMP.LT.0.0.AND.MYRANK.EQ.0)THEN WRITE(6,880)IL(L),JL(L),K,TOP,QXPLUS,QYPLUS,QZPLUS, & QXMINS,QYMINS,QZMINS,QSRC WRITE(8,880)IL(L),JL(L),K,TOP,QXPLUS,QYPLUS,QZPLUS, @@ -245,6 +254,7 @@ c CACAMP=SQRT(1.+CACDTMX*CACDTMX) C TIMEDAY=TIMESEC/86400. IF(DTCOMP.LT.DTMIN)THEN ! *** DSLLC SINGLE LINE + IF(MYRANK.EQ.0)THEN WRITE(8,800)TIMEDAY,DTTMP,DTMIN,IL(LLOC),JL(LLOC) WRITE(6,800)TIMEDAY,DTTMP,DTMIN,IL(LLOC),JL(LLOC) WRITE(8,801)IL(L1LOC),JL(L1LOC),DTL1MN @@ -253,6 +263,7 @@ C WRITE(6,802)IL(L2LOC),JL(L2LOC),DTL2MN WRITE(8,803)IL(L3LOC),JL(L3LOC),DTL3MN WRITE(6,803)IL(L3LOC),JL(L3LOC),DTL3MN + ENDIF DTTMP=DTMIN C *** DSLLC BEGIN BLOCK ELSEIF(DTTMP.LT.DTMIN)THEN @@ -295,21 +306,21 @@ C C ** ADJUST INCREMENT FOR N TO LAND EVENLY ON NTSPTC C RTCTMP=FLOAT(N)/FLOAT(NTSPTC) - NTCTMP=RTCTMP + NTCTMP=INT(RTCTMP,KIND(NTCTMP)) NTMP=(1+NTCTMP)*NTSPTC-N IF(NINCRMT.GT.NTMP)THEN NINCRMT=NTMP DTDYN=FLOAT(NTMP)*DTMIN ENDIF C - 100 FORMAT(5I5,5F12.5,E13.5) - 101 FORMAT(3I5,E13.5) +C 100 FORMAT(5I5,5F12.5,E13.5) +C 101 FORMAT(3I5,E13.5) 800 FORMAT(' TIME,DTDYN,DTMIN,I,J = ',F12.5,2E12.4,2I7) 801 FORMAT(' MOM ADV,I,J,DTM = ',2I5,E13.4) 802 FORMAT(' MASS ADV,I,J,DTM = ',2I5,E13.4) 803 FORMAT(' CURV ACC,I,J,DTM = ',2I5,E13.4) 880 FORMAT(3I5,8E13.4) - 8899 FORMAT(' DT3 ERROR ',2I5,6E13.5) +C8899 FORMAT(' DT3 ERROR ',2I5,6E13.5) C C**********************************************************************C C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTBXY.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTBXY.for index f1a75d126..ff2c04c03 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTBXY.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTBXY.for @@ -27,15 +27,19 @@ C REAL::FRACLAY,FHLAYC,FHLAYW,FHLAYS,WCHAN,RLCHN,HCHAN,STBXCH REAL::FXVEGCH,STBYCH,FYVEGCH,TMPVALW,WVFACT,QQWCTMP,TWCTMP REAL::AEXTMP,TMPVAL,USTARC,CDRGTMP,TAUBTMP,TAUE,RIPAMP - REAL::TAUBTM,RIPSTP,RIPFAC,ZBRMAX,ZBRMIN,CDRGMAX,ZBREU + REAL::RIPSTP,RIPFAC,ZBRMAX,ZBRMIN,CDRGMAX,ZBREU REAL::CDRGMIN,WVDTMP,RKZTURB,UTMP,VTMP,DWVDZ,DWUDZ,DWVD2Z REAL::DWUD2Z,HZRVDZ,HZRUDZ,ZDHZRV,ZDHZRU,ZBREV,HZREFV,HZREFU REAL::QWDQCV,QWDQCU,QCTMPV,QCTMPU,HOTLYMN,HOTLYMX,CDTMPVY REAL::BOTTMP,DWVDHR,DWUDHR,QWCTMPV,QWCTMPU REAL::CDTMPV,CDTMPU,COSWC,CURANG,CDTMPUX REAL::WVDELV,WVDELU,TAUTMP - INTEGER::LF,LL,ithds - REAL::t00,rtc + + LZBMIN=0 + LZBMAX=0 + LCDMIN=0 + LCDMAX=0 + WVDTMP=0.0 DELT=DT2 ISUD=1 @@ -80,35 +84,20 @@ C OPEN(1,FILE='CBOT.LOG',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') ENDIF -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA STBXO(L)=STBX(L) STBYO(L)=STBY(L) ENDDO -c - enddo -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - DO L=LF,LL + DO L=1,LC STBX(L)=0. STBY(L)=0. ENDDO DO K=1,KC - DO L=LF,LL + DO L=1,LC FXVEG(L,K)=0. FYVEG(L,K)=0. ENDDO ENDDO -c - enddo -C N=-2 JSTBXY=1 100 CONTINUE @@ -250,91 +239,7 @@ C VISEXP=2./7. VISFAC=0.0258*(COEFTSBL**VISEXP) C - IF(IDRYTBP.EQ.0)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& UMAGTMP,VMAGTMP,CDMAXU,CDMAXV,VISMUDU,VISMUDV,VISDHU,VISDHV, -!$OMP& SEDTMP) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL - IF(ZBR(L).LE.1.E-6)THEN - UMAGTMP=SQRT( U1(L,1)*U1(L,1)+V1U(L)*V1U(L)+1.E-12 ) - VMAGTMP=SQRT( U1V(L)*U1V(L)+V1(L,1)*V1(L,1)+1.E-12 ) - CDMAXU=CDLIMIT*STBXO(L)*H1U(L)/( DELT*UMAGTMP ) - CDMAXV=CDLIMIT*STBYO(L)*H1V(L)/( DELT*VMAGTMP ) - VISMUDU=VISMUD - VISMUDV=VISMUD - IF(ISMUD.GE.1)THEN - SEDTMP=0.5*(SED(L,1,1)+SED(L-1,1,1)) - VISMUDU=CSEDVIS(SEDTMP) - SEDTMP=0.5*(SED(L,1,1)+SED(LSC(L),1,1)) - VISMUDV=CSEDVIS(SEDTMP) - ENDIF -C ** DELETED COMMENTED OUT LINES & UNUSED VARIABLES - VISDHU=0.0 - VISDHV=0.0 - IF(UMAGTMP.GT.0.0) VISDHU=(VISMUDU*HUI(L)/UMAGTMP)*VISEXP - IF(VMAGTMP.GT.0.0) VISDHV=(VISMUDV*HVI(L)/VMAGTMP)*VISEXP - STBX(L)=VISFAC*AVCON*STBXO(L)*VISDHU - STBY(L)=VISFAC*AVCON*STBYO(L)*VISDHV - STBX(L)=MIN(CDMAXU,STBX(L)) - STBY(L)=MIN(CDMAXV,STBY(L)) - ENDIF - ENDDO -c - enddo -C -C ** END SMOOTH DRAG FORMULATION -C -C ** BEGIN ROUGH DRAG FORMULATION -C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LS,ZBRATU,ZBRATV, -!$OMP& UMAGTMP,VMAGTMP,CDMAXU,CDMAXV,HURTMP,HVRTMP,DZHUDZBR,DZHVDZBR) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL - LS=LSC(L) - IF(ZBR(L).GT.1.E-6)THEN - ZBRATU=0.5*(DXP(L-1)*ZBR(L-1)+DXP(L)*ZBR(L))*DXIU(L) - ZBRATV=0.5*(DYP(LS )*ZBR(LS )+DYP(L)*ZBR(L))*DYIV(L) - UMAGTMP=SQRT( U1(L,1)*U1(L,1)+V1U(L)*V1U(L)+1.E-12 ) - VMAGTMP=SQRT( U1V(L)*U1V(L)+V1(L,1)*V1(L,1)+1.E-12 ) - CDMAXU=CDLIMIT*STBXO(L)*H1U(L)/( DELT*UMAGTMP ) - CDMAXV=CDLIMIT*STBYO(L)*H1V(L)/( DELT*VMAGTMP ) - !IF(ISDYNSTP.GE.1)THEN ! PMC - !IF(IS2TIM.GE.1)THEN ! PMC - ! CDMAXU=1000. - ! CDMAXV=1000. - !END IF - HURTMP=MAX(ZBRATU,H1U(L)) - HVRTMP=MAX(ZBRATV,H1V(L)) - DZHUDZBR=1.+0.5*DZC(1)*HURTMP/ZBRATU - DZHVDZBR=1.+0.5*DZC(1)*HVRTMP/ZBRATV -C - STBX(L)=AVCON*STBXO(L)*.16/((LOG(DZHUDZBR))**2) - STBY(L)=AVCON*STBYO(L)*.16/((LOG(DZHVDZBR))**2) - STBX(L)=MIN(CDMAXU,STBX(L)) - STBY(L)=MIN(CDMAXV,STBY(L)) - ENDIF - ENDDO -c - enddo - - - ELSE -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& UMAGTMP,VMAGTMP,CDMAXU,CDMAXV,VISMUDU,VISMUDV,VISDHU,VISDHV, -!$OMP& SEDTMP) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN IF(ZBR(L).LE.1.E-6)THEN UMAGTMP=SQRT( U1(L,1)*U1(L,1)+V1U(L)*V1U(L)+1.E-12 ) @@ -361,21 +266,12 @@ C ** DELETED COMMENTED OUT LINES & UNUSED VARIABLES ENDIF ENDIF ENDDO -c - enddo C C ** END SMOOTH DRAG FORMULATION C C ** BEGIN ROUGH DRAG FORMULATION C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LS,ZBRATU,ZBRATV, -!$OMP& UMAGTMP,VMAGTMP,CDMAXU,CDMAXV,HURTMP,HVRTMP,DZHUDZBR,DZHVDZBR) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN LS=LSC(L) IF(ZBR(L).GT.1.E-6)THEN @@ -402,10 +298,7 @@ C ENDIF ENDIF ENDDO -c - enddo C - ENDIF C ** END ROUGH DRAG FORMULATION C IF(N.EQ.-2)THEN @@ -832,12 +725,12 @@ C ENDIF ENDIF 1948 CONTINUE - 1717 FORMAT(' N,I,J = ',I10,2I5,' CDTOTU,CDMAXU = ',2F15.10) - 1718 FORMAT(' N,I,J = ',I10,2I5,' CDTOTV,CDMAXV = ',2F15.10) - 1727 FORMAT(' N,I,J = ',I10,2I5,' LAM CDTOTU,CDMAXU = ',2F15.10) - 1728 FORMAT(' N,I,J = ',I10,2I5,' LAM CDTOTV,CDMAXV = ',2F15.10) - 1719 FORMAT(' N = ',I10,' CDTOTUM,CDTOTVM = ',2F15.10) - 1729 FORMAT(' N = ',I10,' CDMAXUM,CDMAXVM = ',2F15.10) +C1717 FORMAT(' N,I,J = ',I10,2I5,' CDTOTU,CDMAXU = ',2F15.10) +C1718 FORMAT(' N,I,J = ',I10,2I5,' CDTOTV,CDMAXV = ',2F15.10) +C1727 FORMAT(' N,I,J = ',I10,2I5,' LAM CDTOTU,CDMAXU = ',2F15.10) +C1728 FORMAT(' N,I,J = ',I10,2I5,' LAM CDTOTV,CDMAXV = ',2F15.10) +C1719 FORMAT(' N = ',I10,' CDTOTUM,CDTOTVM = ',2F15.10) +C1729 FORMAT(' N = ',I10,' CDMAXUM,CDMAXVM = ',2F15.10) 1739 FORMAT(' N,I,J = ',I10,2I5,' ZBRMAX,HBTLYMX = ',2E14.6) 1749 FORMAT(' N,I,J = ',I10,2I5,' ZBRMIN,HBTLYMN = ',2E14.6) 1759 FORMAT(' N,I,J = ',I10,2I5,' CDRGMAX,STBX,STBY = ',3E14.6) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTBXY_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTBXY_mpi.for new file mode 100644 index 000000000..cafa16b1f --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTBXY_mpi.for @@ -0,0 +1,795 @@ + SUBROUTINE CALTBXY_mpi(ISTL_,IS2TL_) +C +C ** SUBROUTINE CALTBXY CALCULATES BOTTOM FRICTION OR DRAG +C ** COEFFICIENTS IN QUADRATIC LAW FORM REFERENCED TO NEAR +C ** BOTTOM OR DEPTH AVERAGED HORIZONTAL VELOCITIES +C ** FOR VEGETATION RESISTANCE IN DEPTH INTEGRATED FLOW +C ** THE COEFFICIENT REPRESENTS BOTTOM AND WATER COLUMN VEGETATION +C ** RESISTANCE +C CHANGE RECORD +C REMOVED DRAG COEFFICIENT CONSTRAINT FOR MULIPLE LAYER ROUGHT +C BOUNDARIES WHEN DYNAMIC TIME STEPPING IS ACTIVE +C FIXED POSSIBLE DIVIDE BY ZERO FOR SUB GRID CHANNEL FRICTION IN +C ABSENCE OF VEGETATION RESISTANCE +C ADDED DRY CELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES +C + USE GLOBAL + USE MPI + + IMPLICIT NONE + INTEGER::ISTL_,IS2TL_,L,K,LS,M,LW,LE,LN,LNW,LSE,MW,MS + INTEGER::NMD,LHOST,LCHNU,LCHNV,MH,MU,MV,NTMP + INTEGER::LZBMIN,LCDMAX,LCDMIN,LZBMAX,JWCBLV,JWCBLU + REAL::CDLIMIT,CDTOTUM,CDTOTVM,CDMAXUM,CDMAXVM + REAL::ZBRATU,ZBRATV,UMAGTMP,VMAGTMP,CDMAXU,CDMAXV + REAL::HURTMP,HVRTMP,HUDZBR,HVDZBR,VTMPATU,UTMPATV,CPVEGU,RVEGUM + REAL::CPVEGV,RVEGVM,HVGTC,HVGTW,HVGTS,VISEXP,VISFAC,VISMUDU + REAL::VISMUDV,SEDTMP,CSEDVIS,VISDHU,VISDHV,DZHUDZBR,DZHVDZBR + REAL::FRACLAY,FHLAYC,FHLAYW,FHLAYS,WCHAN,RLCHN,HCHAN,STBXCH + REAL::FXVEGCH,STBYCH,FYVEGCH,TMPVALW,WVFACT,QQWCTMP,TWCTMP + REAL::AEXTMP,TMPVAL,USTARC,CDRGTMP,TAUBTMP,TAUE,RIPAMP + REAL::RIPSTP,RIPFAC,ZBRMAX,ZBRMIN,CDRGMAX,ZBREU + REAL::CDRGMIN,WVDTMP,RKZTURB,UTMP,VTMP,DWVDZ,DWUDZ,DWVD2Z + REAL::DWUD2Z,HZRVDZ,HZRUDZ,ZDHZRV,ZDHZRU,ZBREV,HZREFV,HZREFU + REAL::QWDQCV,QWDQCU,QCTMPV,QCTMPU,HOTLYMN,HOTLYMX,CDTMPVY + REAL::BOTTMP,DWVDHR,DWUDHR,QWCTMPV,QWCTMPU + REAL::CDTMPV,CDTMPU,COSWC,CURANG,CDTMPUX + REAL::WVDELV,WVDELU,TAUTMP + LCDMIN=0 + LCDMAX=0 + LZBMIN=0 + LZBMAX=0 + WVDTMP=0.0 + + DELT=DT2 + ISUD=1 + IF(ISTL_.NE.3)THEN + DELT=DT + ISUD=0 + ENDIF + IF(IS2TL_.EQ.1)THEN + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + ELSE + DELT=DTDYN + END IF + ISUD=1 + ENDIF + DELTI=1./DELT +C +C ** IF WAVE-CURRENT BBL MODEL IS ACTIVE, GOTO WAVE CURRENT BBL +C + IF(ISWCBL.GE.1) GOTO 1947 +C +C ** INITIALIZE IMPLICIT BOTTOM FRICTION AND SET DIAGNOSTIC FILES +C ** ON FIRST CALL +C + IF(JSTBXY.EQ.1) GOTO 100 + IF(ISITB.GE.1)THEN + IF(ISITB.EQ.1)THEN + RITB1=0.45 + RITB=0.55 + CDLIMIT=1. + ELSE + RITB1=0.0 + RITB=1.0 + CDLIMIT=10. + ENDIF + ELSE + RITB1=1.0 + RITB=0.0 + CDLIMIT=0.5 + ENDIF + IF(ISVEG.GE.2.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='CBOT.LOG',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + ENDIF + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + STBXO(L)=STBX(L) + STBYO(L)=STBY(L) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + STBX(L)=0. + STBY(L)=0. + ENDDO + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + FXVEG(L,K)=0. + FYVEG(L,K)=0. + ENDDO + ENDDO + MPI_WTIMES(851)=MPI_WTIMES(851)+MPI_TOC(S1TIME) + N=-2 + JSTBXY=1 + 100 CONTINUE + IF(ISITB.GE.1)THEN + IF(ISITB.EQ.1)THEN + CDLIMIT=10. + ELSE + CDLIMIT=100. + ENDIF + ELSE + CDLIMIT=0.5 + ENDIF +C +C ** INITIALIZED DIAGNOSTICS FOR STANDARD AND VEGE +C ** RESISTANCE CALCULATION +C + IF(ISVEG.GE.2.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='CBOT.LOG',POSITION='APPEND',STATUS='UNKNOWN') + ENDIF + CDTOTUM=0. + CDTOTVM=0. + CDMAXUM=0. + CDMAXVM=0. + IF(ISVEG.EQ.0) UVEGSCL=1.E-12 + IF(KC.GT.1) GOTO 200 +C +C ** NORMAL ENTRY INTO STANDARD AND VEGE RESISTANCE CALCULATION +C ** FOR SINGLE LAYER +C ** VEGETATION DRAG +C CALCULATE R FOR LAMINAR FLOW +C CALCULATE R FOR LAMINAR FLOW +C ** END VEGETATION DRAG +C ** NORMAL ENTRY INTO STANDARD AND VEGE RESISTANCE CALCULATION +C ** FOR SINGLE LAYER +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LS,ZBRATU,ZBRATV,UMAGTMP,VMAGTMP,CDMAXU, +!$OMP+ CDMAXV,HURTMP,HVRTMP,HUDZBR,HVDZBR) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LS=LSC(L) + ZBRATU=0.5*(DXP(L-1)*ZBR(L-1)+DXP(L)*ZBR(L))*DXIU(L) + ZBRATV=0.5*(DYP(LS )*ZBR(LS )+DYP(L)*ZBR(L))*DYIV(L) + UMAGTMP=SQRT( U1(L,1)*U1(L,1)+V1U(L)*V1U(L)+1.E-12 ) + VMAGTMP=SQRT( U1V(L)*U1V(L)+V1(L,1)*V1(L,1)+1.E-12 ) + CDMAXU=CDLIMIT*STBXO(L)*H1U(L)/( DELT*UMAGTMP ) + CDMAXV=CDLIMIT*STBYO(L)*H1V(L)/( DELT*VMAGTMP ) + HURTMP=MAX(ZBRATU,H1U(L)) + HVRTMP=MAX(ZBRATV,H1V(L)) + HUDZBR=HURTMP/ZBRATU + IF(HUDZBR.LT.7.5) HUDZBR=7.5 + HVDZBR=HVRTMP/ZBRATV + IF(HVDZBR.LT.7.5) HVDZBR=7.5 + STBX(L)=STBXO(L)*.16/( (LOG( HUDZBR ) -1.)**2) + STBY(L)=STBYO(L)*.16/( (LOG( HVDZBR ) -1.)**2) + STBX(L)=MIN(CDMAXU,STBX(L)) + STBY(L)=MIN(CDMAXV,STBY(L)) + ENDIF + ENDDO + MPI_WTIMES(852)=MPI_WTIMES(852)+MPI_TOC(S1TIME) + IF(ISVEG.GE.1)THEN + K=1 + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(M,LW,LE,LS,LN,LNW,LSE,MW,MS, +!$OMP+ VTMPATU,UTMPATV,UMAGTMP,VMAGTMP,CDMAXU, +!$OMP+ CDMAXV,RVEGUM,CPVEGU,RVEGVM,CPVEGV,HVGTC,HVGTW, +!$OMP+ HVGTS) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + M=MVEGL(L) + FXVEG(L,K)=0. + FYVEG(L,K)=0. +C *** DSLLC BEGIN BLOCK + IF(M.NE.MVEGOW.AND.M.NE.0)THEN + LW=L-1 + LE=L+1 + LS=LSC(L) + LN=LNC(L) + LNW=LNWC(L) + LSE=LSEC(L) + MW=MVEGL(LW) + MS=MVEGL(LS) + VTMPATU=0.25*(V(L,K)+V(LW,K)+V(LN,K)+V(LNW,K)) + UTMPATV=0.25*(U(L,K)+U(LE,K)+U(LS,K)+U(LSE,K)) + UMAGTMP=SQRT( U(L,K)*U(L,K)+VTMPATU*VTMPATU +1.E-12 ) + VMAGTMP=SQRT( UTMPATV*UTMPATV+V(L,K)*V(L,K) +1.E-12 ) + UMAGTMP=MAX(UMAGTMP,UVEGSCL) + VMAGTMP=MAX(VMAGTMP,UVEGSCL) + CDMAXU=CDLIMIT*STBXO(L)*H1U(L)/( DELT*UMAGTMP ) + CDMAXV=CDLIMIT*STBYO(L)*H1V(L)/( DELT*VMAGTMP ) + IF(N.EQ.-2)THEN + VTMPATU=0.25*(V1(L,K)+V1(LW,K)+V1(LN,K)+V1(LNW,K)) + UTMPATV=0.25*(U1(L,K)+U1(LE,K)+U1(LS,K)+U1(LSE,K)) + UMAGTMP=SQRT( U1(L,K)*U1(L,K)+VTMPATU*VTMPATU+1.E-12 ) + VMAGTMP=SQRT( UTMPATV*UTMPATV+V1(L,K)*V1(L,K)+1.E-12 ) + ENDIF + CPVEGU=1.0 + IF(ISVEGL.EQ.1) CPVEGU=CPVEGU + 10.E-6/( + & (BPVEG(MW)+BPVEG(M))*UMAGTMP ) + IF(CPVEGU.GT.1.0)THEN +C CALCULATE R FOR LAMINAR FLOW + CPVEGU=CPVEGU-0.5 + RVEGUM=0. + ENDIF + CPVEGU=SCVEG(M)*CPVEGU + CPVEGV=1.0 + IF(ISVEGL.EQ.1) CPVEGV=CPVEGV + 10.E-6/( + & (BPVEG(MS)+BPVEG(M))*VMAGTMP ) + IF(CPVEGV.GT.1.0)THEN +C CALCULATE R FOR LAMINAR FLOW + CPVEGV=CPVEGV-0.5 + RVEGVM=0. + ENDIF + CPVEGV=SCVEG(M)*CPVEGV + HVGTC=MIN(HPVEG(M),HP(L)) + HVGTW=MIN(HPVEG(MW),HP(L-1)) + HVGTS=MIN(HPVEG(MS),HP(LS)) + FXVEG(L,K)=0.25*CPVEGU*( DXP(L)*(BDLPSQ(M)*HVGTC/PVEGZ(M)) + & +DXP(L-1)*(BDLPSQ(MW)*HVGTW/PVEGZ(MW)) )*DXIU(L) + FYVEG(L,K)=0.25*CPVEGV*( DYP(L)*(BDLPSQ(M)*HVGTC/PVEGZ(M)) + & +DYP(LS)*(BDLPSQ(MS)*HVGTS/PVEGZ(MS)) )*DYIV(L) + FXVEG(L,K)=MIN(FXVEG(L,K),CDMAXU) + FYVEG(L,K)=MIN(FYVEG(L,K),CDMAXU) + ENDIF +C +C *** DSLLC END BLOCK +C + ENDIF + ENDDO + MPI_WTIMES(853)=MPI_WTIMES(853)+MPI_TOC(S1TIME) + ENDIF + GOTO 300 +C +C ** NORMAL ENTRY INTO STANDARD AND VEGE RESISTANCE CALCULATION +C ** FOR MULTIPLE LAYER +C + 200 CONTINUE +C +C ** BEGIN SMOOTH DRAG FORMULATION +C + VISEXP=2./7. + VISFAC=0.0258*(COEFTSBL**VISEXP) +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(UMAGTMP,VMAGTMP,CDMAXU,CDMAXV, +!$OMP+ VISMUDU,VISMUDV,SEDTMP,VISDHU,VISDHV) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + IF(ZBR(L).LE.1.E-6)THEN + UMAGTMP=SQRT( U1(L,1)*U1(L,1)+V1U(L)*V1U(L)+1.E-12 ) + VMAGTMP=SQRT( U1V(L)*U1V(L)+V1(L,1)*V1(L,1)+1.E-12 ) + CDMAXU=CDLIMIT*STBXO(L)*H1U(L)/( DELT*UMAGTMP ) + CDMAXV=CDLIMIT*STBYO(L)*H1V(L)/( DELT*VMAGTMP ) + VISMUDU=VISMUD + VISMUDV=VISMUD + IF(ISMUD.GE.1)THEN + SEDTMP=0.5*(SED(L,1,1)+SED(L-1,1,1)) + VISMUDU=CSEDVIS(SEDTMP) + SEDTMP=0.5*(SED(L,1,1)+SED(LSC(L),1,1)) + VISMUDV=CSEDVIS(SEDTMP) + ENDIF +C ** DELETED COMMENTED OUT LINES & UNUSED VARIABLES + VISDHU=0.0 + VISDHV=0.0 + IF(UMAGTMP.GT.0.0) VISDHU=(VISMUDU*HUI(L)/UMAGTMP)*VISEXP + IF(VMAGTMP.GT.0.0) VISDHV=(VISMUDV*HVI(L)/VMAGTMP)*VISEXP + STBX(L)=VISFAC*AVCON*STBXO(L)*VISDHU + STBY(L)=VISFAC*AVCON*STBYO(L)*VISDHV + STBX(L)=MIN(CDMAXU,STBX(L)) + STBY(L)=MIN(CDMAXV,STBY(L)) + ENDIF + ENDIF + ENDDO + MPI_WTIMES(854)=MPI_WTIMES(854)+MPI_TOC(S1TIME) +C +C ** END SMOOTH DRAG FORMULATION +C +C ** BEGIN ROUGH DRAG FORMULATION +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LS,ZBRATU,ZBRATV,UMAGTMP,VMAGTMP, +!$OMP+ CDMAXU,CDMAXV,HURTMP,HVRTMP,DZHUDZBR,DZHVDZBR) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LS=LSC(L) + IF(ZBR(L).GT.1.E-6)THEN + ZBRATU=0.5*(DXP(L-1)*ZBR(L-1)+DXP(L)*ZBR(L))*DXIU(L) + ZBRATV=0.5*(DYP(LS )*ZBR(LS )+DYP(L)*ZBR(L))*DYIV(L) + UMAGTMP=SQRT( U1(L,1)*U1(L,1)+V1U(L)*V1U(L)+1.E-12 ) + VMAGTMP=SQRT( U1V(L)*U1V(L)+V1(L,1)*V1(L,1)+1.E-12 ) + CDMAXU=CDLIMIT*STBXO(L)*H1U(L)/( DELT*UMAGTMP ) + CDMAXV=CDLIMIT*STBYO(L)*H1V(L)/( DELT*VMAGTMP ) + HURTMP=MAX(ZBRATU,H1U(L)) + HVRTMP=MAX(ZBRATV,H1V(L)) + DZHUDZBR=1.+0.5*DZC(1)*HURTMP/ZBRATU + DZHVDZBR=1.+0.5*DZC(1)*HVRTMP/ZBRATV + STBX(L)=AVCON*STBXO(L)*.16/((LOG(DZHUDZBR))**2) + STBY(L)=AVCON*STBYO(L)*.16/((LOG(DZHVDZBR))**2) + STBX(L)=MIN(CDMAXU,STBX(L)) + STBY(L)=MIN(CDMAXV,STBY(L)) + ENDIF + ENDIF + ENDDO + MPI_WTIMES(855)=MPI_WTIMES(855)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LS,ZBRATU,ZBRATV,UMAGTMP,VMAGTMP, +!$OMP+ CDMAXU,CDMAXV,HURTMP,HVRTMP,DZHUDZBR,DZHVDZBR) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L).AND.ZBR(L).GT.1.E-6)THEN + LS=LSC(L) + ZBRATU=0.5*(DXP(L-1)*ZBR(L-1)+DXP(L)*ZBR(L))*DXIU(L) + ZBRATV=0.5*(DYP(LS )*ZBR(LS )+DYP(L)*ZBR(L))*DYIV(L) + UMAGTMP=SQRT( U1(L,1)*U1(L,1)+V1U(L)*V1U(L)+1.E-12 ) + VMAGTMP=SQRT( U1V(L)*U1V(L)+V1(L,1)*V1(L,1)+1.E-12 ) + CDMAXU=CDLIMIT*STBXO(L)*H1U(L)/( DELT*UMAGTMP ) + CDMAXV=CDLIMIT*STBYO(L)*H1V(L)/( DELT*VMAGTMP ) + HURTMP=MAX(ZBRATU,H1U(L)) + HVRTMP=MAX(ZBRATV,H1V(L)) + DZHUDZBR=1.+0.5*DZC(1)*HURTMP/ZBRATU + DZHVDZBR=1.+0.5*DZC(1)*HVRTMP/ZBRATV + STBX(L)=AVCON*STBXO(L)*.16/((LOG(DZHUDZBR))**2) + STBY(L)=AVCON*STBYO(L)*.16/((LOG(DZHVDZBR))**2) + STBX(L)=MIN(CDMAXU,STBX(L)) + STBY(L)=MIN(CDMAXV,STBY(L)) + ENDIF + ENDDO + MPI_WTIMES(855)=MPI_WTIMES(855)+MPI_TOC(S1TIME) +C +C ** END ROUGH DRAG FORMULATION +C + S1TIME=MPI_TIC() + IF(N.EQ.-2)THEN +!$OMP PARALLEL DO PRIVATE(LS,ZBRATU,ZBRATV,UMAGTMP,VMAGTMP, +!$OMP+ CDMAXU,CDMAXV,HURTMP,HVRTMP,DZHUDZBR,DZHVDZBR) + DO L=LMPI2,LMPILA + LS=LSC(L) + ZBRATU=0.5*(DXP(L-1)*ZBR(L-1)+DXP(L)*ZBR(L))*DXIU(L) + ZBRATV=0.5*(DYP(LS )*ZBR(LS )+DYP(L)*ZBR(L))*DYIV(L) + UMAGTMP=SQRT( U1(L,1)*U1(L,1)+V1U(L)*V1U(L)+1.E-12 ) + VMAGTMP=SQRT( U1V(L)*U1V(L)+V1(L,1)*V1(L,1)+1.E-12 ) + CDMAXU=CDLIMIT*STBXO(L)*H1U(L)/( DELT*UMAGTMP ) + CDMAXV=CDLIMIT*STBYO(L)*H1V(L)/( DELT*VMAGTMP ) + HURTMP=MAX(ZBRATU,H1U(L)) + HVRTMP=MAX(ZBRATV,H1V(L)) + DZHUDZBR=1.+0.5*DZC(1)*HURTMP/ZBRATU + DZHVDZBR=1.+0.5*DZC(1)*HVRTMP/ZBRATV + STBX(L)=AVCON*STBXO(L)*.16/((LOG(DZHUDZBR))**2) + STBY(L)=AVCON*STBYO(L)*.16/((LOG(DZHVDZBR))**2) + STBX(L)=MIN(CDMAXU,STBX(L)) + STBY(L)=MIN(CDMAXV,STBY(L)) + ENDDO + ENDIF + MPI_WTIMES(856)=MPI_WTIMES(856)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + IF(ISVEG.GE.1)THEN + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(M,LW,LE,LS,LN,LNW,LSE,MW,MS, +!$OMP+ VTMPATU,UTMPATV,UMAGTMP,VMAGTMP,CDMAXU,CDMAXV, +!$OMP+ CPVEGU,CPVEGV,RVEGUM,RVEGVM,FRACLAY,FHLAYC, +!$OMP+ FHLAYW,FHLAYS,HVGTC,HVGTW,HVGTS) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + M=MVEGL(L) + FXVEG(L,K)=0. + FYVEG(L,K)=0. + IF(M.NE.MVEGOW.AND.M.NE.0)THEN + LW=L-1 + LE=L+1 + LS=LSC(L) + LN=LNC(L) + LNW=LNWC(L) + LSE=LSEC(L) + MW=MVEGL(LW) + MS=MVEGL(LS) + VTMPATU=0.25*(V(L,K)+V(LW,K)+V(LN,K)+V(LNW,K)) + UTMPATV=0.25*(U(L,K)+U(LE,K)+U(LS,K)+U(LSE,K)) + UMAGTMP=SQRT( U(L,K)*U(L,K)+VTMPATU*VTMPATU +1.E-12 ) + VMAGTMP=SQRT( UTMPATV*UTMPATV+V(L,K)*V(L,K) +1.E-12 ) + UMAGTMP=MAX(UMAGTMP,UVEGSCL) + VMAGTMP=MAX(VMAGTMP,UVEGSCL) + CDMAXU=CDLIMIT*STBXO(L)*H1U(L)/( DELT*UMAGTMP ) + CDMAXV=CDLIMIT*STBYO(L)*H1V(L)/( DELT*VMAGTMP ) + IF(N.EQ.-2)THEN + VTMPATU=0.25*(V1(L,K)+V1(LW,K)+V1(LN,K)+V1(LNW,K)) + UTMPATV=0.25*(U1(L,K)+U1(LE,K)+U1(LS,K)+U1(LSE,K)) + UMAGTMP=SQRT( U1(L,K)*U1(L,K)+VTMPATU*VTMPATU+1.E-12 ) + VMAGTMP=SQRT( UTMPATV*UTMPATV+V1(L,K)*V1(L,K)+1.E-12 ) + ENDIF + CPVEGU=1.0 + IF(ISVEGL.EQ.1) CPVEGU=CPVEGU + 10.E-6/( + & (BPVEG(MW)+BPVEG(M))*UMAGTMP ) + IF(CPVEGU.GT.1.0)THEN +C CALCULATE R FOR LAMINAR FLOW + CPVEGU=CPVEGU-0.5 + RVEGUM=0. + ENDIF + CPVEGU=SCVEG(M)*CPVEGU + CPVEGV=1.0 + IF(ISVEGL.EQ.1) CPVEGV=CPVEGV + 10.E-6/( + & (BPVEG(MS)+BPVEG(M))*VMAGTMP ) + IF(CPVEGV.GT.1.0)THEN +C CALCULATE R FOR LAMINAR FLOW + CPVEGV=CPVEGV-0.5 + RVEGVM=0. + ENDIF + CPVEGV=SCVEG(M)*CPVEGV + FRACLAY=FLOAT(K)/FLOAT(KC) + FHLAYC=FRACLAY*HP(L) + FHLAYW=FRACLAY*HP(L-1) + FHLAYS=FRACLAY*HP(LS) + HVGTC=HP(L) + HVGTW=HP(L-1) + HVGTS=HP(LS) + IF(HPVEG(M).LT.FHLAYC) HVGTC=0.0 + IF(HPVEG(MW).LT.FHLAYW) HVGTW=0.0 + IF(HPVEG(MS).LT.FHLAYS) HVGTS=0.0 + FXVEG(L,K)=0.25*CPVEGU*(DXP(L)*(BDLPSQ(M)*HVGTC/PVEGZ(M)) + & +DXP(L-1)*(BDLPSQ(MW)*HVGTW/PVEGZ(MW)) )*DXIU(L) + FYVEG(L,K)=0.25*CPVEGV*(DYP(L)*(BDLPSQ(M)*HVGTC/PVEGZ(M)) + & +DYP(LS)*(BDLPSQ(MS)*HVGTS/PVEGZ(MS)) )*DYIV(L) + FXVEG(L,K)=MIN(FXVEG(L,K),CDMAXU) + FYVEG(L,K)=MIN(FYVEG(L,K),CDMAXU) + ENDIF +C +C *** DSLLC END BLOCK +C + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(857)=MPI_WTIMES(857)+MPI_TOC(S1TIME) + 300 CONTINUE +C +C ** SUBGRID SCALE CHANNEL FRICTION +C + S1TIME=MPI_TIC() + IF(MDCHH.GE.1)THEN + DO NMD=1,MDCHH + LHOST=LMDCHH(NMD) + LCHNU=LMDCHU(NMD) + LCHNV=LMDCHV(NMD) + MH=MVEGL(LHOST) +C X-DIRECTION CHANNEL + IF(MDCHTYP(NMD).EQ.1)THEN + MU=0 + IF(ISVEG.GE.1) MU=MVEGL(LCHNU) + WCHAN=DXP(LCHNU) + RLCHN=0.5*DYP(LCHNU)+CHANLEN(NMD) + HCHAN=0.5*DYP(LCHNU)*H1P(LCHNU)+CHANLEN(NMD)*H1P(LHOST) + HCHAN=HCHAN/RLCHN + ZBRATU=0.5*DYP(LCHNU)*ZBR(LCHNU)+CHANLEN(NMD)*ZBR(LHOST) + ZBRATU=ZBRATU/RLCHN + HURTMP=MAX(ZBRATU,HCHAN) + HUDZBR=HURTMP/ZBRATU + IF(HUDZBR.LT.7.5) HUDZBR=7.5 + STBXCH=0.16/( (LOG( HUDZBR ) -1.)**2) + CDMAXU=HCHAN*HCHAN*WCHAN/( DELT*(QCHANU(NMD)+1.E-12) ) + STBXCH=MAX(STBXCH,CDMAXU) + STBXCH=MAX(STBXCH,0.1) + FXVEGCH=0.0 + IF(MU.GT.0) FXVEGCH= + & 0.5*(0.5*DYP(LCHNU)*(BDLPSQ(MU)*H1P(LCHNU)/PVEGZ(MU)) + & +CHANLEN(NMD)*(BDLPSQ(MH)*H1P(LHOST)/PVEGZ(MH)) )/RLCHN + CHANFRIC(NMD)=FXVEGCH+STBXCH + ENDIF +C Y-DIRECTION CHANNEL + IF(MDCHTYP(NMD).EQ.2)THEN + MV=0 + IF(ISVEG.GE.1) MV=MVEGL(LCHNV) + WCHAN=DYP(LCHNV) + RLCHN=0.5*DXP(LCHNV)+CHANLEN(NMD) + HCHAN=0.5*DXP(LCHNV)*H1P(LCHNV)+CHANLEN(NMD)*H1P(LHOST) + HCHAN=HCHAN/RLCHN + ZBRATV=0.5*DXP(LCHNV)*ZBR(LCHNV)+CHANLEN(NMD)*ZBR(LHOST) + ZBRATV=ZBRATV/RLCHN + HVRTMP=MAX(ZBRATV,HCHAN) + HVDZBR=HVRTMP/ZBRATV + IF(HVDZBR.LT.7.5) HVDZBR=7.5 + STBYCH=0.16/( (LOG( HVDZBR ) -1.)**2) + CDMAXV=HCHAN*HCHAN*WCHAN/( DELT*(QCHANV(NMD)+1.E-12) ) + STBYCH=MAX(STBYCH,CDMAXV) + STBYCH=MAX(STBYCH,0.1) + FYVEGCH=0.0 + IF(MV.GT.0) FYVEGCH= + & 0.5*(0.5*DXP(LCHNV)*(BDLPSQ(MV)*H1P(LCHNV)/PVEGZ(MV)) + & +CHANLEN(NMD)*(BDLPSQ(MH)*H1P(LHOST)/PVEGZ(MH)) )/RLCHN + CHANFRIC(NMD)=FYVEGCH+STBYCH + ENDIF + ENDDO + ENDIF + MPI_WTIMES(858)=MPI_WTIMES(858)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(ISVEG.GE.2.AND.KC.GT.1.AND.MYRANK.EQ.0)THEN + DO L=2,LA + M=MVEGL(L) + MW=MVEGL(L-1) + MS=MVEGL(LSC(L)) + WRITE(1,1122)N,IL(L),JL(L),MVEGL(L),PVEGZ(M),PVEGZ(MS), + & PVEGZ(MW),STBX(L),STBY(L) + WRITE(1,1123)(FXVEG(L,K),K=1,KC) + WRITE(1,1123)(FYVEG(L,K),K=1,KC) + ENDDO + ENDIF + MPI_WTIMES(859)=MPI_WTIMES(859)+MPI_TOC(S1TIME) + IF(ISVEG.GE.2.AND.MYRANK.EQ.0) CLOSE(1) + 1122 FORMAT(4I5,5E12.4) + 1123 FORMAT(15X,10E12.4) + GOTO 1948 +C +C ** ENTER HERE FOR WAVE-CURRENT BOUNDARY LAYER +C + 1947 CONTINUE + S1TIME=MPI_TIC() + IF(JSTBXY.EQ.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + STBXO(L)=STBX(L) + STBYO(L)=STBY(L) + ENDDO + N=0 + JSTBXY=1 + IF(ISDZBR.GE.1.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='ZBREMX.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + ENDIF + ENDIF + IF(ISDZBR.EQ.N.AND.DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='CDDIAG.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='CDDIAG.OUT',STATUS='UNKNOWN') + ENDIF + NTMP=MAX(N,1) + IF(NTMP.LT.NTSWV)THEN + TMPVALW=FLOAT(NTMP)/FLOAT(NTSWV) + WVFACT=0.5-0.5*COS(PI*TMPVALW) + ELSE + WVFACT=1.0 + ENDIF + MPI_WTIMES(860)=MPI_WTIMES(860)+MPI_TOC(S1TIME) +C +C *** DSLLC BEGIN BLOCK +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(QQWCTMP,TWCTMP,AEXTMP,TMPVAL,USTARC, +!$OMP+ CDRGTMP,TAUTMP,TAUBTMP,TAUE,RIPAMP,RIPSTP,RIPFAC) + DO L=LMPI2,LMPILA + IF(UWVSQ(L).GT.1.E-6 .AND. LMASKDRY(L))THEN + QQWCTMP=SQRT( QQWV2(L)*QQWV2(L)+QQ(L,0)*QQ(L,0) ) + TWCTMP=QQWCTMP/CTURB2 + AEXTMP=WVWHA(L)/SINH(WVKHP(L)) + ZBRE(L)=ZBR(L) + IF(QQ(L,0).GT.0.)THEN + TMPVAL=UWVSQ(L)*SQRT( AEXTMP/(30.*ZBR(L)) ) + USTARC=SQRT(QQ(L,0)/CTURB2) + TMPVAL=TMPVAL/USTARC + ZBRE(L)=ZBR(L)*(1.+0.19*TMPVAL) + ENDIF + CDRGTMP=(30.*ZBRE(L)/AEXTMP)**0.2 + CDRGTMP=5.57*CDRGTMP-6.13 + CDRGTMP=EXP(CDRGTMP) + CDRGTMP=MIN(CDRGTMP,0.22) + TAUTMP=0.5*CDRGTMP*UWVSQ(L) + QQWV2(L)=CTURB2*TAUTMP*WVFACT + QQWC(L)=SQRT( QQWV2(L)*QQWV2(L)+QQ(L,0)*QQ(L,0) ) + IF(ISTRAN(7).GT.0)THEN + TWCTMP=QQWC(L)/CTURB2 + TAUBTMP=QQWV1(L)/CTURB2 + TAUE=TWCTMP/TAUN(NSED+1) + RIPAMP=0. + RIPSTP=0. + IF(TAUBTMP.GT.TAUN(NSED+1).AND.TAUBTMP.LE.TAUD(NSED+1))THEN + RIPAMP=0.22/(TAUE**0.16) + RIPSTP=0.16/(TAUE**0.04) + ENDIF + IF(TAUBTMP.GT.TAUD(NSED+1))THEN + RIPAMP=0.78/(TAUE**1.5) + RIPSTP=0.41/TAUE + ENDIF + RIPAMP=RIPAMP*WVWHA(L)/SINH(WVKHP(L)) + TMPVAL=0. + IF(RIPAMP.GT.0.) TMPVAL=LOG(RIPAMP/ZBRE(L))-1. + TMPVAL=MAX(TMPVAL,0.) + RIPFAC=1.+3.125*TMPVAL*TMPVAL*RIPSTP + QQWV3(L)=RIPFAC*QQWV2(L) + QQWCR(L)=SQRT( QQWV3(L)*QQWV3(L)+QQ(L,0)*QQ(L,0) ) + ELSE + QQWCR(L)=QQ(L,0) + ENDIF + ELSE + QQWV2(L)=QQLMIN + QQWC(L)=QQ(L,0) + QQWCR(L)=QQ(L,0) + ENDIF + ENDDO + MPI_WTIMES(861)=MPI_WTIMES(861)+MPI_TOC(S1TIME) +C +C *** DSLLC END BLOCK +C + ZBRMAX=-(1.E+12)*ZBRADJ + ZBRMIN=(1.E+12)*ZBRADJ + CDRGMAX=-1.E+12 + CDRGMIN=1.E+12 + IF(ISWAVE.EQ.1.OR.ISWAVE.EQ.2)WVDTMP=0.4/(WVFRQ*CTURB3) + RKZTURB=0.4/CTURB3 + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(LS,LN,UTMP,VTMP,CURANG,COSWC,UMAGTMP,VMAGTMP, +!$OMP+ CDMAXU,CDMAXV,CDTMPU,CDTMPV,QWCTMPU,QWCTMPV,WVDELU, +!$OMP+ WVDELV,QCTMPU,QCTMPV,QWDQCU,QWDQCV,HZREFU,HZREFV,ZBREU,ZBREV, +!$OMP+ ZDHZRU,ZDHZRV,HZRUDZ,HZRVDZ,DWUD2Z,DWVD2Z,DWUDZ,DWVDZ,DWUDHR, +!$OMP+ DWVDHR,CDTMPUX,CDTMPVY,JWCBLU,JWCBLV,BOTTMP) +!$OMP+ FIRSTPRIVATE(WVDTMP) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LS=LSC(L) + LN=LNC(L) + UTMP=0.5*STCUV(L)*(U(L+1,1)+U(L,1))+1.E-12 + VTMP=0.5*STCUV(L)*(V(LN,1)+V(L,1)) + CURANG=ATAN2(VTMP,UTMP) + COSWC=COS(CURANG-WACCWE(L)) + UMAGTMP=SQRT( U1(L,1)*U1(L,1)+V1U(L)*V1U(L)+1.E-12 ) + VMAGTMP=SQRT( U1V(L)*U1V(L)+V1(L,1)*V1(L,1)+1.E-12 ) + CDMAXU=STBXO(L)*H1U(L)/( 4.*DELT*UMAGTMP ) + CDMAXV=STBYO(L)*H1V(L)/( 4.*DELT*VMAGTMP ) + CDTMPU=-1. + CDTMPV=-1. + QWCTMPU=0.5*( QQWV2(L)+QQWV2(L+1) ) + QWCTMPV=0.5*( QQWV2(L)+QQWV2(LS ) ) + IF(ISWCBL.EQ.2)THEN + QWCTMPU=0.5*( QQWC(L)+QQWC(L+1) ) + QWCTMPV=0.5*( QQWC(L)+QQWC(LS ) ) + ENDIF + IF(ISWAVE.EQ.3)THEN + IF(WVFRQL(L).GT.1E-6)THEN + WVDTMP=0.4/(WVFRQL(L)*CTURB3) + ELSE + WVDTMP=0. + ENDIF + ENDIF + WVDELU=WVDTMP*SQRT(QWCTMPU) + WVDELV=WVDTMP*SQRT(QWCTMPV) + QWCTMPU=0.5*( QQWCR(L)+QQWCR(L+1) ) + QWCTMPV=0.5*( QQWCR(L)+QQWCR(LS ) ) + QWCTMPU=SQRT(QWCTMPU) + QWCTMPV=SQRT(QWCTMPV) + QCTMPU=0.5*( QQ(L,0)+QQ(L+1,0) ) + QCTMPV=0.5*( QQ(L,0)+QQ(LS ,0) ) + QWDQCU=QWCTMPU/SQRT(QCTMPU) + QWDQCV=QWCTMPV/SQRT(QCTMPV) + HZREFU=DZC(1)*H1U(L) + HZREFV=DZC(1)*H1V(L) + ZBREU=0.5*(ZBRE(L)+ZBRE(L+1)) + ZBREV=0.5*(ZBRE(L)+ZBRE(LS )) + ZDHZRU=ZBREU/HZREFU + ZDHZRV=ZBREV/HZREFV + HZRUDZ=1./ZDHZRU + HZRVDZ=1./ZDHZRV + DWUD2Z=0.5*WVDELU/ZBREU + DWVD2Z=0.5*WVDELV/ZBREV + DWUDZ=2.*DWUD2Z + DWVDZ=2.*DWVD2Z + DWUDHR=WVDELU/HZREFU + DWVDHR=WVDELV/HZREFV + CDTMPUX=RKZTURB*QWCTMPU + CDTMPVY=RKZTURB*QWCTMPV + JWCBLU=0 + JWCBLV=0 + IF( HZRUDZ.LE.DWUD2Z)THEN + CDTMPU=CDTMPUX/( (1.+ZDHZRU)*LOG(1.+HZRUDZ)-1. ) + JWCBLU=1 + ENDIF + IF( HZRVDZ.LE.DWVD2Z)THEN + CDTMPV=CDTMPVY/( (1.+ZDHZRV)*LOG(1.+HZRVDZ)-1. ) + JWCBLV=1 + ENDIF + IF( HZRUDZ.GT.DWUD2Z.AND.HZRUDZ.LE.DWUDZ)THEN + BOTTMP=(1.+ZDHZRU)*LOG(1.+DWUD2Z)-0.5*DWUDHR + & +0.5*HZRUDZ*(1.-0.5*DWUDHR)*(1.-0.5*DWUDHR)/(1.+DWUD2Z) + CDTMPU=CDTMPUX/BOTTMP + JWCBLU=2 + ENDIF + IF( HZRVDZ.GT.DWVD2Z.AND.HZRVDZ.LE.DWVDZ)THEN + BOTTMP=(1.+ZDHZRV)*LOG(1.+DWVD2Z)-0.5*DWVDHR + & +0.5*HZRVDZ*(1.-0.5*DWVDHR)*(1.-0.5*DWVDHR)/(1.+DWVD2Z) + CDTMPV=CDTMPVY/BOTTMP + JWCBLV=2 + ENDIF + IF( HZRUDZ.GT.DWUDZ)THEN + BOTTMP=QWDQCU*( (1.+ZDHZRU)*(LOG(1.+HZRUDZ)-LOG(1.+DWUDZ)) + & +DWUDHR-1. ) + BOTTMP=BOTTMP+(1.+ZDHZRU)*LOG(1.+DWUD2Z) + & +DWUD2Z*(1.-1.25*DWUDHR-ZDHZRU)/(1.+DWUD2Z) + CDTMPU=CDTMPUX/BOTTMP + JWCBLU=3 + ENDIF + IF( HZRVDZ.GT.DWVDZ)THEN + BOTTMP=QWDQCV*( (1.+ZDHZRV)*(LOG(1.+HZRVDZ)-LOG(1.+DWVDZ)) + & +DWVDHR-1. ) + BOTTMP=BOTTMP+(1.+ZDHZRV)*LOG(1.+DWVD2Z) + & +DWVD2Z*(1.-1.25*DWVDHR-ZDHZRV)/(1.+DWVD2Z) + CDTMPV=CDTMPVY/BOTTMP + JWCBLV=3 + ENDIF + CDTMPU=CDTMPU/UMAGTMP + CDTMPV=CDTMPV/VMAGTMP + IF(DEBUG.AND.MYRANK.EQ.0)THEN + IF(ISDZBR.EQ.N)THEN + WRITE(1,1779) IL(L),JL(L),JWCBLU,JWCBLV + WRITE(1,1780) + WRITE(1,1781) ZBREU,WVDELU,HZREFU,CDTMPU,CDMAXU + WRITE(1,1782) + WRITE(1,1781) ZBREV,WVDELV,HZREFV,CDTMPV,CDMAXV + ENDIF + ENDIF + IF(CDTMPU.LE.0.) CDTMPU=CDMAXU + IF(CDTMPV.LE.0.) CDTMPV=CDMAXV + STBX(L)=AVCON*STBXO(L)*CDTMPU + STBY(L)=AVCON*STBYO(L)*CDTMPV + STBX(L)=MIN(CDMAXU,STBX(L),0.11) + STBY(L)=MIN(CDMAXV,STBY(L),0.11) + ENDIF + ENDDO + MPI_WTIMES(862)=MPI_WTIMES(862)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(DEBUG.AND.MYRANK.EQ.0)THEN + IF(ISDZBR.EQ.N) CLOSE(1) + IF(ISDZBR.GE.1)THEN + DO L=2,LA + IF(ZBRE(L).GT.ZBRMAX)THEN + ZBRMAX=ZBRE(L) + LZBMAX=L + ENDIF + IF(ZBRE(L).LT.ZBRMIN)THEN + ZBRMIN=ZBRE(L) + LZBMIN=L + ENDIF + IF(STBX(L).GT.CDRGMAX)THEN + CDRGMAX=STBX(L) + LCDMAX=L + ENDIF + IF(STBX(L).LT.CDRGMIN)THEN + CDRGMIN=STBX(L) + LCDMIN=L + ENDIF + IF(STBY(L).GT.CDRGMAX)THEN + CDRGMAX=STBY(L) + LCDMAX=L + ENDIF + IF(STBY(L).LT.CDRGMIN)THEN + CDRGMIN=STBY(L) + LCDMIN=L + ENDIF + ENDDO + OPEN(1,FILE='ZBREMX.OUT',STATUS='UNKNOWN',POSITION='APPEND') + HOTLYMX=DZC(1)*H1P(LZBMAX) + HOTLYMN=DZC(1)*H1P(LZBMIN) + WRITE(1,1739)N,IL(LZBMAX),JL(LZBMAX),ZBRMAX,HOTLYMX + WRITE(1,1749)N,IL(LZBMIN),JL(LZBMIN),ZBRMIN,HOTLYMN + WRITE(1,1759)N,IL(LCDMAX),JL(LCDMAX),CDRGMAX,STBX(LCDMAX), + & STBY(LCDMAX) + WRITE(1,1769)N,IL(LCDMIN),JL(LCDMIN),CDRGMIN,STBX(LCDMIN), + & STBY(LCDMIN) + CLOSE(1) + ENDIF + ENDIF + MPI_WTIMES(863)=MPI_WTIMES(863)+MPI_TOC(S1TIME) + + 1948 CONTINUE +C1717 FORMAT(' N,I,J = ',I10,2I5,' CDTOTU,CDMAXU = ',2F15.10) +C1718 FORMAT(' N,I,J = ',I10,2I5,' CDTOTV,CDMAXV = ',2F15.10) +C1727 FORMAT(' N,I,J = ',I10,2I5,' LAM CDTOTU,CDMAXU = ',2F15.10) +C1728 FORMAT(' N,I,J = ',I10,2I5,' LAM CDTOTV,CDMAXV = ',2F15.10) +C1719 FORMAT(' N = ',I10,' CDTOTUM,CDTOTVM = ',2F15.10) +C1729 FORMAT(' N = ',I10,' CDMAXUM,CDMAXVM = ',2F15.10) + 1739 FORMAT(' N,I,J = ',I10,2I5,' ZBRMAX,HBTLYMX = ',2E14.6) + 1749 FORMAT(' N,I,J = ',I10,2I5,' ZBRMIN,HBTLYMN = ',2E14.6) + 1759 FORMAT(' N,I,J = ',I10,2I5,' CDRGMAX,STBX,STBY = ',3E14.6) + 1769 FORMAT(' N,I,J = ',I10,2I5,' CDRGMIN,STBX,STBY = ',3E14.6) + 1779 FORMAT(' I, J, JWCBLU, JWCBLV = ',4I8) + 1780 FORMAT(' ZBREU WVDELU HZREFU CDTMPU ', + & 1X,' CDMAXU') + 1781 FORMAT(5E12.4) + 1782 FORMAT(' ZBREV WVDELV HZREFV CDTMPV ', + & 1X,' CDMAXV') + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTOX.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTOX.for index fd7034e88..b9fb2570a 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTOX.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTOX.for @@ -5,6 +5,7 @@ C ** SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING, C ** DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX C USE GLOBAL + USE MPI REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TOXFPA IF(.NOT.ALLOCATED(TOXFPA))THEN @@ -204,7 +205,7 @@ C ENDDO ENDDO ENDIF - 1907 FORMAT(2I6,10E13.4) +C1907 FORMAT(2I6,10E13.4) C C ** CALCULATE TOXIC CONTAMINANT PARTICULATE FRACTIONS C ** IN SEDIMENT BED @@ -560,7 +561,7 @@ C C ** DIAGNOSTICS OF FLUX C IF(ISDTXBUG.EQ.1.AND.DEBUG)THEN - IF(N.EQ.1)THEN + IF(N.EQ.1.AND.MYRANK.EQ.0)THEN OPEN(2,FILE='TOXFLX.DIA') CLOSE(2,STATUS='DELETE') OPEN(2,FILE='TOXFLX.DIA') @@ -679,7 +680,7 @@ C ENDDO ENDDO - 8822 FORMAT(3I5,E14.5) +C8822 FORMAT(3I5,E14.5) IF(IS2TIM.GE.1) THEN IF(ISBAL.GE.1)THEN IF(NSBDLDBC.GT.0) THEN @@ -733,8 +734,8 @@ C TOXFBLT(NT)=TOXFBLT(NT)+DXYP(L)*TOXFBL(L,NT) ENDDO ENDDO - 8862 FORMAT('N,NX,SNDFBLTOT,QSBLLDXDY =',2I5,2E14.5) - 8899 FORMAT('N,TOXFBLT(NT),TOXBLB(NT)=',I5,2E14.5) +C8862 FORMAT('N,NX,SNDFBLTOT,QSBLLDXDY =',2I5,2E14.5) +C8899 FORMAT('N,TOXFBLT(NT),TOXBLB(NT)=',I5,2E14.5) C C END FIXED FOR BED LOAD JMH 5/22/02 C ** ADJUST TOXIC FLUXES ACROSS WATER COLUMN - BED INTERFACE TO @@ -793,8 +794,8 @@ C END ADJUST WC AND BED TOXIC CONSISTENT WITH FLUX C ENDDO - 676 FORMAT('N,L,T,TB,TT,T1.TB1,F,FB=',2I5,8E13.4) - 677 FORMAT('N,L,T,TB =',2I5,8E13.4) +C 676 FORMAT('N,L,T,TB,TT,T1.TB1,F,FB=',2I5,8E13.4) +C 677 FORMAT('N,L,T,TB =',2I5,8E13.4) ENDDO ENDIF @@ -1013,7 +1014,7 @@ C ENDDO ENDIF ENDIF - 8888 FORMAT(4I5,7E14.5) +C8888 FORMAT(4I5,7E14.5) 2222 FORMAT(2I5,7E14.5) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTOXB.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTOXB.for index e6f3f5001..7ce666856 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTOXB.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTOXB.for @@ -246,7 +246,7 @@ C ENDDO ENDDO ENDIF - 8999 FORMAT(' TAD ',2I10,5E14.5,2F10.5) +C8999 FORMAT(' TAD ',2I10,5E14.5,2F10.5) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRAN.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRAN.for index e3a8776fd..f33650271 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRAN.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRAN.for @@ -10,24 +10,17 @@ C USE GLOBAL REAL, DIMENSION(LCM,KCM), intent(inout) :: CON,CON1 - REAL, DIMENSION(:,:), allocatable :: UTERM0, VTERM0, - + SSCORUEWNS, SSCORWAB - INTEGER, dimension(0:nthds-1,KC) :: icount REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::CONTMN REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::CONTMX - REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::FQCPAD - REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::QSUMNAD - REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::QSUMPAD +! REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::FQCPAD +! REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::QSUMNAD +! REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::QSUMPAD REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::POS - REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::WQBCCON + REAL CTMP + CTMP=0.0 - ALLOCATE(UTERM0(LC,KC)) - ALLOCATE(VTERM0(LC,KC)) - ALLOCATE(SSCORUEWNS(LC,KC)) - ALLOCATE(SSCORWAB(LC,KC)) - IF(.NOT.ALLOCATED(CONTMN))THEN ALLOCATE(CONTMN(0:LCM1,KCM)) ALLOCATE(CONTMX(0:LCM1,KCM)) @@ -37,17 +30,10 @@ C ALLOCATE(POS(0:LCM1,KCM)) ALLOCATE(WQBCCON(0:LCM1,KCM)) -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - DO L=LF,LL + DO L=1,LC FWU(L,0)=0. FWU(L,KC)=0. ENDDO -c - enddo CONTMN=0.0 CONTMX=0.0 FQCPAD=0.0 @@ -82,20 +68,7 @@ C IF(IS2TL_.EQ.1)THEN ISUD=1 IF(MVAR.NE.8)THEN -c CON1=CON ! *** ARRAYS -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c - DO K=1,KC - DO L=LF,LL - CON1(L,K)=CON(L,K) - ENDDO - ENDDO -c - enddo - + CON1=CON ! *** ARRAYS ENDIF ENDIF @@ -112,7 +85,7 @@ c C C ** CALCULATED EXTERNAL SOURCES AND SINKS C - CALL CALFQC (ISTL_,IS2TL_,MVAR,M,CON,CON1,FQCPAD,QSUMPAD,QSUMNAD) + CALL CALFQC (ISTL_,IS2TL_,MVAR,M,CON,CON1)!,FQCPAD,QSUMPAD,QSUMNAD) C C ** SELECT TRANSPORT OPTION, ISPLIT=1 FOR HORIZONTAL-VERTICAL C ** OPERATOR SPLITTING @@ -129,28 +102,23 @@ C ** AVERAGED BETWEEN (N) AND (N+1) OR (N-1) AND (N+1) AND ADVECTED C ** AT (N) OR (N-1) IF ISTL EQUALS 2 OR 3 RESPECTIVELY C 300 CONTINUE -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(IDRYTBP.EQ.0)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA FUHU(L,K)=UHDY2(L,K)*CON1(LUPU(L,K),K) FVHU(L,K)=VHDX2(L,K)*CON1(LUPV(L,K),K) ENDDO ENDDO IF(KC.GT.1)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA FWU(L,K)=W2(L,K)*CON1(L,KUPW(L,K)) ENDDO ENDDO ENDIF ELSE DO K=1,KC - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN FUHU(L,K)=UHDY2(L,K)*CON1(LUPU(L,K),K) FVHU(L,K)=VHDX2(L,K)*CON1(LUPV(L,K),K) @@ -162,7 +130,7 @@ c ENDDO IF(KC.GT.1)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA IF(LMASKDRY(L))THEN FWU(L,K)=W2(L,K)*CON1(L,KUPW(L,K)) ELSE @@ -172,8 +140,6 @@ c ENDDO ENDIF ENDIF -c - enddo GOTO 500 C C ** CALCULATE ADVECTIVE FLUXES BY UPWIND DIFFERENCE WITH ADVECTION @@ -181,39 +147,25 @@ C ** AVERAGED BETWEEN (N-1) AND (N+1) AND ADVECTED FIELD AVERAGED C ** BETWEEN AT (N-1) AND (N) IF ISTL 3 ONLY C 350 CONTINUE -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA CONT(L,K)=0.5*(CON(L,K)+CON1(L,K)) & +DELT*0.5*FQC(L,K)*DXYIP(L)/H2P(L) ENDDO ENDDO -c - enddo -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA FUHU(L,K)=UHDY2(L,K)*CONT(LUPU(L,K),K) FVHU(L,K)=VHDX2(L,K)*CONT(LUPV(L,K),K) ENDDO ENDDO IF(KC.GT.1)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA FWU(L,K)=W2(L,K)*CONT(L,KUPW(L,K)) ENDDO ENDDO ENDIF -c - enddo GOTO 500 C C ** CALCULATE ADVECTIVE FLUXES BY CENTRAL DIFFERENCE WITH TRANSPORT @@ -225,26 +177,13 @@ C PMC DO L=2,LA C PMC CONT(L,K)=CON1(L,K) C PMC ENDDO C PMC ENDDO -!$OMP PARALLEL DO PRIVATE(LF,LL,LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA LS=LSC(L) FUHU(L,K)=0.5*UHDY2(L,K)*(CON(L,K)+CON(L-1,K)) FVHU(L,K)=0.5*VHDX2(L,K)*(CON(L,K)+CON(LS,K)) ENDDO ENDDO - DO K=1,KS - DO L=LF,LL - FWU(L,K)=0.5*W2(L,K)*(CON(L,K+1)+CON(L,K)) - ENDDO - ENDDO -c - enddo - DO K=1,KC DO LL=1,NCBS L=LCBS(LL) @@ -265,6 +204,11 @@ c IF(VHDX2(L,K).GT.0.) FVHU(L,K)=VHDX2(L,K)*CON1(LS,K) ENDDO ENDDO + DO K=1,KS + DO L=2,LA + FWU(L,K)=0.5*W2(L,K)*(CON(L,K+1)+CON(L,K)) + ENDDO + ENDDO C C ** STANDARD ADVECTION CALCULATION C @@ -277,16 +221,11 @@ C ! *** IF ISACAC EQ 0 INCLUDE FQC MASS SOURCES IN UPDATE IF(ISCDCA(MVAR).EQ.0)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL,RDZIC) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(ISTL_.EQ.2)THEN IF(IDRYTBP.EQ.0)THEN DO K=1,KC RDZIC=DZIC(K) - DO L=LF,LL + DO L=2,LA CH(L,K)=CON1(L,K)*H1P(L) & +DELT*( ( RDZIC*FQC(L,K) & +FUHU(L,K)-FUHU(L+1,K) @@ -297,7 +236,7 @@ c ELSE DO K=1,KC RDZIC=DZIC(K) - DO L=LF,LL + DO L=2,LA IF(IMASKDRY(L).EQ.0) & CH(L,K)=CON1(L,K)*H1P(L) & +DELT*( ( RDZIC*FQC(L,K)+FUHU(L,K)-FUHU(L+1,K) @@ -313,7 +252,7 @@ c ENDIF IF(ISFCT(MVAR).GE.1.AND.ISADAC(MVAR).GT.0)THEN ! *** DSLLC SINGLE LINE DO K=1,KC - DO L=LF,LL + DO L=2,LA CON2(L,K)=CON1(L,K) ENDDO ENDDO @@ -324,7 +263,7 @@ C ELSE DO K=1,KC RDZIC=DZIC(K) - DO L=LF,LL + DO L=2,LA CH(L,K)=CON1(L,K)*H2P(L) & +DELT*( ( RDZIC*FQC(L,K) & +FUHU(L,K)-FUHU(L+1,K) @@ -334,14 +273,12 @@ C ENDDO IF(ISFCT(MVAR).GE.1.AND.ISADAC(MVAR).GT.0)THEN ! *** DSLLC SINGLE LINE DO K=1,KC - DO L=LF,LL + DO L=2,LA CON2(L,K)=CON(L,K) ENDDO ENDDO ENDIF ENDIF -c - enddo C C ENDIF ON TIME LEVEL CHOICE FOR ISCDCA=0 C @@ -351,35 +288,19 @@ C L=LOBCS(IOBC) CON(L,K)=CON1(L,K) ENDDO - ENDDO -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO K=1,KC - DO L=LF,LL + DO L=2,LA CON1(L,K)=CON(L,K) ENDDO ENDDO -c - enddo ENDIF ! *** UPDATE NEW CONCENTRATIONS -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA CON(L,K)=CH(L,K)*HPI(L) ENDDO ENDDO -c - enddo C C *** ELSE ON TRANSPORT OPTION CHOICE C *** IF ISACAC NE 0 DO NOT INCLUDE FQC MASS SOURCES IN UPDATE @@ -389,15 +310,10 @@ C C BEGIN IF ON TIME LEVEL CHOICE FOR ISCDCA.NE.0 C IF(ISTL_.EQ.2)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL,RDZIC) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(IDRYTBP.EQ.0)THEN DO K=1,KC RDZIC=DZIC(K) - DO L=LF,LL + DO L=2,LA CH(L,K)=CON1(L,K)*H1P(L) & +DELT*( ( RDZIC*FQC(L,K) & +FUHU(L,K)-FUHU(L+1,K) @@ -408,7 +324,7 @@ c ELSE DO K=1,KC RDZIC=DZIC(K) - DO L=LF,LL + DO L=2,LA IF(IMASKDRY(L).EQ.0) & CH(L,K)=CON1(L,K)*H1P(L) & +DELT*( ( RDZIC*FQC(L,K) @@ -423,9 +339,6 @@ c ENDDO ENDDO ENDIF -c - enddo - IF(ISFCT(MVAR).GE.1)THEN CON2=CON1 ! *** ARRAYS ENDIF @@ -433,23 +346,15 @@ C C ELSE ON TIME LEVEL CHOICE FOR ISCDCA.NE.0 AND ISTL.EQ.3 C ELSE -!$OMP PARALLEL DO PRIVATE(LF,LL,RDZIC) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC RDZIC=DZIC(K) - DO L=LF,LL + DO L=2,LA CH(L,K)=CON1(L,K)*H2P(L) & +DELT*( ( RDZIC*FQC(L,K)+FUHU(L,K)-FUHU(L+1,K) & +FVHU(L,K)-FVHU(LNC(L),K))*DXYIP(L) & +(FWU(L,K-1)-FWU(L,K))*RDZIC ) ENDDO ENDDO -c - enddo - IF(ISFCT(MVAR).GE.1)THEN CON2=CON ! *** ARRAYS ENDIF @@ -458,41 +363,24 @@ C C ENDIF ON TIME LEVEL CHOICE FOR ISCDCA.NE.0 C IF(ISUD.EQ.1.AND.MVAR.NE.8)THEN -!$OMP PARALLEL DO PRIVATE(L) DO K=1,KC DO IOBC=1,NBCSOP L=LOBCS(IOBC) CON(L,K)=CON1(L,K) ENDDO - ENDDO -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO K=1,KC - DO L=LF,LL + DO L=2,LA CON1(L,K)=CON(L,K) ENDDO ENDDO -c - enddo ENDIF ! *** PMC-BOUNDARY CONDITIONS APPLIED BELOW -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA CON(L,K)=CH(L,K)*HPI(L) ENDDO ENDDO -c - enddo ENDIF C @@ -696,106 +584,41 @@ C ! *** PMC BEGIN BLOCK ! *** GET ONLY POSITIVE CONCENTRATIONS -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c + DO L=2,LA DO K=1,KC - DO L=LF,LL POS(L,K)=MAX(CON(L,K),0.) ENDDO ENDDO -c - enddo ! *** PMC END BLOCK IF(IDRYTBP.EQ.0)THEN + DO K=1,KC + UUU(LC,K)=0.0 + VVV(LC,K)=0.0 + UUU(1,K)=0.0 + VVV(1,K)=0.0 + ENDDO + DO L=1,LC + WWW(L,0)=0.0 + WWW(L,KC)=0.0 + ENDDO C -!$OMP PARALLEL DO PRIVATE(LF,LL,LF_LC,LL_LC,L,K, -!$OMP& RDZIG,LS,AUHU,AVHV) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) - LF_LC=jse_LC(1,ithds) - LL_LC=jse_LC(2,ithds) -c DO K=1,KC - IF(LF.eq.2) THEN - L=1 - UUU(L,K)=0.0 - VVV(L,K)=0.0 - ENDIF - DO L=LF,LL + DO L=2,LA LS=LSC(L) UUU(L,K)=U2(L,K)*(POS(L,K)-POS(L-1,K))*DXIU(L) VVV(L,K)=V2(L,K)*(POS(L,K)-POS(LS,K))*DYIV(L) -c AUHU=ABS(UHDY2(L,K)) -c AVHV=ABS(VHDX2(L,K)) -c UTERM0(L,K)=AUHU*(POS(L,K)-POS(L-1,K)) -c VTERM0(L,K)=AVHV*(POS(L,K)-POS(LS,K)) ENDDO - IF(LL.eq.LA) THEN - L=LC - UUU(L,K)=0.0 - VVV(L,K)=0.0 - ENDIF - ENDDO - K=0 - DO L=LF_LC,LL_LC - WWW(L,K)=0.0 - ENDDO + ENDDO DO K=1,KS RDZIG=DZIG(K) - DO L=LF,LL + DO L=2,LA WWW(L,K)=W2(L,K)*(POS(L,K+1)-POS(L,K))*HPI(L)*RDZIG ENDDO ENDDO - K=KC - DO L=LF_LC,LL_LC - WWW(L,K)=0.0 - ENDDO -c - enddo -c t00=rtc()-t00 -c write(6,*) '==>5C',t00*1d6 -c t00=rtc() - IF(ISADAC(MVAR).GE.2)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL,LF_LC,LL_LC, -!$OMP& RDZIC) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) - LF_LC=jse_LC(1,ithds) - LL_LC=jse_LC(2,ithds) -c - DO K=1,KC - RDZIC=DZIC(K) - DO L=LF_LC,LL_LC - SSCORUEWNS(L,K)=DELTA*RDZIC*DXYIP(L)*HPI(L)*(FQCPAD(L,K) - & -QSUMPAD(L,K)*CON(L,K)) - ENDDO - DO L=LF,LL - SSCORWAB(L,K)=DELTA*DZIG(K)*HPI(L)*DXYIP(L) - & *(FQCPAD(L,K )-QSUMPAD(L,K )*POS(L,K )) - ENDDO - ENDDO -c - enddo - ENDIF - -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& RDZIC,LN,LS,LNW,LSE, -!$OMP& AUHU,AVHV,UTERM,VTERM,SSCORUE,SSCORUW,SSCORVN,SSCORVS, -!$OMP& SSCORU,SSCORV,UHU,VHV, -!$OMP& AWW,WTERM,SSCORWA,SSCORWB,SSCORW,WW) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC RDZIC=DZIC(K) - DO L=LF,LL + DO L=2,LA LN=LNC(L) LS=LSC(L) LNW=LNWC(L) @@ -804,22 +627,15 @@ c AVHV=ABS(VHDX2(L,K)) UTERM=AUHU*(POS(L,K)-POS(L-1,K)) VTERM=AVHV*(POS(L,K)-POS(LS,K)) -c UTERM=UTERM0(L,K) -c VTERM=VTERM0(L,K) IF(ISADAC(MVAR).GE.2)THEN -c SSCORUE=DELTA*RDZIC*DXYIP(L )*HPI(L )*(FQCPAD(L ,K) -c & -QSUMPAD(L ,K)*CON(L ,K)) -c SSCORUW=DELTA*RDZIC*DXYIP(L-1)*HPI(L-1)*(FQCPAD(L-1,K) -c & -QSUMPAD(L-1,K)*CON(L-1,K)) -c SSCORVN=DELTA*RDZIC*DXYIP(L )*HPI(L )*(FQCPAD(L ,K) -c & -QSUMPAD(L ,K)*CON(L ,K)) -c SSCORVS=DELTA*RDZIC*DXYIP(LS )*HPI(LS )*(FQCPAD(LS ,K) -c & -QSUMPAD(LS ,K)*CON(LS ,K)) - SSCORUE=SSCORUEWNS(L,K) - SSCORUW=SSCORUEWNS(L-1,K) - SSCORVN=SSCORUEWNS(L,K) - SSCORVS=SSCORUEWNS(LS,K) - + SSCORUE=DELTA*RDZIC*DXYIP(L )*HPI(L )*(FQCPAD(L ,K) + & -QSUMPAD(L ,K)*CON(L ,K)) + SSCORUW=DELTA*RDZIC*DXYIP(L-1)*HPI(L-1)*(FQCPAD(L-1,K) + & -QSUMPAD(L-1,K)*CON(L-1,K)) + SSCORVN=DELTA*RDZIC*DXYIP(L )*HPI(L )*(FQCPAD(L ,K) + & -QSUMPAD(L ,K)*CON(L ,K)) + SSCORVS=DELTA*RDZIC*DXYIP(LS )*HPI(LS )*(FQCPAD(LS ,K) + & -QSUMPAD(LS ,K)*CON(LS ,K)) SSCORU=MAX(UHDY2(L,K),0.0)*SSCORUW+MIN(UHDY2(L,K),0.0) & *SSCORUE SSCORV=MAX(VHDX2(L,K),0.0)*SSCORVS+MIN(VHDX2(L,K),0.0) @@ -863,18 +679,15 @@ c & -QSUMPAD(LS ,K)*CON(LS ,K)) ENDDO ENDDO DO K=1,KS - DO L=LF,LL + DO L=2,LA LN=LNC(L) AWW=ABS(W2(L,K)) WTERM=AWW*(POS(L,K+1)-POS(L,K)) IF(ISADAC(MVAR).GE.2)THEN -c SSCORWA=DELTA*DZIG(K+1)*HPI(L)*DXYIP(L) -c & *(FQCPAD(L,K+1)-QSUMPAD(L,K+1)*POS(L,K+1)) -c SSCORWB=DELTA*DZIG(K)*HPI(L)*DXYIP(L) -c & *(FQCPAD(L,K )-QSUMPAD(L,K )*POS(L,K )) - SSCORWA=SSCORWAB(L,K+1) - SSCORWB=SSCORWAB(L,K) - + SSCORWA=DELTA*DZIG(K+1)*HPI(L)*DXYIP(L) + & *(FQCPAD(L,K+1)-QSUMPAD(L,K+1)*POS(L,K+1)) + SSCORWB=DELTA*DZIG(K)*HPI(L)*DXYIP(L) + & *(FQCPAD(L,K )-QSUMPAD(L,K )*POS(L,K )) SSCORW=MAX(W2(L,K),0.0)*SSCORWB+MIN(W2(L,K),0.0)*SSCORWA WTERM=WTERM+SSCORW ENDIF @@ -899,164 +712,74 @@ c & *(FQCPAD(L,K )-QSUMPAD(L,K )*POS(L,K )) ENDIF ENDDO ENDDO -c - enddo -c t00=rtc()-t00 -c write(6,*) '==>6C',t00*1d6 -c t00=rtc() C C ** SET ANTIDIFFUSIVE FLUXES TO ZERO FOR SOURCE CELLS C IF(ISADAC(MVAR).EQ.1)THEN ! *** ANTIDIFFUSION TURNED OFF FOR SOURCE CELLS -!$OMP PARALLEL DO PRIVATE(LF,LL,L) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL-1 -c DO L=2,LA + DO L=2,LA IF(QSUMPAD(L,K).GT.0.0)THEN - IF(FUHU(L ,K).NE.0.) FUHU(L ,K)=0. - IF(FUHU(L+1,K).NE.0.) FUHU(L+1,K)=0. - IF(FVHU(L ,K).NE.0.) FVHU(L ,K)=0. - IF(FWU(L,K ).NE.0.) FWU(L,K )=0. - IF(FWU(L,K-1).NE.0.) FWU(L,K-1)=0. - ENDIF - ENDDO - ENDDO - enddo -c - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO K=1,KC - L=LL - IF(QSUMPAD(L,K).GT.0.0)THEN - IF(FUHU(L ,K).NE.0.) FUHU(L ,K)=0. - IF(FUHU(L+1,K).NE.0.) FUHU(L+1,K)=0. - IF(FVHU(L ,K).NE.0.) FVHU(L ,K)=0. - IF(FWU(L,K ).NE.0.) FWU(L,K )=0. - IF(FWU(L,K-1).NE.0.) FWU(L,K-1)=0. - ENDIF - ENDDO - enddo - - -!$OMP PARALLEL DO PRIVATE(LF,LL,LN,ii) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO K=1,KC - ii=0 - DO L=LF,LL - IF(QSUMPAD(L,K).GT.0.0)THEN LN=LNC(L) - IF(LN.NE.LC) THEN - IF(FVHU(LN ,K).NE.0.) FVHU(LN ,K)=0. - ELSE - ii=ii+1 - ENDIF + FUHU(L ,K)=0. + FUHU(L+1,K)=0. + FVHU(L ,K)=0. + FVHU(LN ,K)=0. + FWU(L,K )=0. + FWU(L,K-1)=0. ENDIF ENDDO - icount(ithds,K)=ii - ENDDO - enddo - DO K=1,KC - ii=0 - do ithds=0,nthds-1 - ii=ii+icount(ithds,K) - enddo - if(ii.gt.0) then - LN=LC - FVHU(LN ,K)=0. - endif ENDDO - ENDIF C C ** SET ANTIDIFFUSIVE FLUXES TO ZERO FOR OPEN BOUNDARY CELLS C + DO K=1,KC DO LL=1,NCBS L=LCBS(LL) LN=LNC(L) - DO K=1,KC FVHU(LN,K)=0.0 ENDDO - ENDDO - DO LL=1,NCBW - L=LCBW(LL) - DO K=1,KC - FUHU(L+1,K)=0.0 + DO LL=1,NCBW + L=LCBW(LL) + FUHU(L+1,K)=0.0 ENDDO - ENDDO - DO LL=1,NCBE - L=LCBE(LL) - DO K=1,KC - FUHU(L,K)=0.0 + DO LL=1,NCBE + L=LCBE(LL) + FUHU(L,K)=0.0 ENDDO - ENDDO - DO LL=1,NCBN - L=LCBN(LL) - DO K=1,KC + DO LL=1,NCBN + L=LCBN(LL) FVHU(L,K)=0.0 - ENDDO ENDDO + ENDDO C C ** CALCULATE AND APPLY FLUX CORRECTED TRANSPORT LIMITERS C -c t00=rtc()-t00 -c write(6,*) '==>7C',t00*1d6 -c t00=rtc() IF(ISFCT(MVAR).EQ.0) GOTO 1100 C C ** DETERMINE MAX AND MIN CONCENTRATIONS C -!$OMP PARALLEL DO PRIVATE(LF,LL,L) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - IF(LF.eq.2) THEN - L=1 + DO L=1,LC CONTMX(L,K)=0.0 CONTMN(L,K)=0.0 - ENDIF - DO L=LF,LL + ENDDO + ENDDO + DO K=1,KC + DO L=2,LA CONTMX(L,K)=MAX(CON(L,K),CON2(L,K)) CONTMN(L,K)=MIN(CON(L,K),CON2(L,K)) ENDDO - IF(LL.eq.LA) THEN - L=LC - CONTMX(L,K)=0.0 - CONTMN(L,K)=0.0 - ENDIF ENDDO -c - enddo -c t00=rtc()-t00 -c write(6,*) '==>8C',t00*1d6 -c t00=rtc() - -!$OMP PARALLEL DO PRIVATE(LF,LL,K, -!$OMP& LS,LN, -!$OMP& CWMAX,CEMAX,CSMAX,CNMAX,CMAXT,CWMIN,CEMIN,CSMIN,CNMIN,CMINT) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA CMAX(L,1)=MAX(CONTMX(L,1),CONTMX(L,2)) CMAX(L,KC)=MAX(CONTMX(L,KS),CONTMX(L,KC)) CMIN(L,1)=MIN(CONTMN(L,1),CONTMN(L,2)) CMIN(L,KC)=MIN(CONTMN(L,KS),CONTMN(L,KC)) ENDDO DO K=2,KS - DO L=LF,LL + DO L=2,LA CMAXT=MAX(CONTMX(L,K-1),CONTMX(L,K+1)) CMAX(L,K)=MAX(CONTMX(L,K),CMAXT) CMINT=MIN(CONTMN(L,K-1),CONTMN(L,K+1)) @@ -1064,7 +787,7 @@ c ENDDO ENDDO DO K=1,KC - DO L=LF,LL + DO L=2,LA LS=LSC(L) LN=LNC(L) CWMAX=SUB(L)*CONTMX(L-1,K) @@ -1085,13 +808,12 @@ c CMIN(L,K)=MIN(CMIN(L,K),CMINT) ENDDO ENDDO - C C ** SEPARATE POSITIVE AND NEGATIVE FLUXES PUTTING NEGATIVE FLUXES C ** INTO FUHV, FVHV, AND FWV C DO K=1,KC - DO L=LF,LL + DO L=2,LA FUHV(L,K)=MIN(FUHU(L,K),0.) FUHU(L,K)=MAX(FUHU(L,K),0.) FVHV(L,K)=MIN(FVHU(L,K),0.) @@ -1099,29 +821,18 @@ C ENDDO ENDDO DO K=1,KS - DO L=LF,LL + DO L=2,LA FWV(L,K)=MIN(FWU(L,K),0.) FWU(L,K)=MAX(FWU(L,K),0.) ENDDO ENDDO -c - enddo -c t00=rtc()-t00 -c write(6,*) '==>9C',t00*1d6 -c t00=rtc() C C ** CALCULATE INFLUX AND OUTFLUX IN CONCENTRATION UNITS AND LOAD C ** INTO DU AND DV, THEN ADJUCT VALUES AT BOUNDARIES C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& RDZIC,LN) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC RDZIC=DZIC(K) - DO L=LF,LL + DO L=2,LA LN=LNC(L) DU(L,K)=DELT*(DXYIP(L)*(FUHU(L,K)-FUHV(L+1,K) & +FVHU(L,K)-FVHV(LN,K)) @@ -1131,45 +842,33 @@ c & +RDZIC*(FWU(L,K)-FWV(L,K-1)) )*HPI(L) ENDDO ENDDO -c - enddo - -c t00=rtc()-t00 -c write(6,*) '==>10C',t00*1d6 -c t00=rtc() + DO K=1,KC DO IOBC=1,NBCSOP L=LOBCS(IOBC) - DO K=1,KC DU(L,K)=0. DV(L,K)=0. ENDDO END DO + DO K=1,KC DO LL=1,NCBS L=LCBS(LL) LN=LNC(L) - DO K=1,KC DU(LN,K)=0. DV(LN,K)=0. ENDDO - ENDDO DO LL=1,NCBW L=LCBW(LL) - DO K=1,KC DU(L+1,K)=0. DV(L+1,K)=0. ENDDO - ENDDO DO LL=1,NCBE L=LCBE(LL) DU(L-1,K)=0. - DO K=1,KC DV(L-1,K)=0. ENDDO - ENDDO DO LL=1,NCBN L=LCBN(LL) LS=LSC(L) - DO K=1,KC DU(LS,K)=0. DV(LS,K)=0. ENDDO @@ -1177,65 +876,19 @@ c t00=rtc() C C ** CALCULATE BETA COEFFICIENTS WITH BETAUP AND BETADOWN IN DU AND DV C -!$OMP PARALLEL DO PRIVATE(LF,LL,BB) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL - IF(DU(L,K).GT.0.) THEN - IF((CMAX(L,K)-POS(L,K)).LT.(DU(L,K)+BSMALL)) THEN - BB=(CMAX(L,K)-POS(L,K))/(DU(L,K)+BSMALL) - ELSE - BB=1. - ENDIF - ELSE - BB=MIN(DU(L,K),1.) - ENDIF - DU(L,K)=BB -c IF(DU(L,K).GT.0.)DU(L,K)=(CMAX(L,K)-POS(L,K))/(DU(L,K)+BSMALL) -c DU(L,K)=MIN(DU(L,K),1.) -c if(BB.ne.DU(L,K)) THEN -c cc write(6,*) BB,DU(L,K) -c stop 10 -c endif - IF(DV(L,K).GT.0.) THEN - IF((CON(L,K)-CMIN(L,K)).LT.(DV(L,K)+BSMALL)) THEN - BB=(CON(L,K)-CMIN(L,K))/(DV(L,K)+BSMALL) - ELSE - BB=1. - ENDIF - ELSE - BB=MIN(DV(L,K),1.) - ENDIF - DV(L,K)=BB - -c IF(DV(L,K).GT.0.)DV(L,K)=(CON(L,K)-CMIN(L,K))/(DV(L,K)+BSMALL) -c DV(L,K)=MIN(DV(L,K),1.) -c if(BB.ne.DV(L,K)) THEN -c cc write(6,*) BB,DV(L,K) -c stop 10 -c endif - + DO L=2,LA + IF(DU(L,K).GT.0.)DU(L,K)=(CMAX(L,K)-POS(L,K))/(DU(L,K)+BSMALL) + DU(L,K)=MIN(DU(L,K),1.) + IF(DV(L,K).GT.0.)DV(L,K)=(CON(L,K)-CMIN(L,K))/(DV(L,K)+BSMALL) + DV(L,K)=MIN(DV(L,K),1.) ENDDO ENDDO -c - enddo C -c t00=rtc()-t00 -c write(6,*) '==>11C',t00*1d6 -c t00=rtc() C ** LIMIT FLUXES C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LS) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA LS=LSC(L) FUHU(L,K)=MIN(DV(L-1,K),DU(L,K))*FUHU(L,K) & +MIN(DU(L-1,K),DV(L,K))*FUHV(L,K) @@ -1244,30 +897,19 @@ c ENDDO ENDDO DO K=1,KS - DO L=LF,LL + DO L=2,LA FWU(L,K)=MIN(DV(L,K),DU(L,K+1))*FWU(L,K) & +MIN(DU(L,K),DV(L,K+1))*FWV(L,K) ENDDO ENDDO -c - enddo C C ** ANTI-DIFFUSIVE ADVECTION CALCULATION C 1100 CONTINUE C -c t00=rtc()-t00 -c write(6,*) '==>12C',t00*1d6 -c t00=rtc() -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& RDZIC) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC RDZIC=DZIC(K) - DO L=LF,LL + DO L=2,LA CH(L,K)=CON(L,K)*HP(L) & +DELT*( (FUHU(L,K)-FUHU(L+1,K) & +FVHU(L,K)-FVHU(LNC(L),K))*DXYIP(L) @@ -1275,19 +917,14 @@ c CON(L,K)=SCB(L)*CH(L,K)*HPI(L)+(1.-SCB(L))*CON(L,K) ENDDO ENDDO -c - enddo C C ** ADD REMAINING SEDIMENT SETTLING AND FLUX C ENDIF -c t00=rtc()-t00 -c write(6,*) '==>13C',t00*1d6 C C ** ANTI-DIFFUSIVE ADVECTIVE FLUX CALCULATION WITH DRY BYPASS C IF(IDRYTBP.GT.0)THEN -c t00=rtc() ! *** DSLLC BEGIN DO L=1,LC WWW(L,0)=0.0 @@ -1434,6 +1071,17 @@ C C C ** SET ANTIDIFFUSIVE FLUXES TO ZERO FOR SOURCE CELLS C + if(n.gt.2400.AND..FALSE.)then ! PMC PMC + L = 6795 + k = 1 + write(*,9999)n,con(l-1,k),con(l,k),con(l+1,k), + 1 fuhu(l-1,k),fuhu(l,k),fuhu(l+1,k), + 1 UHDY2(l-1,k),UHDY2(l,k),UHDY2(l+1,k), + 1 VHDX2(l-1,k),VHDX2(l,k),VHDX2(l+1,k) + ! 1 fwu(l-1,k),fwu(l,k),fwu(l+1,k) + 9999 format(i5,6f12.2/5x,6f12.2) + endif + IF(ISADAC(MVAR).EQ.1)THEN DO K=1,KC DO L=2,LA @@ -1690,34 +1338,21 @@ C ! *** ZERO HEAT FLUXES 2000 IF(MVAR.EQ.2)THEN -c t00=rtc() -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c ! *** ZERO EVAP/RAINFALL - DO L=LF,LL + DO L=1,LC FQC(L,KC)=0. ENDDO IF(ISADAC(MVAR).GE.2)THEN - DO L=LF,LL + DO L=1,LC FQCPAD(L,KC)=0. ENDDO ENDIF IF(ISADAC(MVAR).GT.0)THEN - DO L=LF,LL + DO L=1,LC QSUMPAD(L,KC)=0. ENDDO ENDIF -c - enddo ENDIF - DEALLOCATE(UTERM0) - DEALLOCATE(VTERM0) - DEALLOCATE(SSCORUEWNS) - DEALLOCATE(SSCORWAB) - RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRANQ.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRANQ.for index fde15c129..f85b02201 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRANQ.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRANQ.for @@ -8,6 +8,8 @@ C ** THE NUMBER OF TIME LEVELS IN THE STEP C USE GLOBAL DIMENSION QCON(LCM,0:KCM),QCON1(LCM,0:KCM) + INTEGER L + L=0 C BSMALL=1.0E-6 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRAN_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRAN_mpi.for new file mode 100644 index 000000000..505ce6d6c --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTRAN_mpi.for @@ -0,0 +1,1788 @@ + SUBROUTINE CALTRAN_mpi (ISTL_,IS2TL_,MVAR,MO,CON,CON1) +C +C CHANGE RECORD +C ADDED TRANSPORT BYPASS MASK, IMASKDRY FOR DRY CELLS +C ** SUBROUTINE CALTRAN CALCULATES THE ADVECTIVE +C ** TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO +C ** A NEW VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL INDICATES +C ** THE NUMBER OF TIME LEVELS IN THE STEP +C + USE GLOBAL + USE MPI + + DIMENSION CON(LCM,KCM),CON1(LCM,KCM) + + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::CONTMN + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::CONTMX +! REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::FQCPAD +! REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::QSUMNAD +! REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::QSUMPAD + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::POS + + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::WQBCCON + REAL CTMP + CTMP=0.0 + + IF(.NOT.ALLOCATED(CONTMN))THEN + ALLOCATE(CONTMN(LCM,KCM)) + ALLOCATE(CONTMX(LCM,KCM)) + ALLOCATE(FQCPAD(LCM,KCM)) + ALLOCATE(QSUMNAD(LCM,KCM)) + ALLOCATE(QSUMPAD(LCM,KCM)) + ALLOCATE(POS(LCM,KCM)) + ALLOCATE(WQBCCON(LCM,KCM)) + + DO L=1,LC + FWU(L,0)=0. + FWU(L,KC)=0. + ENDDO + CONTMN=0.0 + CONTMX=0.0 + FQCPAD=0.0 + QSUMNAD=0.0 ! *** NOT USED + QSUMPAD=0.0 + POS=0.0 + WQBCCON=0.0 + ENDIF +C + BSMALL=1.0E-6 + ISUD=1 + IF(ISDYNSTP.EQ.0)THEN + DELT=DT2 + DELTA=DT2 + IF(ISCDCA(MVAR).EQ.2) DELTA=DT + DELTD2=DT + IF(ISTL_.NE.3)THEN + DELT=DT + DELTA=DT + DELTD2=0.5*DT + IF(IS2TIM.EQ.0)ISUD=0 ! *** PMC SINGLE LINE CHANGE + ENDIF + ELSE + DELT=DTDYN + DELTA=DTDYN + DELTD2=0.5*DTDYN + END IF + DELTA4=0.25*DELTA + + S3TIME=MPI_TIC() + ! *** DSLLC BEGIN + M=MO + IF(IS2TL_.EQ.1)THEN + ISUD=1 + IF(MVAR.NE.8)THEN ! *** ARRAYS + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CON1(L,K)=CON(L,K) + ENDDO + ENDDO + ENDIF + ENDIF + MPI_WTIMES(650)=MPI_WTIMES(650)+MPI_TOC(S3TIME) + + S3TIME=MPI_TIC() + ! *** SAVE OLD WQ CONCENTRATIONS FOR OPEN BOUNDARY CELLS + IF(MVAR.EQ.8)THEN + DO IOBC=1,NBCSOP + L=LOBCS(IOBC) + DO K=1,KC + WQBCCON(L,K)=CON(L,K) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(651)=MPI_WTIMES(651)+MPI_TOC(S3TIME) + + ! *** DSLLC END +C +C ** CALCULATED EXTERNAL SOURCES AND SINKS +C + S3TIME=MPI_TIC() + CALL CALFQC_mpi (ISTL_,IS2TL_,MVAR,M,CON,CON1)!, +! & FQCPAD,QSUMPAD,QSUMNAD) + MPI_WTIMES(652)=MPI_WTIMES(652)+MPI_TOC(S3TIME) +C +C +C ** SELECT TRANSPORT OPTION, ISPLIT=1 FOR HORIZONTAL-VERTICAL +C ** OPERATOR SPLITTING +C ** BEGIN COMBINED ADVECTION SCHEME +C ** ADVECTIVE FLUX CALCULATION +C + IF(ISTL_.EQ.2) GOTO 300 + IF(ISCDCA(MVAR).EQ.0) GOTO 300 + IF(ISCDCA(MVAR).EQ.1) GOTO 400 + IF(ISCDCA(MVAR).EQ.2) GOTO 350 +C +C ** CALCULATE ADVECTIVE FLUXES BY UPWIND DIFFERENCE WITH ADVECTION +C ** AVERAGED BETWEEN (N) AND (N+1) OR (N-1) AND (N+1) AND ADVECTED +C ** AT (N) OR (N-1) IF ISTL EQUALS 2 OR 3 RESPECTIVELY +C + 300 CONTINUE +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(CON1,ic) + MPI_WTIMES(692)=MPI_WTIMES(692)+MPI_TOC(S3TIME) + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FUHU) + call collect_in_zero_array(FVHU) + call collect_in_zero_array(FWU ) + call collect_in_zero_array(UHDY2 ) + call collect_in_zero_array(VHDX2 ) + call collect_in_zero_array(CON1 ) + call collect_in_zero_array(W2 ) + IF(MYRANK.EQ.0) PRINT*, '0FUHU = ', sum(abs(dble(FUHU))) + IF(MYRANK.EQ.0) PRINT*, '0FVHU = ', sum(abs(dble(FVHU))) + IF(MYRANK.EQ.0) PRINT*, '0FWU = ', sum(abs(dble(FWU ))) + IF(MYRANK.EQ.0) PRINT*, '0UHDY2 = ', sum(abs(dble(UHDY2 ))) + IF(MYRANK.EQ.0) PRINT*, '0VHDX2 = ', sum(abs(dble(VHDX2 ))) + IF(MYRANK.EQ.0) PRINT*, '0CON1 = ', sum(abs(dble(CON1 ))) + IF(MYRANK.EQ.0) PRINT*, '0W2 = ', sum(abs(dble(W2 ))) + endif + call mpi_barrier(mpi_comm_world,ierr) + + S3TIME=MPI_TIC() + IF(IDRYTBP.EQ.0)THEN + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FUHU(L,K)=UHDY2(L,K)*CON1(LUPU(L,K),K) + FVHU(L,K)=VHDX2(L,K)*CON1(LUPV(L,K),K) + ENDDO + ENDDO + IF(KC.GT.1)THEN + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FWU(L,K)=W2(L,K)*CON1(L,KUPW(L,K)) + ENDDO + ENDDO + ENDIF + ELSE + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + FUHU(L,K)=UHDY2(L,K)*CON1(LUPU(L,K),K) + FVHU(L,K)=VHDX2(L,K)*CON1(LUPV(L,K),K) + ELSE + FUHU(L,K)=0. + FVHU(L,K)=0. + ENDIF + ENDDO + ENDDO + IF(KC.GT.1)THEN + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + FWU(L,K)=W2(L,K)*CON1(L,KUPW(L,K)) + ELSE + FWU(L,K)=0. + ENDIF + ENDDO + ENDDO + ENDIF + ENDIF + MPI_WTIMES(653)=MPI_WTIMES(653)+MPI_TOC(S3TIME) +C + call mpi_barrier(mpi_comm_world,ierr) + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FUHU) + call collect_in_zero_array(FVHU) + call collect_in_zero_array(FWU ) + IF(MYRANK.EQ.0) PRINT*, '1FUHU = ', sum(abs(dble(FUHU))) + IF(MYRANK.EQ.0) PRINT*, '1FVHU = ', sum(abs(dble(FVHU))) + IF(MYRANK.EQ.0) PRINT*, '1FWU = ', sum(abs(dble(FWU ))) + if(n.eq.12.and.myrank.eq.0)then + do l=2,lcm ; do k=1,kcm + print*, l,k,fvhu(l,k) + enddo ; enddo + endif + endif + + GOTO 500 +C +C ** CALCULATE ADVECTIVE FLUXES BY UPWIND DIFFERENCE WITH ADVECTION +C ** AVERAGED BETWEEN (N-1) AND (N+1) AND ADVECTED FIELD AVERAGED +C ** BETWEEN AT (N-1) AND (N) IF ISTL 3 ONLY +C + 350 CONTINUE +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(CONT,ic) + MPI_WTIMES(692)=MPI_WTIMES(692)+MPI_TOC(S3TIME) + + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CONT(L,K)=0.5*(CON(L,K)+CON1(L,K)) + & +DELT*0.5*FQC(L,K)*DXYIP(L)/H2P(L) + ENDDO + ENDDO + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FUHU(L,K)=UHDY2(L,K)*CONT(LUPU(L,K),K) + FVHU(L,K)=VHDX2(L,K)*CONT(LUPV(L,K),K) + ENDDO + ENDDO + IF(KC.GT.1)THEN + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FWU(L,K)=W2(L,K)*CONT(L,KUPW(L,K)) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(654)=MPI_WTIMES(654)+MPI_TOC(S3TIME) +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FUHU) + call collect_in_zero_array(FVHU) + call collect_in_zero_array(FWU ) + IF(MYRANK.EQ.0) PRINT*, '2FUHU = ', sum(abs(dble(FUHU))) + IF(MYRANK.EQ.0) PRINT*, '2FVHU = ', sum(abs(dble(FVHU))) + IF(MYRANK.EQ.0) PRINT*, '2FWU = ', sum(abs(dble(FWU ))) + endif + GOTO 500 +C +C ** CALCULATE ADVECTIVE FLUXES BY CENTRAL DIFFERENCE WITH TRANSPORT +C ** AVERAGED BETWEEN (N+1) AND (N-1) AND TRANSPORTED FIELD AT (N) +C + 400 CONTINUE +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(CON,ic) + MPI_WTIMES(692)=MPI_WTIMES(692)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + FUHU(L,K)=0.5*UHDY2(L,K)*(CON(L,K)+CON(L-1,K)) + FVHU(L,K)=0.5*VHDX2(L,K)*(CON(L,K)+CON(LS,K)) + ENDDO + ENDDO + MPI_WTIMES(655)=MPI_WTIMES(655)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(VHDX2,ic) + CALL broadcast_boundary_array(UHDY2,ic) + MPI_WTIMES(693)=MPI_WTIMES(693)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + DO K=1,KC + DO LL=1,NCBS + L=LCBS(LL) + LN=LNC(L) + IF(VHDX2(LN,K).LT.0.) FVHU(LN,K)=VHDX2(LN,K)*CON1(LN,K) + ENDDO + DO LL=1,NCBW + L=LCBW(LL) + IF(UHDY2(L+1,K).LT.0.) FUHU(L+1,K)=UHDY2(L+1,K)*CON1(L+1,K) + ENDDO + DO LL=1,NCBE + L=LCBE(LL) + IF(UHDY2(L,K).GT.0.) FUHU(L,K)=UHDY2(L,K)*CON1(L-1,K) + ENDDO + DO LL=1,NCBN + L=LCBN(LL) + LS =LSC(L) + IF(VHDX2(L,K).GT.0.) FVHU(L,K)=VHDX2(L,K)*CON1(LS,K) + ENDDO + ENDDO + MPI_WTIMES(656)=MPI_WTIMES(656)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FWU(L,K)=0.5*W2(L,K)*(CON(L,K+1)+CON(L,K)) + ENDDO + ENDDO + MPI_WTIMES(657)=MPI_WTIMES(657)+MPI_TOC(S3TIME) +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FUHU) + call collect_in_zero_array(FVHU) + call collect_in_zero_array(FWU ) + IF(MYRANK.EQ.0) PRINT*, '3FUHU = ', sum(abs(dble(FUHU))) + IF(MYRANK.EQ.0) PRINT*, '3FVHU = ', sum(abs(dble(FVHU))) + IF(MYRANK.EQ.0) PRINT*, '3FWU = ', sum(abs(dble(FWU ))) + endif +C ** STANDARD ADVECTION CALCULATION +C + 500 CONTINUE +C +C BEGIN IF ON TRANSPORT OPTION CHOICE +C + ! *** CALCULATE AND ADD HORIZONTAL DIFFUSION FLUX (PMC MOVED) + S3TIME=MPI_TIC() + IF(ISHDMF.EQ.2) CALL CALDIFF_mpi (ISTL_,M,CON1) + MPI_WTIMES(658)=MPI_WTIMES(658)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(FUHU,ic) + CALL broadcast_boundary_array(FVHU,ic) + CALL broadcast_boundary_array(FWU,ic) + MPI_WTIMES(694)=MPI_WTIMES(694)+MPI_TOC(S3TIME) +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FUHU) + call collect_in_zero_array(FVHU) + call collect_in_zero_array(FWU ) + call collect_in_zero_array(CON1 ) + call collect_in_zero_array(FQC ) + call collect_in_zero(H1P ) + call COLLECT_IN_ZERO_INT(IMASKDRY) + IF(MYRANK.EQ.0) PRINT*, 'FUHU = ', sum(abs(dble(FUHU))) + IF(MYRANK.EQ.0) PRINT*, 'FVHU = ', sum(abs(dble(FVHU))) + IF(MYRANK.EQ.0) PRINT*, 'FWU = ', sum(abs(dble(FWU ))) + IF(MYRANK.EQ.0) PRINT*, 'CON1 = ', sum(abs(dble(CON1 ))) + IF(MYRANK.EQ.0) PRINT*, 'FQC = ', sum(abs(dble(FQC ))) + IF(MYRANK.EQ.0) PRINT*, 'H1P = ', sum(abs(dble(H1P ))) + IF(MYRANK.EQ.0) PRINT*, 'IMASKDRY= ',sum(abs(dble(IMASKDRY ))) + endif + + ! *** IF ISACAC EQ 0 INCLUDE FQC MASS SOURCES IN UPDATE + IF(ISCDCA(MVAR).EQ.0)THEN + IF(ISTL_.EQ.2)THEN +C + S3TIME=MPI_TIC() + IF(IDRYTBP.EQ.0)THEN + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CH(L,K)=CON1(L,K)*H1P(L) + & +DELT*( ( RDZIC*FQC(L,K) + & +FUHU(L,K)-FUHU(L+1,K) + & +FVHU(L,K)-FVHU(LNC(L),K))*DXYIP(L) + & +(FWU(L,K-1)-FWU(L,K))*RDZIC ) + ENDDO + ENDDO + ELSE + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(CH) + IF(MYRANK.EQ.0) PRINT*, 'cc','CH = ', sum(abs(dble(CH))) + endif + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(IMASKDRY(L).EQ.0) + & CH(L,K)=CON1(L,K)*H1P(L) + & +DELT*( ( RDZIC*FQC(L,K)+FUHU(L,K)-FUHU(L+1,K) + & +FVHU(L,K)-FVHU(LNC(L),K))*DXYIP(L) + & +(FWU(L,K-1)-FWU(L,K))*RDZIC ) + IF(IMASKDRY(L).EQ.1) + & CH(L,K)=CON1(L,K)*H1P(L) + & +DELT*( ( FQC(L,K) )*DXYIP(L) ) + IF(IMASKDRY(L).EQ.2) + & CH(L,K)=CON1(L,K)*H1P(L) + ENDDO + ENDDO + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(CH) + IF(MYRANK.EQ.0) PRINT*, 'c0','CH = ', sum(abs(dble(CH))) + endif + ENDIF + IF(ISFCT(MVAR).GE.1.AND.ISADAC(MVAR).GT.0)THEN ! *** DSLLC SINGLE LINE + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CON2(L,K)=CON1(L,K) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(659)=MPI_WTIMES(659)+MPI_TOC(S3TIME) +C +C ELSE ON TIME LEVEL CHOICE FOR ISCDCA=0 +C + ELSE +C + S3TIME=MPI_TIC() + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CH(L,K)=CON1(L,K)*H2P(L) + & +DELT*( ( RDZIC*FQC(L,K) + & +FUHU(L,K)-FUHU(L+1,K) + & +FVHU(L,K)-FVHU(LNC(L),K))*DXYIP(L) + & +(FWU(L,K-1)-FWU(L,K))*RDZIC ) + ENDDO + ENDDO + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(CH) + IF(MYRANK.EQ.0) PRINT*, 'c1','CH = ', sum(abs(dble(CH))) + endif + IF(ISFCT(MVAR).GE.1.AND.ISADAC(MVAR).GT.0)THEN ! *** DSLLC SINGLE LINE + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CON2(L,K)=CON(L,K) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(660)=MPI_WTIMES(660)+MPI_TOC(S3TIME) +C + ENDIF +C + if(PRINT_SUM)THEN + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + IF(MYRANK.EQ.0)THEN + IF(MO.LE.NWQV)PRINT*, n,'h11WQV = ', sum(abs(dble(WQV))),mo + ENDIF + ENDIF +C ENDIF ON TIME LEVEL CHOICE FOR ISCDCA=0 +C + IF(ISUD.EQ.1.AND.IS2TL_.EQ.0.AND.MVAR.NE.8)THEN + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(L) + DO IOBC=1,NBCSOP + L=LOBCS(IOBC) + IF(ISDOMAIN(L))THEN + CON(L,K)=CON1(L,K) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(661)=MPI_WTIMES(661)+MPI_TOC(S3TIME) + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CON1(L,K)=CON(L,K) + ENDDO + ENDDO + MPI_WTIMES(662)=MPI_WTIMES(662)+MPI_TOC(S3TIME) + ENDIF + ! *** UPDATE NEW CONCENTRATIONS + S3TIME=MPI_TIC() +C DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CON(L,1:KC)=CH(L,1:KC)*HPI(L) + ENDDO +C ENDDO + MPI_WTIMES(663)=MPI_WTIMES(663)+MPI_TOC(S3TIME) +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(CON) + call collect_in_zero(HPI) + IF(MYRANK.EQ.0) PRINT*, 'd1','CON = ', sum(abs(dble(CON))) + IF(MYRANK.EQ.0) PRINT*, 'e1','HPI = ', sum(abs(dble(HPI))) + endif +C *** ELSE ON TRANSPORT OPTION CHOICE +C *** IF ISACAC NE 0 DO NOT INCLUDE FQC MASS SOURCES IN UPDATE +C + ELSE +C +C BEGIN IF ON TIME LEVEL CHOICE FOR ISCDCA.NE.0 +C + IF(ISTL_.EQ.2)THEN +C + S3TIME=MPI_TIC() + IF(IDRYTBP.EQ.0)THEN + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CH(L,K)=CON1(L,K)*H1P(L) + & +DELT*( ( RDZIC*FQC(L,K) + & +FUHU(L,K)-FUHU(L+1,K) + & +FVHU(L,K)-FVHU(LNC(L),K))*DXYIP(L) + & +(FWU(L,K-1)-FWU(L,K))*RDZIC ) + ENDDO + ENDDO + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(CH) + IF(MYRANK.EQ.0) PRINT*, 'c2','CH = ', sum(abs(dble(CH))) + endif + ELSE + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(IMASKDRY(L).EQ.0) + & CH(L,K)=CON1(L,K)*H1P(L) + & +DELT*( ( RDZIC*FQC(L,K) + & +FUHU(L,K)-FUHU(L+1,K) + & +FVHU(L,K)-FVHU(LNC(L),K))*DXYIP(L) + & +(FWU(L,K-1)-FWU(L,K))*RDZIC ) + IF(IMASKDRY(L).EQ.1) + & CH(L,K)=CON1(L,K)*H1P(L) + & +DELT*( ( FQC(L,K) )*DXYIP(L) ) + IF(IMASKDRY(L).EQ.2) + & CH(L,K)=CON1(L,K)*H1P(L) + ENDDO + ENDDO + ENDIF + IF(ISFCT(MVAR).GE.1)THEN + CON2=CON1 ! *** ARRAYS + ENDIF + MPI_WTIMES(664)=MPI_WTIMES(664)+MPI_TOC(S3TIME) +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(CH) + IF(MYRANK.EQ.0) PRINT*, 'c3','CH = ', sum(abs(dble(CH))) + endif +C ELSE ON TIME LEVEL CHOICE FOR ISCDCA.NE.0 AND ISTL.EQ.3 +C + ELSE +C + S3TIME=MPI_TIC() + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CH(L,K)=CON1(L,K)*H2P(L) + & +DELT*( ( RDZIC*FQC(L,K)+FUHU(L,K)-FUHU(L+1,K) + & +FVHU(L,K)-FVHU(LNC(L),K))*DXYIP(L) + & +(FWU(L,K-1)-FWU(L,K))*RDZIC ) + ENDDO + ENDDO + IF(ISFCT(MVAR).GE.1)THEN + CON2=CON ! *** ARRAYS + ENDIF + MPI_WTIMES(664)=MPI_WTIMES(664)+MPI_TOC(S3TIME) +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(CH) + IF(MYRANK.EQ.0) PRINT*, 'c4','CH = ', sum(abs(dble(CH))) + endif + ENDIF +C +C ENDIF ON TIME LEVEL CHOICE FOR ISCDCA.NE.0 +C + S3TIME=MPI_TIC() + IF(ISUD.EQ.1.AND.MVAR.NE.8)THEN + DO K=1,KC + DO IOBC=1,NBCSOP + L=LOBCS(IOBC) + CON(L,K)=CON1(L,K) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CON1(L,K)=CON(L,K) + ENDDO + ENDDO + ENDIF + ! *** PMC-BOUNDARY CONDITIONS APPLIED BELOW + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CON(L,K)=CH(L,K)*HPI(L) + ENDDO + ENDDO + MPI_WTIMES(664)=MPI_WTIMES(664)+MPI_TOC(S3TIME) + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(CON) + call collect_in_zero(HPI) + IF(MYRANK.EQ.0) PRINT*, 'd2','CON = ', sum(abs(dble(CON))) + IF(MYRANK.EQ.0) PRINT*, 'e2','HPI = ', sum(abs(dble(HPI))) + endif +C + ENDIF +C +C ENDIF ON TRANSPORT OPTION CHOICE +C +C *** APPLY OPEN BOUNDARY CONDITIONS, BASED ON DIRECTION OF FLOW +C + ! *** ALL OTHER WATER CONSTITUENTS + S3TIME=MPI_TIC() + IF(MVAR.EQ.8)THEN !.AND.IWQPSL.EQ.2)THEN + M=4+NTOX+NSED+NSND+MO + ! *** RESTORE ORIGINAL CONCENTRATIONS PRIOR TO APPLYING OPEN BC'S + DO K=1,KC + DO IOBC=1,NBCSOP + L=LOBCS(IOBC) + CON1(L,K)=WQBCCON(L,K) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(665)=MPI_WTIMES(665)+MPI_TOC(S3TIME) +C + ! *** SOUTH OPEN BC + S3TIME=MPI_TIC() + DO K=1,KC + DO LL=1,NCBS + IF(ISDOMAIN(LCBS(LL)))THEN + NSID=NCSERS(LL,M) + L=LCBS(LL) + LN=LNC(L) + IF(VHDX2(LN,K).LE.0.)THEN + ! *** FLOWING OUT OF DOMAIN + IF(ISTL_.EQ.2)THEN + CTMP=CON1(L,K)+DELT*(VHDX2(LN,K)*CON1(L,K) + & -FVHU(LN,K))*DXYIP(L)*HPI(L) + ELSE + IF(ISCDCA(MVAR).NE.2)CTMP=CON1(L,K)+DELT*(VHDX2(LN,K) + & *CON1(L,K)-FVHU(LN,K))*DXYIP(L)*HPI(L) + IF(ISCDCA(MVAR).EQ.2) CTMP=0.5*(CON1(L,K)+CON(L,K)) + & +0.5*(CON1(L,K)-CON(L,K))*H2P(L)*HPI(L) + & +DELT*(0.5*VHDX2(LN,K)*(CON1(L,K)+CON(L,K)) + & -FVHU(LN,K))*DXYIP(L)*HPI(L) + CON1(L,K)=CON(L,K) + ENDIF + CON(L,K)=CTMP + CBSTMP=CBS(LL,1,M)+CSERT(1,NSID,M) + IF(M.EQ.1.AND.CON(L,K).GT.CBSTMP)THEN + CON(L,K)=CBSTMP + ENDIF + CLOS(LL,K,M)=CON(L,K) + NLOS(LL,K,M)=N + ELSE + ! *** FLOWING INTO DOMAIN + IF(ISUD.EQ.1) CON1(L,K)=CON(L,K) + CBT=WTCI(K,1)*CBS(LL,1,M)+WTCI(K,2)*CBS(LL,2,M)+CSERT( + & K,NSID,M) + NMNLO=N-NLOS(LL,K,M) + IF(NMNLO.GE.NTSCRS(LL))THEN + CON(L,K)=CBT + ELSE + CON(L,K)=CLOS(LL,K,M) + & +(CBT-CLOS(LL,K,M))*FLOAT(NMNLO)/FLOAT(NTSCRS(LL)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + MPI_WTIMES(666)=MPI_WTIMES(666)+MPI_TOC(S3TIME) +C + ! *** WEST OPEN BC + S3TIME=MPI_TIC() + DO K=1,KC + DO LL=1,NCBW + IF(ISDOMAIN(LCBW(LL)))THEN + NSID=NCSERW(LL,M) + L=LCBW(LL) + IF(UHDY2(L+1,K).LE.0.)THEN + ! *** FLOWING OUT OF DOMAIN + IF(ISTL_.EQ.2)THEN + CTMP=CON1(L,K)+DELT*(UHDY2(L+1,K)*CON1(L,K) + & -FUHU(L+1,K))*DXYIP(L)*HPI(L) + ELSE + IF(ISCDCA(MVAR).NE.2) CTMP=CON1(L,K) + & +DELT*(UHDY2(L+1,K)*CON1(L,K)-FUHU(L+1,K))*DXYIP(L) + & *HPI(L) + IF(ISCDCA(MVAR).EQ.2) CTMP=0.5*(CON1(L,K)+CON(L,K)) + & +0.5*(CON1(L,K)-CON(L,K))*H2P(L)*HPI(L) + & +DELT*(0.5*UHDY2(L+1,K)*(CON1(L,K)+CON(L,K)) + & -FUHU(L+1,K))*DXYIP(L)*HPI(L) + CON1(L,K)=CON(L,K) + ENDIF + CON(L,K)=CTMP + CBWTMP=CBW(LL,1,M)+CSERT(1,NSID,M) + IF(M.EQ.1.AND.CON(L,K).GT.CBWTMP) CON(L,K)=CBWTMP + CLOW(LL,K,M)=CON(L,K) + NLOW(LL,K,M)=N + ELSE + ! *** FLOWING INTO DOMAIN + IF(ISUD.EQ.1) CON1(L,K)=CON(L,K) + CBT=WTCI(K,1)*CBW(LL,1,M)+WTCI(K,2)*CBW(LL,2,M)+CSERT( + & K,NSID,M) + NMNLO=N-NLOW(LL,K,M) + IF(NMNLO.GE.NTSCRW(LL))THEN + CON(L,K)=CBT + ELSE + CON(L,K)=CLOW(LL,K,M) + & +(CBT-CLOW(LL,K,M))*FLOAT(NMNLO)/FLOAT(NTSCRW(LL)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + MPI_WTIMES(667)=MPI_WTIMES(667)+MPI_TOC(S3TIME) +C + ! *** EAST OPEN BC + S3TIME=MPI_TIC() + DO K=1,KC + DO LL=1,NCBE + IF(ISDOMAIN(LCBE(LL)))THEN + NSID=NCSERE(LL,M) + L=LCBE(LL) + IF(UHDY2(L,K).GE.0.)THEN + ! *** FLOWING OUT OF DOMAIN + IF(ISTL_.EQ.2)THEN + CTMP=CON1(L,K)+DELT*(FUHU(L,K) + & -UHDY2(L,K)*CON1(L,K))*DXYIP(L)*HPI(L) + ELSE + IF(ISCDCA(MVAR).NE.2) CTMP=CON1(L,K)+DELT*(FUHU(L,K) + & -UHDY2(L,K)*CON1(L,K))*DXYIP(L)*HPI(L) + IF(ISCDCA(MVAR).EQ.2) CTMP=0.5*(CON1(L,K)+CON(L,K)) + & +0.5*(CON1(L,K)-CON(L,K))*H2P(L)*HPI(L)+DELT*(FUHU(L,K) + & -0.5*UHDY2(L,K)*(CON1(L,K)+CON(L,K)))*DXYIP(L)*HPI(L) + CON1(L,K)=CON(L,K) + ENDIF + CON(L,K)=CTMP + CBETMP=CBE(LL,1,M)+CSERT(1,NSID,M) + IF(M.EQ.1.AND.CON(L,K).GT.CBETMP) CON(L,K)=CBETMP + CLOE(LL,K,M)=CON(L,K) + NLOE(LL,K,M)=N + ELSE + ! *** FLOWING INTO DOMAIN + IF(ISUD.EQ.1) CON1(L,K)=CON(L,K) + CBT=WTCI(K,1)*CBE(LL,1,M)+WTCI(K,2)*CBE(LL,2,M)+CSERT( + & K,NSID,M) + NMNLO=N-NLOE(LL,K,M) + IF(NMNLO.GE.NTSCRE(LL))THEN + CON(L,K)=CBT + ELSE + CON(L,K)=CLOE(LL,K,M) + & +(CBT-CLOE(LL,K,M))*FLOAT(NMNLO)/FLOAT(NTSCRE(LL)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + MPI_WTIMES(668)=MPI_WTIMES(668)+MPI_TOC(S3TIME) +C + ! *** NORTH OPEN BC + S3TIME=MPI_TIC() + DO K=1,KC + DO LL=1,NCBN + IF(ISDOMAIN(LCBN(LL)))THEN + NSID=NCSERN(LL,M) + L=LCBN(LL) + LS=LSC(L) +! if(lcbn(ll).eq.16759.and.k.eq.1) print*,'f1',nsid,l,ls + IF(VHDX2(L,K).GE.0.)THEN + ! *** FLOWING OUT OF DOMAIN + IF(ISTL_.EQ.2)THEN + CTMP=CON1(L,K)+DELT*(FVHU(L,K) + & -VHDX2(L,K)*CON1(L,K))*DXYIP(L)*HPI(L) +! if(lcbn(ll).eq.16759.and.k.eq.1) print*,'f2',ctmp + ELSE + IF(ISCDCA(MVAR).NE.2) CTMP=CON1(L,K)+DELT*(FVHU(L,K) + & -VHDX2(L,K)*CON1(L,K))*DXYIP(L)*HPI(L) + IF(ISCDCA(MVAR).EQ.2) CTMP=0.5*(CON1(L,K)+CON(L,K)) + & +0.5*(CON1(L,K)-CON(L,K))*H2P(L)*HPI(L)+DELT*(FVHU(L,K) + & -0.5*VHDX2(L,K)*(CON1(L,K)+CON(L,K)))*DXYIP(L)*HPI(L) + CON1(L,K)=CON(L,K) +! if(lcbn(ll).eq.16759.and.k.eq.1) print*,'f3',ctmp + ENDIF + CON(L,K)=CTMP + CBNTMP=CBN(LL,1,M)+CSERT(1,NSID,M) +! if(lcbn(ll).eq.16759.and.k.eq.1) print*,'f4',CON(L,K) + IF(M.EQ.1.AND.CON(L,K).GT.CBNTMP) CON(L,K)=CBNTMP +! if(lcbn(ll).eq.16759.and.k.eq.1) print*,'f5',CON(L,K) + CLON(LL,K,M)=CON(L,K) + NLON(LL,K,M)=N + ELSE + ! *** FLOWING INTO DOMAIN + IF(ISUD.EQ.1) CON1(L,K)=CON(L,K) + CBT=WTCI(K,1)*CBN(LL,1,M)+WTCI(K,2)*CBN(LL,2,M)+CSERT( + & K,NSID,M) + NMNLO=N-NLON(LL,K,M) + IF(NMNLO.GE.NTSCRN(LL))THEN + CON(L,K)=CBT +! if(lcbn(ll).eq.16759.and.k.eq.1) print*,'f7',CON(L,K) + ELSE + CON(L,K)=CLON(LL,K,M) + & +(CBT-CLON(LL,K,M))*FLOAT(NMNLO)/FLOAT(NTSCRN(LL)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + MPI_WTIMES(669)=MPI_WTIMES(669)+MPI_TOC(S3TIME) +C +C ** ANTI-DIFFUSIVE ADVECTIVE FLUX CALCULATION +C + IF(ISADAC(MVAR).EQ.0) GOTO 2000 + IF(ISCDCA(MVAR).EQ.1) GOTO 2000 + IF(ISFCT(MVAR).GT.0)THEN + ! *** DU & DV are used as a temporary array in this sub + DO K=1,KC + DU(1,K)=0. + DV(1,K)=0. + DU(LC,K)=0. + DV(LC,K)=0. + ENDDO + ENDIF +C +C ** STANDARD ANTI-DIFFUSIVE ADVECTIVE FLUX CALCULATION +C + ! *** PMC BEGIN BLOCK + ! *** GET ONLY POSITIVE CONCENTRATIONS + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + POS(L,K)=MAX(CON(L,K),0.) + ENDDO + ENDDO + CALL broadcast_boundary_array(POS,ic) + MPI_WTIMES(670)=MPI_WTIMES(670)+MPI_TOC(S3TIME) + ! *** PMC END BLOCK +C + IF(IDRYTBP.EQ.0)THEN + S3TIME=MPI_TIC() + DO K=1,KC + UUU(LC,K)=0.0 + VVV(LC,K)=0.0 + UUU(1,K)=0.0 + VVV(1,K)=0.0 + ENDDO +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + WWW(L,0)=0.0 + WWW(L,KC)=0.0 + ENDDO +C + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + UUU(L,K)=U2(L,K)*(POS(L,K)-POS(L-1,K))*DXIU(L) + VVV(L,K)=V2(L,K)*(POS(L,K)-POS(LS,K))*DYIV(L) + ENDDO + ENDDO + DO K=1,KS + RDZIG=DZIG(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WWW(L,K)=W2(L,K)*(POS(L,K+1)-POS(L,K))*HPI(L)*RDZIG + ENDDO + ENDDO + MPI_WTIMES(671)=MPI_WTIMES(671)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(UUU,ic) + CALL broadcast_boundary_array(VVV,ic) + CALL broadcast_boundary_array(WWW,ic) + MPI_WTIMES(696)=MPI_WTIMES(696)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(CON,ic) + CALL broadcast_boundary_array(CON1,ic) + MPI_WTIMES(695)=MPI_WTIMES(695)+MPI_TOC(S3TIME) + + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(FQCPAD,ic) + CALL broadcast_boundary_array(QSUMPAD,ic) + MPI_WTIMES(695)=MPI_WTIMES(695)+MPI_TOC(S3TIME) + + S3TIME=MPI_TIC() + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO PRIVATE(LN,LS,LNW,LSE,AUHU,AVHV,UTERM,VTERM, +!$OMP+ SSCORUE,SSCORUW,SSCORVN,SSCORVS,SSCORU,SSCORV,UHU,VHV) + DO L=LMPI2,LMPILA + LN=LNC(L) + LS=LSC(L) + LNW=LNWC(L) + LSE=LSEC(L) + AUHU=ABS(UHDY2(L,K)) + AVHV=ABS(VHDX2(L,K)) + UTERM=AUHU*(POS(L,K)-POS(L-1,K)) + VTERM=AVHV*(POS(L,K)-POS(LS,K)) + IF(ISADAC(MVAR).GE.2)THEN + SSCORUE=DELTA*RDZIC*DXYIP(L )*HPI(L )*(FQCPAD(L ,K) + & -QSUMPAD(L ,K)*CON(L ,K)) + SSCORUW=DELTA*RDZIC*DXYIP(L-1)*HPI(L-1)*(FQCPAD(L-1,K) + & -QSUMPAD(L-1,K)*CON(L-1,K)) + SSCORVN=DELTA*RDZIC*DXYIP(L )*HPI(L )*(FQCPAD(L ,K) + & -QSUMPAD(L ,K)*CON(L ,K)) + SSCORVS=DELTA*RDZIC*DXYIP(LS )*HPI(LS )*(FQCPAD(LS ,K) + & -QSUMPAD(LS ,K)*CON(LS ,K)) + SSCORU=MAX(UHDY2(L,K),0.0)*SSCORUW+MIN(UHDY2(L,K),0.0) + & *SSCORUE + SSCORV=MAX(VHDX2(L,K),0.0)*SSCORVS+MIN(VHDX2(L,K),0.0) + & *SSCORVN + UTERM=UTERM+SSCORU + VTERM=VTERM+SSCORV + ENDIF + IF(UHDY2(L,K).GE.0.0)THEN + UTERM=UTERM-0.5*DELTA*UHDY2(L,K)* + & (VVV(LNW,K)+VVV(L-1,K)+WWW(L-1,K)+WWW(L-1,K-1) + & +UUU(L,K)+UUU(L-1,K)) + ELSE + UTERM=UTERM-0.5*DELTA*UHDY2(L,K)* + & (VVV(LN,K)+VVV(L,K)+WWW(L,K)+WWW(L,K-1) + & +UUU(L,K)+UUU(L+1,K)) + ENDIF + IF(VHDX2(L,K).GE.0.0)THEN + VTERM=VTERM-0.5*DELTA*VHDX2(L,K)* + & (UUU(LS,K)+UUU(LSE,K)+WWW(LS,K)+WWW(LS,K-1) + & +VVV(LS,K)+VVV(L,K)) + ELSE + VTERM=VTERM-0.5*DELTA*VHDX2(L,K)* + & (UUU(L,K)+UUU(L+1,K)+WWW(L,K)+WWW(L,K-1) + & +VVV(LN,K)+VVV(L,K)) + ENDIF + IF(ISFCT(MVAR).GE.2)THEN + FUHU(L,K)=0.5*UTERM + FVHU(L,K)=0.5*VTERM + IF(ISFCT(MVAR).EQ.3)THEN + FUHU(L,K)=UTERM + FVHU(L,K)=VTERM + ENDIF + ELSE + UHU=UTERM/(POS(L,K)+POS(L-1,K)+BSMALL) + VHV=VTERM/(POS(L,K)+POS(LS,K)+BSMALL) + FUHU(L,K)=MAX(UHU,0.)*POS(L-1,K) + & +MIN(UHU,0.)*POS(L,K) + FVHU(L,K)=MAX(VHV,0.)*POS(LS,K) + & +MIN(VHV,0.)*POS(L,K) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(672)=MPI_WTIMES(672)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN,AWW,WTERM,SSCORWA,SSCORWB,SSCORW,WW) + DO L=LMPI2,LMPILA + LN=LNC(L) + AWW=ABS(W2(L,K)) + WTERM=AWW*(POS(L,K+1)-POS(L,K)) + IF(ISADAC(MVAR).GE.2)THEN + SSCORWA=DELTA*DZIG(K+1)*HPI(L)*DXYIP(L) + & *(FQCPAD(L,K+1)-QSUMPAD(L,K+1)*POS(L,K+1)) + SSCORWB=DELTA*DZIG(K)*HPI(L)*DXYIP(L) + & *(FQCPAD(L,K )-QSUMPAD(L,K )*POS(L,K )) + SSCORW=MAX(W2(L,K),0.0)*SSCORWB+MIN(W2(L,K),0.0)*SSCORWA + WTERM=WTERM+SSCORW + ENDIF + IF(W2(L,K).GE.0.0)THEN + WTERM=WTERM-0.5*DELTA*W2(L,K)* + & (UUU(L,K)+UUU(L+1,K)+VVV(L,K)+VVV(LN,K) + & +WWW(L,K)+WWW(L,K-1)) + ELSE + WTERM=WTERM-0.5*DELTA*W2(L,K)* + & (UUU(L+1,K+1)+UUU(L,K+1)+VVV(LN,K+1)+VVV(L,K+1) + & +WWW(L,K)+WWW(L,K+1)) + ENDIF + IF(ISFCT(MVAR).GE.2)THEN + FWU(L,K)=0.5*WTERM + IF(ISFCT(MVAR).EQ.3)THEN + FWU(L,K)=WTERM + ENDIF + ELSE + WW=WTERM/(POS(L,K+1)+POS(L,K)+BSMALL) + FWU(L,K)=MAX(WW,0.)*POS(L,K) + & +MIN(WW,0.)*POS(L,K+1) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(673)=MPI_WTIMES(673)+MPI_TOC(S3TIME) +C +C ** SET ANTIDIFFUSIVE FLUXES TO ZERO FOR SOURCE CELLS +C + S3TIME=MPI_TIC() + IF(ISADAC(MVAR).EQ.1)THEN + ! *** ANTIDIFFUSION TURNED OFF FOR SOURCE CELLS + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LN,LS) + DO L=LMPI2,LMPILA + LN=LNC(L) + LS=LSC(L) + IF(QSUMPAD(L,K).GT.0.0)THEN + FUHU(L ,K)=0. + FUHU(L+1,K)=0. + FVHU(L ,K)=0. + FVHU(LN ,K)=0. + FWU(L,K )=0. + FWU(L,K-1)=0. + ENDIF + IF(QSUMPAD(LS,K).GT.0.0)THEN ! MPI + FVHU(L ,K)=0. + ENDIF + IF(QSUMPAD(L-1,K).GT.0.0)THEN ! MPI + FUHU(L ,K)=0. + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(674)=MPI_WTIMES(674)+MPI_TOC(S3TIME) +C +C ** SET ANTIDIFFUSIVE FLUXES TO ZERO FOR OPEN BOUNDARY CELLS +C + S3TIME=MPI_TIC() + DO K=1,KC + DO LL=1,NCBS + L=LCBS(LL) + LN=LNC(L) + FVHU(LN,K)=0.0 + ENDDO + DO LL=1,NCBW + L=LCBW(LL) + FUHU(L+1,K)=0.0 + ENDDO + DO LL=1,NCBE + L=LCBE(LL) + FUHU(L,K)=0.0 + ENDDO + DO LL=1,NCBN + L=LCBN(LL) + FVHU(L,K)=0.0 + ENDDO + ENDDO + MPI_WTIMES(675)=MPI_WTIMES(675)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(FUHU,ic) + CALL broadcast_boundary_array(FVHU,ic) + CALL broadcast_boundary_array(FWU,ic) + MPI_WTIMES(697)=MPI_WTIMES(697)+MPI_TOC(S3TIME) +C +C ** CALCULATE AND APPLY FLUX CORRECTED TRANSPORT LIMITERS +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(con) + IF(MYRANK.EQ.0) PRINT*, 'cn1','con = ', sum(abs(dble(con))) + endif + + IF(ISFCT(MVAR).EQ.0) GOTO 1100 +C +C ** DETERMINE MAX AND MIN CONCENTRATIONS +C + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + CONTMX(L,K)=0.0 + CONTMN(L,K)=0.0 + ENDDO + ENDDO + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CONTMX(L,K)=MAX(CON(L,K),CON2(L,K)) + CONTMN(L,K)=MIN(CON(L,K),CON2(L,K)) + ENDDO + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CMAX(L,1)=MAX(CONTMX(L,1),CONTMX(L,2)) + CMAX(L,KC)=MAX(CONTMX(L,KS),CONTMX(L,KC)) + CMIN(L,1)=MIN(CONTMN(L,1),CONTMN(L,2)) + CMIN(L,KC)=MIN(CONTMN(L,KS),CONTMN(L,KC)) + ENDDO + DO K=2,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CMAXT=MAX(CONTMX(L,K-1),CONTMX(L,K+1)) + CMAX(L,K)=MAX(CONTMX(L,K),CMAXT) + CMINT=MIN(CONTMN(L,K-1),CONTMN(L,K+1)) + CMIN(L,K)=MIN(CONTMN(L,K),CMINT) + ENDDO + ENDDO + MPI_WTIMES(676)=MPI_WTIMES(676)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(CONTMX,ic) + CALL broadcast_boundary_array(CONTMN,ic) + MPI_WTIMES(698)=MPI_WTIMES(698)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LS,LN,CWMAX,CEMAX,CSMAX,CNMAX,CMAXT, +!$OMP+ CWMIN,CEMIN,CSMIN,CNMIN,CMINT) + DO L=LMPI2,LMPILA + LS=LSC(L) + LN=LNC(L) + CWMAX=SUB(L)*CONTMX(L-1,K) + CEMAX=SUB(L+1)*CONTMX(L+1,K) + CSMAX=SVB(L)*CONTMX(LS,K) + CNMAX=SVB(LN)*CONTMX(LN,K) + CMAXT=MAX(CNMAX,CEMAX) + CMAXT=MAX(CMAXT,CSMAX) + CMAXT=MAX(CMAXT,CWMAX) + CMAX(L,K)=MAX(CMAX(L,K),CMAXT) + CWMIN=SUB(L)*CONTMN(L-1,K)+1.E+6*(1.-SUB(L)) + CEMIN=SUB(L+1)*CONTMN(L+1,K)+1.E+6*(1.-SUB(L+1)) + CSMIN=SVB(L)*CONTMN(LS,K)+1.E+6*(1.-SVB(L)) + CNMIN=SVB(LN)*CONTMN(LN,K)+1.E+6*(1.-SVB(LN)) + CMINT=MIN(CNMIN,CEMIN) + CMINT=MIN(CMINT,CSMIN) + CMINT=MIN(CMINT,CWMIN) + CMIN(L,K)=MIN(CMIN(L,K),CMINT) + ENDDO + ENDDO + MPI_WTIMES(677)=MPI_WTIMES(677)+MPI_TOC(S3TIME) +C +C ** SEPARATE POSITIVE AND NEGATIVE FLUXES PUTTING NEGATIVE FLUXES +C ** INTO FUHV, FVHV, AND FWV +C + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FUHV(L,K)=MIN(FUHU(L,K),0.) + FUHU(L,K)=MAX(FUHU(L,K),0.) + FVHV(L,K)=MIN(FVHU(L,K),0.) + FVHU(L,K)=MAX(FVHU(L,K),0.) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FWV(L,K)=MIN(FWU(L,K),0.) + FWU(L,K)=MAX(FWU(L,K),0.) + ENDDO + ENDDO + CALL broadcast_boundary_array(FUHV,ic) + CALL broadcast_boundary_array(FUHU,ic) + CALL broadcast_boundary_array(FVHV,ic) + CALL broadcast_boundary_array(FVHU,ic) + CALL broadcast_boundary_array(FWV, ic) + CALL broadcast_boundary_array(FWU, ic) + MPI_WTIMES(678)=MPI_WTIMES(678)+MPI_TOC(S3TIME) +C +C ** CALCULATE INFLUX AND OUTFLUX IN CONCENTRATION UNITS AND LOAD +C ** INTO DU AND DV, THEN ADJUCT VALUES AT BOUNDARIES +C + S3TIME=MPI_TIC() + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + LN=LNC(L) + DU(L,K)=DELT*(DXYIP(L)*(FUHU(L,K)-FUHV(L+1,K) + & +FVHU(L,K)-FVHV(LN,K)) + & +RDZIC*(FWU(L,K-1)-FWV(L,K)) )*HPI(L) + DV(L,K)=DELT*(DXYIP(L)*(FUHU(L+1,K)-FUHV(L,K) + & +FVHU(LN,K)-FVHV(L,K)) + & +RDZIC*(FWU(L,K)-FWV(L,K-1)) )*HPI(L) + ENDDO + ENDDO + DO K=1,KC + DO IOBC=1,NBCSOP + L=LOBCS(IOBC) + DU(L,K)=0. + DV(L,K)=0. + ENDDO + END DO + DO K=1,KC + DO LL=1,NCBS + L=LCBS(LL) + LN=LNC(L) + DU(LN,K)=0. + DV(LN,K)=0. + ENDDO + DO LL=1,NCBW + L=LCBW(LL) + DU(L+1,K)=0. + DV(L+1,K)=0. + ENDDO + DO LL=1,NCBE + L=LCBE(LL) + DU(L-1,K)=0. + DV(L-1,K)=0. + ENDDO + DO LL=1,NCBN + L=LCBN(LL) + LS=LSC(L) + DU(LS,K)=0. + DV(LS,K)=0. + ENDDO + ENDDO + MPI_WTIMES(679)=MPI_WTIMES(679)+MPI_TOC(S3TIME) +C +C ** CALCULATE BETA COEFFICIENTS WITH BETAUP AND BETADOWN IN DU AND DV +C + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(DU(L,K).GT.0.)DU(L,K)=(CMAX(L,K)-POS(L,K))/(DU(L,K)+BSMALL) + DU(L,K)=MIN(DU(L,K),1.) + IF(DV(L,K).GT.0.)DV(L,K)=(CON(L,K)-CMIN(L,K))/(DV(L,K)+BSMALL) + DV(L,K)=MIN(DV(L,K),1.) + ENDDO + ENDDO + MPI_WTIMES(680)=MPI_WTIMES(680)+MPI_TOC(S3TIME) +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(DU,ic) + CALL broadcast_boundary_array(DV,ic) + MPI_WTIMES(699)=MPI_WTIMES(699)+MPI_TOC(S3TIME) +C +C ** LIMIT FLUXES +C + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + LS=LSC(L) + FUHU(L,K)=MIN(DV(L-1,K),DU(L,K))*FUHU(L,K) + & +MIN(DU(L-1,K),DV(L,K))*FUHV(L,K) + FVHU(L,K)=MIN(DV(LS,K),DU(L,K))*FVHU(L,K) + & +MIN(DU(LS,K),DV(L,K))*FVHV(L,K) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + FWU(L,K)=MIN(DV(L,K),DU(L,K+1))*FWU(L,K) + & +MIN(DU(L,K),DV(L,K+1))*FWV(L,K) + ENDDO + ENDDO + MPI_WTIMES(681)=MPI_WTIMES(681)+MPI_TOC(S3TIME) +C +C ** ANTI-DIFFUSIVE ADVECTION CALCULATION +C + 1100 CONTINUE +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(FUHU,ic) + CALL broadcast_boundary_array(FVHU,ic) + MPI_WTIMES(700)=MPI_WTIMES(700)+MPI_TOC(S3TIME) +C + if(PRINT_SUM.AND.MVAR.eq.6)then + DO NS=1,NSED; call collect_in_zero_array(SED(:,:,NS)); ENDDO + IF(MYRANK.EQ.0) PRINT*, MO,'b6', sum(abs(dble(SED))) + endif + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(con) + IF(MYRANK.EQ.0) PRINT*, 'cn2','con = ', sum(abs(dble(con))) + endif +C + S3TIME=MPI_TIC() + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CH(L,K)=CON(L,K)*HP(L) + & +DELT*( (FUHU(L,K)-FUHU(L+1,K) + & +FVHU(L,K)-FVHU(LNC(L),K))*DXYIP(L) + & +(FWU(L,K-1)-FWU(L,K))*RDZIC ) + CON(L,K)=SCB(L)*CH(L,K)*HPI(L)+(1.-SCB(L))*CON(L,K) + ENDDO + ENDDO + MPI_WTIMES(682)=MPI_WTIMES(682)+MPI_TOC(S3TIME) +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(con) + IF(MYRANK.EQ.0) PRINT*, 'cn3','con = ', sum(abs(dble(con))) + endif +C + S3TIME=MPI_TIC() + CALL broadcast_boundary_array(CON,ic) + MPI_WTIMES(700)=MPI_WTIMES(700)+MPI_TOC(S3TIME) +C +C ** ADD REMAINING SEDIMENT SETTLING AND FLUX +C + ENDIF +C +C ** ANTI-DIFFUSIVE ADVECTIVE FLUX CALCULATION WITH DRY BYPASS +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FUHU) + call collect_in_zero_array(FVHU) + call collect_in_zero_array(FWU ) + IF(MYRANK.EQ.0) PRINT*, '1FUHU = ', sum(abs(dble(FUHU))) + IF(MYRANK.EQ.0) PRINT*, '1FVHU = ', sum(abs(dble(FVHU))) + IF(MYRANK.EQ.0) PRINT*, '1FWU = ', sum(abs(dble(FWU ))) + endif +C + S3TIME=MPI_TIC() + IF(IDRYTBP.GT.0)THEN + ! *** DSLLC BEGIN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + WWW(L,0)=0.0 + WWW(L,KC)=0.0 + ENDDO + DO K=1,KC + UUU(LC,K)=0.0 + VVV(LC,K)=0.0 + UUU(1,K)=0.0 + VVV(1,K)=0.0 + ENDDO + + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LS=LSC(L) + UUU(L,K)=U2(L,K)*(POS(L,K)-POS(L-1,K))*DXIU(L) + VVV(L,K)=V2(L,K)*(POS(L,K)-POS(LS,K))*DYIV(L) + ELSE + UUU(L,K)=0. + VVV(L,K)=0. + ENDIF + ENDDO + ENDDO + + DO K=1,KS + RDZIG=DZIG(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + WWW(L,K)=W2(L,K)*(POS(L,K+1)-POS(L,K))*HPI(L)*RDZIG + ELSE + WWW(L,K)=0.0 + ENDIF + ENDDO + ENDDO +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(UUU) + call collect_in_zero_array(VVV) + call collect_in_zero_array(WWW ) + IF(MYRANK.EQ.0) PRINT*, 'UUU = ', sum(abs(dble(UUU))) + IF(MYRANK.EQ.0) PRINT*, 'VVV = ', sum(abs(dble(VVV))) + IF(MYRANK.EQ.0) PRINT*, 'WWW = ', sum(abs(dble(WWW))) + endif +C + CALL broadcast_boundary_array(UUU,ic) + CALL broadcast_boundary_array(VVV,ic) + CALL broadcast_boundary_array(WWW,ic) +C + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO PRIVATE(LN,LS,LNW,LSE,AUHU,AVHV,UTERM,VTERM,SSCORUE, +!$OMP+ SSCORUW,SSCORVN,SSCORVS,SSCORU,SSCORV,UHU,VHV) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LN=LNC(L) + LS=LSC(L) + LNW=LNWC(L) + LSE=LSEC(L) + AUHU=ABS(UHDY2(L,K)) + AVHV=ABS(VHDX2(L,K)) + UTERM=AUHU*(POS(L,K)-POS(L-1,K)) + VTERM=AVHV*(POS(L,K)-POS(LS,K)) + IF(ISADAC(MVAR).GE.2)THEN + SSCORUE=DELTA*RDZIC*DXYIP(L )*HPI(L )*(FQCPAD(L ,K) + & -QSUMPAD(L ,K)*CON(L ,K)) + SSCORUW=DELTA*RDZIC*DXYIP(L-1)*HPI(L-1)*(FQCPAD(L-1,K) + & -QSUMPAD(L-1,K)*CON(L-1,K)) + SSCORVN=DELTA*RDZIC*DXYIP(L )*HPI(L )*(FQCPAD(L ,K) + & -QSUMPAD(L ,K)*CON(L ,K)) + SSCORVS=DELTA*RDZIC*DXYIP(LS )*HPI(LS )*(FQCPAD(LS ,K) + & -QSUMPAD(LS ,K)*CON(LS ,K)) + SSCORU=MAX(UHDY2(L,K),0.0)*SSCORUW+MIN(UHDY2(L,K),0.0) + & *SSCORUE + SSCORV=MAX(VHDX2(L,K),0.0)*SSCORVS+MIN(VHDX2(L,K),0.0) + & *SSCORVN + UTERM=UTERM+SSCORU + VTERM=VTERM+SSCORV + ENDIF + IF(UHDY2(L,K).GE.0.0)THEN + UTERM=UTERM-0.5*DELTA*UHDY2(L,K)* + & (VVV(LNW,K)+VVV(L-1,K)+WWW(L-1,K)+WWW(L-1,K-1) + & +UUU(L,K)+UUU(L-1,K)) + ELSE + UTERM=UTERM-0.5*DELTA*UHDY2(L,K)* + & (VVV(LN,K)+VVV(L,K)+WWW(L,K)+WWW(L,K-1) + & +UUU(L,K)+UUU(L+1,K)) + ENDIF + IF(VHDX2(L,K).GE.0.0)THEN + VTERM=VTERM-0.5*DELTA*VHDX2(L,K)* + & (UUU(LS,K)+UUU(LSE,K)+WWW(LS,K)+WWW(LS,K-1) + & +VVV(LS,K)+VVV(L,K)) + ELSE + VTERM=VTERM-0.5*DELTA*VHDX2(L,K)* + & (UUU(L,K)+UUU(L+1,K)+WWW(L,K)+WWW(L,K-1) + & +VVV(LN,K)+VVV(L,K)) + ENDIF + IF(ISFCT(MVAR).GE.2)THEN + FUHU(L,K)=0.5*UTERM + FVHU(L,K)=0.5*VTERM + IF(ISFCT(MVAR).EQ.3)THEN + FUHU(L,K)=UTERM + FVHU(L,K)=VTERM + ENDIF + ELSE + UHU=UTERM/(POS(L,K)+POS(L-1,K)+BSMALL) + VHV=VTERM/(POS(L,K)+POS(LS,K)+BSMALL) + FUHU(L,K)=MAX(UHU,0.)*POS(L-1,K) + & +MIN(UHU,0.)*POS(L,K) + FVHU(L,K)=MAX(VHV,0.)*POS(LS,K) + & +MIN(VHV,0.)*POS(L,K) + ENDIF + ELSE + FUHU(L,K)=0. + FVHU(L,K)=0. + ENDIF + ENDDO + ENDDO +C + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FUHU) + call collect_in_zero_array(FVHU) + call collect_in_zero_array(FWU ) + IF(MYRANK.EQ.0) PRINT*, '2.FUHU = ', sum(abs(dble(FUHU))) + IF(MYRANK.EQ.0) PRINT*, '2.FVHU = ', sum(abs(dble(FVHU))) + IF(MYRANK.EQ.0) PRINT*, '2.FWU = ', sum(abs(dble(FWU ))) + endif +C + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN,AWW,WTERM,SSCORWA,SSCORWB,SSCORW,WW) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LN=LNC(L) + AWW=ABS(W2(L,K)) + WTERM=AWW*(POS(L,K+1)-POS(L,K)) + IF(ISADAC(MVAR).GE.2)THEN + SSCORWA=DELTA*DZIG(K+1)*HPI(L)*DXYIP(L) + & *(FQCPAD(L,K+1)-QSUMPAD(L,K+1)*CON(L,K+1)) + SSCORWB=DELTA*DZIG(K)*HPI(L)*DXYIP(L) + & *(FQCPAD(L,K )-QSUMPAD(L,K )*CON(L,K )) + SSCORW=MAX(W2(L,K),0.0)*SSCORWB+MIN(W2(L,K),0.0)*SSCORWA + WTERM=WTERM+SSCORW + ENDIF + IF(W2(L,K).GE.0.0)THEN + WTERM=WTERM-0.5*DELTA*W2(L,K)* + & (UUU(L,K)+UUU(L+1,K)+VVV(L,K)+VVV(LN,K) + & +WWW(L,K)+WWW(L,K-1)) + ELSE + WTERM=WTERM-0.5*DELTA*W2(L,K)* + & (UUU(L+1,K+1)+UUU(L,K+1)+VVV(LN,K+1)+VVV(L,K+1) + & +WWW(L,K)+WWW(L,K+1)) + ENDIF + IF(ISFCT(MVAR).GE.2)THEN + FWU(L,K)=0.5*WTERM + IF(ISFCT(MVAR).EQ.3)THEN + FWU(L,K)=WTERM + ENDIF + ELSE + WW=WTERM/(POS(L,K+1)+POS(L,K)+BSMALL) + FWU(L,K)=MAX(WW,0.)*POS(L,K) + & +MIN(WW,0.)*POS(L,K+1) + ENDIF + ELSE + FWU(L,K)=0. + ENDIF + ENDDO + + ENDDO +C +C ** SET ANTIDIFFUSIVE FLUXES TO ZERO FOR SOURCE CELLS +C + IF(ISADAC(MVAR).EQ.1)THEN + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + IF(ABS(QSUM(L,K)).GT.1.E-12)THEN + LN=LNC(L) + FUHU(L ,K)=0. + FUHU(L+1,K)=0. + FVHU(L ,K)=0. + FVHU(LN ,K)=0. + FWU(L,K )=0. + FWU(L,K-1)=0. + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(683)=MPI_WTIMES(683)+MPI_TOC(S3TIME) + if(PRINT_SUM.AND.MVAR.eq.2)then + call collect_in_zero_array(FUHU) + call collect_in_zero_array(FVHU) + call collect_in_zero_array(FWU ) + IF(MYRANK.EQ.0) PRINT*, '2FUHU = ', sum(abs(dble(FUHU))) + IF(MYRANK.EQ.0) PRINT*, '2FVHU = ', sum(abs(dble(FVHU))) + IF(MYRANK.EQ.0) PRINT*, '2FWU = ', sum(abs(dble(FWU ))) + endif +C +C ** SET ANTIDIFFUSIVE FLUXES TO ZERO FOR OPEN BOUNDARY CELLS +C + S3TIME=MPI_TIC() + DO K=1,KC + DO LL=1,NCBS + L=LCBS(LL) + LN=LNC(L) + FVHU(LN,K)=0.0 + ENDDO + DO LL=1,NCBW + L=LCBW(LL) + FUHU(L+1,K)=0.0 + ENDDO + DO LL=1,NCBE + L=LCBE(LL) + FUHU(L,K)=0.0 + ENDDO + DO LL=1,NCBN + L=LCBN(LL) + FVHU(L,K)=0.0 + ENDDO + ENDDO + MPI_WTIMES(684)=MPI_WTIMES(684)+MPI_TOC(S3TIME) +C +C ** CALCULATE AND APPLY FLUX CORRECTED TRANSPORT LIMITERS +C + IF(ISFCT(MVAR).EQ.0) GOTO 1101 +C +C ** DETERMINE MAX AND MIN CONCENTRATIONS +C + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CMIN(L,K)=0. + CMAX(L,K)=0. + ENDDO + ENDDO + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + CONTMX(L,K)=MAX(CON(L,K),CON2(L,K)) + CONTMN(L,K)=MIN(CON(L,K),CON2(L,K)) + ENDIF + ENDDO + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + CMAX(L,1)=MAX(CONTMX(L,1),CONTMX(L,2)) + CMAX(L,KC)=MAX(CONTMX(L,KS),CONTMX(L,KC)) + CMIN(L,1)=MIN(CONTMN(L,1),CONTMN(L,2)) + CMIN(L,KC)=MIN(CONTMN(L,KS),CONTMN(L,KC)) + ENDIF + ENDDO + DO K=2,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + CMAXT=MAX(CONTMX(L,K-1),CONTMX(L,K+1)) + CMAX(L,K)=MAX(CONTMX(L,K),CMAXT) + CMINT=MIN(CONTMN(L,K-1),CONTMN(L,K+1)) + CMIN(L,K)=MIN(CONTMN(L,K),CMINT) + ENDIF + ENDDO + ENDDO + CALL broadcast_boundary_array(CONTMN,ic) + CALL broadcast_boundary_array(CONTMX,ic) + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LS,LN,CWMAX,CEMAX,CSMAX,CNMAX,CMAXT, +!$OMP+ CWMIN,CEMIN,CSMIN,CNMIN,CMINT) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LS=LSC(L) + LN=LNC(L) + CWMAX=SUB(L)*CONTMX(L-1,K) + CEMAX=SUB(L+1)*CONTMX(L+1,K) + CSMAX=SVB(L)*CONTMX(LS,K) + CNMAX=SVB(LN)*CONTMX(LN,K) + CMAXT=MAX(CNMAX,CEMAX) + CMAXT=MAX(CMAXT,CSMAX) + CMAXT=MAX(CMAXT,CWMAX) + CMAX(L,K)=MAX(CMAX(L,K),CMAXT) + CWMIN=SUB(L)*CONTMN(L-1,K)+1.E+6*(1.-SUB(L)) + CEMIN=SUB(L+1)*CONTMN(L+1,K)+1.E+6*(1.-SUB(L+1)) + CSMIN=SVB(L)*CONTMN(LS,K)+1.E+6*(1.-SVB(L)) + CNMIN=SVB(LN)*CONTMN(LN,K)+1.E+6*(1.-SVB(LN)) + CMINT=MIN(CNMIN,CEMIN) + CMINT=MIN(CMINT,CSMIN) + CMINT=MIN(CMINT,CWMIN) + CMIN(L,K)=MIN(CMIN(L,K),CMINT) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(685)=MPI_WTIMES(685)+MPI_TOC(S3TIME) +C +C ** SEPARATE POSITIVE AND NEGATIVE FLUXES PUTTING NEGATIVE FLUXES +C ** INTO FUHV, FVHV, AND FWV +C + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + FUHV(L,K)=MIN(FUHU(L,K),0.) + FUHU(L,K)=MAX(FUHU(L,K),0.) + FVHV(L,K)=MIN(FVHU(L,K),0.) + FVHU(L,K)=MAX(FVHU(L,K),0.) + ELSE + FUHV(L,K)=0. + FVHV(L,K)=0. + ENDIF + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + FWV(L,K)=MIN(FWU(L,K),0.) + FWU(L,K)=MAX(FWU(L,K),0.) + ELSE + FWV(L,K)=0. + ENDIF + ENDDO + ENDDO + MPI_WTIMES(686)=MPI_WTIMES(686)+MPI_TOC(S3TIME) + CALL broadcast_boundary_array(FUHV,ic) + CALL broadcast_boundary_array(FUHU,ic) + CALL broadcast_boundary_array(FVHU,ic) + CALL broadcast_boundary_array(FVHV,ic) +C +C ** CALCULATE INFLUX AND OUTFLUX IN CONCENTRATION UNITS AND LOAD +C ** INTO DU AND DV, THEN ADJUCT VALUES AT BOUNDARIES +C + S3TIME=MPI_TIC() + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO PRIVATE(LN) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LN=LNC(L) + DU(L,K)=DELT*SCB(L)*( DXYIP(L)*(FUHU(L,K)-FUHV(L+1,K) + & +FVHU(L,K)-FVHV(LN,K)) + & +RDZIC*(FWU(L,K-1)-FWV(L,K)) )*HPI(L) + DV(L,K)=DELT*SCB(L)*( DXYIP(L)*(FUHU(L+1,K)-FUHV(L,K) + & +FVHU(LN,K)-FVHV(L,K)) + & +RDZIC*(FWU(L,K)-FWV(L,K-1)) )*HPI(L) + ELSE + DU(L,K)=0. + DV(L,K)=0. + ENDIF + ENDDO + ENDDO + DO K=1,KC + DO LL=1,NCBS + L=LCBS(LL) + LN=LNC(L) + DU(LN,K)=0. + DV(LN,K)=0. + ENDDO + DO LL=1,NCBW + L=LCBW(LL) + DU(L+1,K)=0. + DV(L+1,K)=0. + ENDDO + DO LL=1,NCBE + L=LCBE(LL) + DU(L-1,K)=0. + DV(L-1,K)=0. + ENDDO + DO LL=1,NCBN + L=LCBN(LL) + LS=LSC(L) + DU(LS,K)=0. + DV(LS,K)=0. + ENDDO + ENDDO + MPI_WTIMES(687)=MPI_WTIMES(687)+MPI_TOC(S3TIME) +C +C ** CALCULATE BETA COEFFICIENTS WITH BETAUP AND BETADOWN IN DU AND DV +C + S3TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + IF(DU(L,K).GT.0.)DU(L,K)=(CMAX(L,K)-POS(L,K))/(DU(L,K) + & +BSMALL) + DU(L,K)=MIN(DU(L,K),1.) + IF(DV(L,K).GT.0.)DV(L,K)=(CON(L,K)-CMIN(L,K))/(DV(L,K) + & +BSMALL) + DV(L,K)=MIN(DV(L,K),1.) + ENDIF + ENDDO + ENDDO + CALL broadcast_boundary_array(DU,ic) + CALL broadcast_boundary_array(DV,ic) +C +C ** LIMIT FLUXES +C + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(LS) + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + LS=LSC(L) + FUHU(L,K)=MIN(DV(L-1,K),DU(L,K))*FUHU(L,K) + & +MIN(DU(L-1,K),DV(L,K))*FUHV(L,K) + FVHU(L,K)=MIN(DV(LS,K),DU(L,K))*FVHU(L,K) + & +MIN(DU(LS,K),DV(L,K))*FVHV(L,K) + ENDIF + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + FWU(L,K)=MIN(DV(L,K),DU(L,K+1))*FWU(L,K) + & +MIN(DU(L,K),DV(L,K+1))*FWV(L,K) + ENDIF + ENDDO + ENDDO + CALL broadcast_boundary_array(FUHU,ic) + CALL broadcast_boundary_array(FVHU,ic) + MPI_WTIMES(688)=MPI_WTIMES(688)+MPI_TOC(S3TIME) +C +C ** END OF ANTI-DIFFUSIVE ADVECTION CALCULATION +C + 1101 CONTINUE +C + S3TIME=MPI_TIC() + DO K=1,KC + RDZIC=DZIC(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(LMASKDRY(L))THEN + CH(L,K)=CON(L,K)*HP(L) + & +DELT*( (FUHU(L,K)-FUHU(L+1,K) + & +FVHU(L,K)-FVHU(LNC(L),K))*DXYIP(L) + & +(FWU(L,K-1)-FWU(L,K))*RDZIC ) + CON(L,K)=SCB(L)*CH(L,K)*HPI(L)+(1.-SCB(L))*CON(L,K) + ENDIF + ENDDO + ENDDO + MPI_WTIMES(689)=MPI_WTIMES(689)+MPI_TOC(S3TIME) +C +C ** ADD REMAINING SEDIMENT SETTLING AND FLUX +C + ENDIF +C +C ** DIAGNOSE FCT SCHEME +C + S3TIME=MPI_TIC() + IF(ISFCT(MVAR).EQ.99)THEN + WRITE(6,6110)N + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(CCMAX,CCMIN) + DO L=LMPI2,LMPILA + CCMAX=SCB(L)*(CON(L,K)-CMAX(L,K)) + IF(CCMAX.GT.0.)THEN + WRITE(6,6111)CON(L,K),CMAX(L,K),IL(L),JL(L),K + ENDIF + CCMIN=SCB(L)*(CMIN(L,K)-CON(L,K)) + IF(CCMIN.GT.0.)THEN + WRITE(6,6112)CMIN(L,K),CON(L,K),IL(L),JL(L),K + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(690)=MPI_WTIMES(690)+MPI_TOC(S3TIME) + 6110 FORMAT(' FCT DIAGNOSTICS AT N = ',I5) + 6111 FORMAT(' CON = ',E12.4,3X,'CMAX = ',E12.4,3X,'I,J,K=',(3I10)) + 6112 FORMAT(' CMIN = ',E12.4,3X,'CON = ',E12.4,3X,'I,J,K=',(3I10)) + + ! *** ZERO HEAT FLUXES + 2000 IF(MVAR.EQ.2)THEN + ! *** ZERO EVAP/RAINFALL + S3TIME=MPI_TIC() + !$OMP PARALLEL DO + DO L=LMPI1,LMPILC + FQC(L,KC)=0. + ENDDO + IF(ISADAC(MVAR).GE.2)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + FQCPAD(L,KC)=0. + ENDDO + ENDIF + IF(ISADAC(MVAR).GT.0)THEN +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + QSUMPAD(L,KC)=0. + ENDDO + ENDIF + MPI_WTIMES(691)=MPI_WTIMES(691)+MPI_TOC(S3TIME) + ENDIF + RETURN + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTSXY.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTSXY.for index d376685af..20d72f46c 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTSXY.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTSXY.for @@ -4,22 +4,22 @@ C CHANGE RECORD C ** SUBROUTINE CALTSXY UPDATES TIME VARIABLE SURFACE WIND STRESS C USE GLOBAL - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::CLOUDTT - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::EVAPTT - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PATMTT - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RAINTT - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RHAT - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SOLSWRTT - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SVPAT - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TATMTT - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TWETTT - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::VPAT - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDE - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDN - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSXX - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSXY - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSYX - REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSYY +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::CLOUDTT +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::EVAPTT +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PATMTT +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RAINTT +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RHAT +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SOLSWRTT +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SVPAT +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TATMTT +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TWETTT +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::VPAT +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDE +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDN +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSXX +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSXY +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSYX +C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSYY C IF(.NOT.ALLOCATED(CLOUDTT))THEN ALLOCATE(CLOUDTT(NASERM)) @@ -392,12 +392,7 @@ C IF(NASER.GT.0)THEN ENDDO ENDDO ELSE -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA PATMT(L)=PATMTT(1) TATMT(L)=TATMTT(1) RAINT(L)=RAINTT(1) @@ -408,19 +403,12 @@ c RHA(L)=RHAT(1) VPA(L)=VPAT(1) ENDDO -c - enddo ENDIF ! *** PMC - MOVED ALL TIME INVARIANT PARAMETERS TO KEEP FROM COMPUTING EVERY TIME -!$OMP PARALLEL DO PRIVATE(LF,LL,CLEVAPTMP,CCNHTTTMP) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(REVC.LT.0.)THEN CLEVAPTMP=0.001*ABS(REVC) - DO L=LF,LL + DO L=2,LA CLEVAP(L)=1.E-3*(0.8+0.065*WINDST(L)) CLEVAP(L)=MAX(CLEVAP(L),CLEVAPTMP) ENDDO @@ -428,13 +416,11 @@ c IF(RCHC.LT.0.)THEN CCNHTTTMP=0.001*ABS(RCHC) - DO L=LF,LL + DO L=2,LA CCNHTT(L)=1.E-3*(0.8+0.065*WINDST(L)) CCNHTT(L)=MAX(CCNHTT(L),CCNHTTTMP) ENDDO ENDIF -c - enddo ENDIF C RETURN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTSXY_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTSXY_mpi.for new file mode 100644 index 000000000..a2b89b00e --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALTSXY_mpi.for @@ -0,0 +1,455 @@ + SUBROUTINE CALTSXY_mpi +C +C CHANGE RECORD +C ** SUBROUTINE CALTSXY UPDATES TIME VARIABLE SURFACE WIND STRESS +C + USE GLOBAL + USE MPI +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::CLOUDTT +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::EVAPTT +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PATMTT +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RAINTT +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RHAT +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SOLSWRTT +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SVPAT +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TATMTT +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TWETTT +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::VPAT +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDE +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDN +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSXX +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSXY +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSYX +c REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSYY + IF(.NOT.ALLOCATED(CLOUDTT))THEN + ALLOCATE(CLOUDTT(NASERM)) + ALLOCATE(EVAPTT(NASERM)) + ALLOCATE(PATMTT(NASERM)) + ALLOCATE(RAINTT(NASERM)) + ALLOCATE(RHAT(NASERM)) + ALLOCATE(SOLSWRTT(NASERM)) + ALLOCATE(SVPAT(NASERM)) + ALLOCATE(TATMTT(NASERM)) + ALLOCATE(TWETTT(NASERM)) + ALLOCATE(VPAT(NASERM)) + ALLOCATE(WINDE(NWSERM)) + ALLOCATE(WINDN(NWSERM)) + ALLOCATE(WINDSXX(LCM)) + ALLOCATE(WINDSXY(LCM)) + ALLOCATE(WINDSYX(LCM)) + ALLOCATE(WINDSYY(LCM)) + + CLOUDTT=0.0 + EVAPTT=0.0 + PATMTT=0.0 + RAINTT=0.0 + RHAT=0.0 + SOLSWRTT=0.0 + SVPAT=0.0 + TATMTT=0.0 + TWETTT=0.0 + VPAT=0.0 + WINDE=0.0 + WINDN=0.0 + WINDSXX=0.0 + WINDSXY=0.0 + WINDSYX=0.0 + WINDSYY=0.0 + + ! *** ONE TIME SPATIAL DISTRIBUTION,\ +C *** OOPS, REVC & RCHC NOT SAVED FOR EACH SERIES +C DO L=2,LA +C CLEVAP(L)=0. +C CCNHTT(L)=0. +C ENDDO +C DO NA=1,NASER +C CLEVAPT=0.001*ABS(REVC) +C CCNHTTT=0.001*ABS(RCHC) +C DO L=2,LA +C CLEVAP(L)=CLEVAP(L)+ATMWHT(L,NA)*CLEVAPT +C CCNHTT(L)=CCNHTT(L)+ATMWHT(L,NA)*CCNHTTT +C ENDDO +C ENDDO + DO L=2,LA + CLEVAP(L)=0.001*ABS(REVC) + CCNHTT(L)=0.001*ABS(RCHC) + ENDDO + ENDIF +C +C**********************************************************************C +C +C INITIALIZE WIND SHELTERED SURFACE GAS TRANSFER +C + S1TIME=MPI_TIC() + IF(N.EQ.-1.AND.NWSER.GT.0)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='WINDSHELT.OUT') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='WINDSHELT.OUT') + ENDIF +!$OMP PARALLEL DO PRIVATE(I,J,LS,LN) + DO L=LMPI2,LMPILA + I=IL(L) + J=JL(L) + IF(WINDSTKA(L).GT.0.0)THEN + ! ** IF WINDSTKA > 0 BOTH X AND Y COMPONENTS ARE APPLIED + WINDSXX(L)=CVN(L) + WINDSXY(L)=-CVE(L) + WINDSYX(L)=-CUN(L) + WINDSYY(L)=CUE(L) + ELSE + ! ** IF WINDSTKA < 0 SLECTIVELY APPLY X AND Y COMPONENTS + ! ** FIRST CASE IS FULLY OPEN WATER + WINDSXX(L)=CVN(L) + WINDSXY(L)=-CVE(L) + WINDSYX(L)=-CUN(L) + WINDSYY(L)=CUE(L) + LS=LSC(L) + LN=LNC(L) + ! ** SECOND CASE IS 1D CHANNEL IN COMP X DIRECTION + IF(SVB(L).LT.0.5.AND.IJCT(I,J-1).NE.5)THEN + IF(SVB(LN).LT.0.5.AND.IJCT(I,J+1).NE.5)THEN + WINDSXX(L)=CVN(L) + WINDSXY(L)=-CVE(L) + WINDSYX(L)=-1000. + WINDSYY(L)=0. + ENDIF + ENDIF + ! ** THIRD CASE IS 1D CHANNEL IN COMP Y DIRECTION + IF(SUB(L).LT.0.5.AND.IJCT(I-1,J).NE.5)THEN + IF(SUB(L+1).LT.0.5.AND.IJCT(I+1,J).NE.5)THEN + WINDSXX(L)=0. + WINDSXY(L)=-1000. + WINDSYX(L)=-CUN(L) + WINDSYY(L)=CUE(L) + ENDIF + ENDIF + ENDIF + IF(DEBUG.AND.MYRANK.EQ.0) WRITE(1,1111)IL(L),JL(L),WINDSTKA(L) + & ,WINDSXX(L),WINDSXY(L),WINDSYX(L),WINDSYY(L) + ENDDO + IF(DEBUG.AND.MYRANK.EQ.0) CLOSE(1) + ENDIF + 1111 FORMAT(2I5,10F10.6) + MPI_WTIMES(871)=MPI_WTIMES(871)+MPI_TOC(S1TIME) +C +C**********************************************************************C +C + IF(NWSER.GT.0)THEN + S1TIME=MPI_TIC() + ! *** UPDATE THE FORCING WIND DATA TO THE CURRENT TIME + DO NA=1,NWSER + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N)/TCWSER(NA)+TBEGIN*(TCON/TCWSER(NA)) + ELSE + TIME=TIMESEC/TCWSER(NA) + ENDIF + M1=MWTLAST(NA) + MSAVE=M1 + 200 CONTINUE + M2=M1+1 + IF(TIME.GT.TWSER(M2,NA))THEN + M1=M2 + GOTO 200 + ELSE + MWTLAST(NA)=M1 + ENDIF + TDIFF=TWSER(M2,NA)-TWSER(M1,NA) + WTM1=(TWSER(M2,NA)-TIME)/TDIFF + WTM2=(TIME-TWSER(M1,NA))/TDIFF + DEGM1=90.-WINDD(M1,NA) + DEGM2=90.-WINDD(M2,NA) + WINDS1=WTM1*WINDS(M1,NA)+WTM2*WINDS(M2,NA) + WINDS2=WTM1*WINDS(M1,NA)+WTM2*WINDS(M2,NA) + WINDE1=WINDS(M1,NA)*COS(DEGM1/57.29578) + WINDN1=WINDS(M1,NA)*SIN(DEGM1/57.29578) + WINDE2=WINDS(M2,NA)*COS(DEGM2/57.29578) + WINDN2=WINDS(M2,NA)*SIN(DEGM2/57.29578) + WINDE(NA)=WTM1*WINDE1+WTM2*WINDE2 + WINDN(NA)=WTM1*WINDN1+WTM2*WINDN2 + ENDDO + MPI_WTIMES(872)=MPI_WTIMES(872)+MPI_TOC(S1TIME) + + ! *** CALCULATE THE WIND STRESS + S1TIME=MPI_TIC() + IF(NWSER.GT.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WNDVELE(L)=0. + WNDVELN(L)=0. + ENDDO + DO NA=1,NWSER +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WNDVELE(L)=WNDVELE(L)+WNDWHT(L,NA)*WINDE(NA) + WNDVELN(L)=WNDVELN(L)+WNDWHT(L,NA)*WINDN(NA) + ENDDO + ENDDO + ELSE !IF(NWSER.EQ.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WNDVELE(L)=WINDE(1) + WNDVELN(L)=WINDN(1) + ENDDO + ENDIF + MPI_WTIMES(873)=MPI_WTIMES(873)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(WNDFAC,C2,CD10,TSEAST,TSNORT,WINDXX,WINDYY) + DO L=LMPI2,LMPILA + ! ** CASE 0 MAGNITUDE SHELTERING AND NO DIRECTIONAL SHELTERING + IF(WINDSTKA(L).GT.0.0)THEN + WNDFAC=ABS(WINDSTKA(L)) + WNDVELE(L)=WNDFAC*WNDVELE(L) + WNDVELN(L)=WNDFAC*WNDVELN(L) + WINDST(L)=SQRT( WNDVELE(L)*WNDVELE(L) + & +WNDVELN(L)*WNDVELN(L) ) +!{GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. +! C2=1.2E-6*(0.8+0.065*WINDST(L)) + IF(ISCD.EQ.1)THEN + C2=1.2E-6*(0.26+0.46*WINDST(L)/CDDN(L)) ! Dean(1997) + ELSEIF(ISCD.EQ.2)THEN + IF(WINDST(L).NE.0.0)THEN + IF(WINDST(L).GE.WNDCR)THEN + CD10=(WNDCM*WINDST(L)+WNDB)**2/WINDST(L)**2 ! Foreman(2012) + ELSE + CD10=(WNDCM*WNDCR+WNDB)**2/WNDCR**2 ! Foreman(2012) + ENDIF + C2=1.2E-3*CD10 ! Foreman(2012) + ELSE + C2=0.0 + ENDIF + ELSE + C2=1.2E-6*(WNDCM+WNDB*WINDST(L)) + ENDIF +!} GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. + TSEAST=C2*WINDST(L)*WNDVELE(L) + TSNORT=C2*WINDST(L)*WNDVELN(L) + TSX(L)=WINDSXX(L)*TSEAST+WINDSXY(L)*TSNORT + TSY(L)=WINDSYX(L)*TSEAST+WINDSYY(L)*TSNORT + + ELSEIF(WINDSTKA(L).LT.0.0)THEN + ! ** CASE 1 MAGNITUDE SHELTERING AND DIRECTIONAL SHELTERING, OPEN WATER + IF(WINDSYX(L).GT.-99.0.AND.WINDSXY(L).GT.-99.0)THEN + WNDFAC=ABS(WINDSTKA(L)) + WNDVELE(L)=WNDFAC*WNDVELE(L) + WNDVELN(L)=WNDFAC*WNDVELN(L) + WINDST(L)=SQRT( WNDVELE(L)*WNDVELE(L) + & +WNDVELN(L)*WNDVELN(L) ) +!{GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. +! C2=1.2E-6*(0.8+0.065*WINDST(L)) + IF(ISCD.EQ.1)THEN + C2=1.2E-6*(0.26+0.46*WINDST(L)/CDDN(L)) ! Dean(1997) + ELSEIF(ISCD.EQ.2)THEN + IF(WINDST(L).NE.0.0)THEN + IF(WINDST(L).GE.WNDCR)THEN + CD10=(WNDCM*WINDST(L)+WNDB)**2/WINDST(L)**2 ! Foreman(2012) + ELSE + CD10=(WNDCM*WNDCR+WNDB)**2/WNDCR**2 ! Foreman(2012) + ENDIF + C2=1.2E-3*CD10 !Foreman(2012) + ELSE + C2=0.0 + ENDIF + ELSE + C2=1.2E-6*(WNDCM+WNDB*WINDST(L)) + ENDIF +!} GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. + TSEAST=C2*WINDST(L)*WNDVELE(L) + TSNORT=C2*WINDST(L)*WNDVELN(L) + TSX(L)=WINDSXX(L)*TSEAST+WINDSXY(L)*TSNORT + TSY(L)=WINDSYX(L)*TSEAST+WINDSYY(L)*TSNORT + ENDIF + + ! ** CASE 2 MAGNITUDE SHELTERING AND DIRECTIONAL SHELTERING, X CHANNEL + IF(WINDSYX(L).LT.-99.0)THEN + WINDXX=WINDSXX(L)*WNDVELE(L)+WINDSXY(L)*WNDVELN(L) + WNDFAC=ABS(WINDSTKA(L)) + WINDXX=WNDFAC*WNDVELE(L) + WINDST(L)=ABS(WINDXX) +!{GeoSR, YSSONG, ICE COVER, 1111031 + IF(PSHADE(L).NE.1.0) WINDST(L)=0.0 +!} +!{GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. +! TSX(L)=1.2E-6*(0.8+0.065*WINDST(L))*WINDST(L)*WINDXX + IF(ISCD.EQ.1)THEN + TSX(L)=1.2E-6*(0.26+0.46*WINDST(L)/CDDN(L)) ! Dean(1997) + & *WINDST(L)*WINDXX + ELSEIF(ISCD.EQ.2)THEN + IF(WINDST(L).NE.0.0)THEN + IF(WINDST(L).GE.WNDCR)THEN + CD10=(WNDCM*WINDST(L)+WNDB)**2/WINDST(L)**2 ! Foreman(2012) + ELSE + CD10=(WNDCM*WNDCR+WNDB)**2/WNDCR**2 ! Foreman(2012) + ENDIF + TSX(L)=1.2E-3*CD10*WINDST(L)*WINDXX ! Foreman(2012) + ELSE + TSX(L)=0.0 + ENDIF + ELSE + TSX(L)=1.2E-6*(WNDCM+WNDB*WINDST(L))*WINDST(L)*WINDXX + ENDIF +!} GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. + TSY(L)=0. + ENDIF + + ! ** CASE 3 MAGNITUDE SHELTERING AND DIRECTIONAL SHELTERING, Y CHANNEL + IF(WINDSXY(L).LT.-99.0)THEN + WINDYY=WINDSYX(L)*WNDVELE(L)+WINDSYY(L)*WNDVELN(L) + WNDFAC=ABS(WINDSTKA(L)) + WINDYY=WNDFAC*WINDYY + WINDST(L)=ABS(WINDYY) + TSX(L)=0 +!{GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. +! TSY(L)=1.2E-6*(0.8+0.065*WINDST(L))*WINDST(L)*WINDYY + IF(ISCD.EQ.1)THEN + TSY(L)=1.2E-6*(0.26+0.46*WINDST(L)/CDDN(L)) ! Dean(1997) + & *WINDST(L)*WINDYY + ELSEIF(ISCD.EQ.2)THEN + IF(WINDST(L).NE.0.0)THEN + IF(WINDST(L).GE.WNDCR)THEN + CD10=(WNDCM*WINDST(L)+WNDB)**2/WINDST(L)**2 ! Foreman(2012) + ELSE + CD10=(WNDCM*WNDCR+WNDB)**2/WNDCR**2 ! Foreman(2012) + ENDIF + TSY(L)=1.2E-3*CD10*WINDST(L)*WINDYY ! Foreman(2012) + ELSE + TSX(L)=0.0 + ENDIF + ELSE + TSY(L)=1.2E-6*(WNDCM+WNDB*WINDST(L))*WINDST(L)*WINDYY + ENDIF +!} GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. + ENDIF + ENDIF + ENDDO + MPI_WTIMES(874)=MPI_WTIMES(874)+MPI_TOC(S1TIME) + ENDIF +C +C CFTSX=1. +C CFTSY=1. +C HHUU=2.*HUWET(L) +C HHVV=2.*HVWET(L) +C + IF(NASER.GT.0)THEN + S1TIME=MPI_TIC() + DO NA=1,NASER + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N)/TCASER(NA)+TBEGIN*(TCON/TCASER(NA)) + ELSE + TIME=TIMESEC/TCASER(NA) + ENDIF + M1=MATLAST(NA) + 100 CONTINUE + M2=M1+1 + IF(TIME.GT.TASER(M2,NA))THEN + M1=M2 + GOTO 100 + ELSE + MATLAST(NA)=M1 + ENDIF + TDIFF=TASER(M2,NA)-TASER(M1,NA) + WTM1=(TASER(M2,NA)-TIME)/TDIFF + WTM2=(TIME-TASER(M1,NA))/TDIFF + PATMTT(NA)=WTM1*PATM(M1,NA)+WTM2*PATM(M2,NA) + TATMTT(NA)=WTM1*TDRY(M1,NA)+WTM2*TDRY(M2,NA) + TWETTT(NA)=WTM1*TWET(M1,NA)+WTM2*TWET(M2,NA) + RAINTT(NA)=WTM1*RAIN(M1,NA)+WTM2*RAIN(M2,NA) + EVAPTT(NA)=WTM1*EVAP(M1,NA)+WTM2*EVAP(M2,NA) + SOLSWRTT(NA)=WTM1*SOLSWR(M1,NA)+WTM2*SOLSWR(M2,NA) + CLOUDTT(NA)=WTM1*CLOUD(M1,NA)+WTM2*CLOUD(M2,NA) + SVPAT(NA)= + & 10.**((0.7859+0.03477*TATMTT(NA))/(1.+0.00412*TATMTT(NA))) + IF(IRELH(NA).EQ.0.AND.ISTOPT(2).NE.4)THEN +C RHAT(NA)=1. +C & -0.00066*(PATMTT(NA)/SVPAT(NA))*(TATMTT(NA)-TWETTT(NA)) + ! *** DSLLC Begin + ! *** (Correct RHA Computation from wet bulb) + TMPVAL=0.00066*(1.0+0.00115*TWETTT(NA)) + SVPWET= + & 10.**((0.7859+0.03477*TWETTT(NA))/(1.+0.00412*TWETTT(NA))) + TMPVL1=SVPWET-TMPVAL*PATMTT(NA)*(TATMTT(NA)-TWETTT(NA)) + RHAT(NA)=MAX(TMPVL1/ SVPAT(NA),.01) + ! *** DSLLC End + ELSE + RHAT(NA)=TWETTT(NA) + ENDIF + VPAT(NA)=RHAT(NA)*SVPAT(NA) + ENDDO + MPI_WTIMES(875)=MPI_WTIMES(875)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + IF(NASER.GT.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + PATMT(L)=0. + TATMT(L)=0. + RAINT(L)=0. + EVAPT(L)=0. + SOLSWRT(L)=0. + CLOUDT(L)=0. + SVPA(L)=0. + RHA(L)=0. + VPA(L)=0. + ENDDO + DO NA=1,NASER +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + PATMT(L)=PATMT(L)+ATMWHT(L,NA)*PATMTT(NA) + TATMT(L)=TATMT(L)+ATMWHT(L,NA)*TATMTT(NA) + RAINT(L)=RAINT(L)+ATMWHT(L,NA)*RAINTT(NA) + EVAPT(L)=EVAPT(L)+ATMWHT(L,NA)*EVAPTT(NA) + SOLSWRT(L)=SOLSWRT(L)+ATMWHT(L,NA)*SOLSWRTT(NA) + CLOUDT(L)=CLOUDT(L)+ATMWHT(L,NA)*CLOUDTT(NA) + SVPA(L)=SVPA(L)+ATMWHT(L,NA)*SVPAT(NA) + RHA(L)=RHA(L)+ATMWHT(L,NA)*RHAT(NA) + VPA(L)=VPA(L)+ATMWHT(L,NA)*VPAT(NA) + ENDDO + ENDDO + ELSE +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + PATMT(L)=PATMTT(1) + TATMT(L)=TATMTT(1) + RAINT(L)=RAINTT(1) + EVAPT(L)=EVAPTT(1) + SOLSWRT(L)=SOLSWRTT(1) + CLOUDT(L)=CLOUDTT(1) + SVPA(L)=SVPAT(1) + RHA(L)=RHAT(1) + VPA(L)=VPAT(1) + ENDDO + ENDIF + MPI_WTIMES(876)=MPI_WTIMES(876)+MPI_TOC(S1TIME) +C + ! *** PMC - MOVED ALL TIME INVARIANT PARAMETERS TO KEEP FROM COMPUTING EVERY TIME + S1TIME=MPI_TIC() + IF(REVC.LT.0.)THEN + CLEVAPTMP=0.001*ABS(REVC) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CLEVAP(L)=1.E-3*(0.8+0.065*WINDST(L)) + CLEVAP(L)=MAX(CLEVAP(L),CLEVAPTMP) + ENDDO + ENDIF + + IF(RCHC.LT.0.)THEN + CCNHTTTMP=0.001*ABS(RCHC) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + CCNHTT(L)=1.E-3*(0.8+0.065*WINDST(L)) + CCNHTT(L)=MAX(CCNHTT(L),CCNHTTTMP) + ENDDO + ENDIF + MPI_WTIMES(877)=MPI_WTIMES(877)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + CALL broadcast_boundary(TSX,ic) + CALL broadcast_boundary(TSY,ic) + MPI_WTIMES(878)=MPI_WTIMES(878)+MPI_TOC(S1TIME) + + ENDIF +C + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALUVW.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALUVW.for index 129467f0f..b41b958cf 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALUVW.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALUVW.for @@ -23,17 +23,8 @@ C C C ** CALCULATE BOTTOM FRICTION COEFFICIENT C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& Q1,Q2, -!$OMP& RCDZM,RCDZU,RCDZL,CMU,CMV,EU,EV, -!$OMP& RCDZR,CRU,CRV, -!$OMP& RDZG,RCDZD) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(ISTL_.EQ.3)THEN - DO L=LF,LL + DO L=2,LA RCX(L)=AVCON1/H1U(L)+STBX(L)*SQRT(U1(L,1)*U1(L,1) & +V1U(L)*V1U(L)) RCY(L)=AVCON1/H1V(L)+STBY(L)*SQRT(U1V(L)*U1V(L) @@ -44,7 +35,7 @@ C LF=2+(ND-1)*LDM C ELSE IF(AVCON1.LT.0.00001)THEN - DO L=LF,LL + DO L=2,LA ! *** FOR 2TL U1 & U AND V1 & V ARE THE SAME ! *** THESE ARE ONLY DIFFERENCE FOR 3TL ISTL=2 TRAP CORRECTION STEP Q1=SQRT(U1(L,1)*U1(L,1)+V1U(L)*V1U(L)) @@ -55,7 +46,7 @@ C RCY(L)=STBY(L)*SQRT(Q1*Q2) ENDDO ELSE - DO L=LF,LL + DO L=2,LA Q1=SQRT(U1(L,1)*U1(L,1)+V1U(L)*V1U(L)) Q2=SQRT(U(L,1)*U(L,1)+VU(L)*VU(L)) RCX(L)=AVCON1/SQRT(H1U(L)*HU(L))+STBX(L)*SQRT(Q1*Q2) @@ -74,7 +65,7 @@ C RCDZM=CDZM(1)*DELTI RCDZU=CDZU(1) RCDZL=CDZL(1) - DO L=LF,LL + DO L=2,LA CMU=1.+RCDZM*HU(L)*AVUI(L,1) CMV=1.+RCDZM*HV(L)*AVVI(L,1) EU=1./CMU @@ -90,7 +81,7 @@ C RCDZM=CDZM(K)*DELTI RCDZU=CDZU(K) RCDZL=CDZL(K) - DO L=LF,LL + DO L=2,LA CMU=1.+RCDZM*HU(L)*AVUI(L,K) CMV=1.+RCDZM*HV(L)*AVVI(L,K) EU=1./(CMU-RCDZL*CU1(L,K-1)) @@ -104,14 +95,14 @@ C ENDDO ENDDO DO K=KS-1,1,-1 - DO L=LF,LL + DO L=2,LA DU(L,K)=DU(L,K)-CU1(L,K)*DU(L,K+1) DV(L,K)=DV(L,K)-CU2(L,K)*DV(L,K+1) UUU(L,K)=UUU(L,K)-CU1(L,K)*UUU(L,K+1) VVV(L,K)=VVV(L,K)-CU2(L,K)*VVV(L,K+1) ENDDO ENDDO - DO L=LF,LL + DO L=2,LA AAU(L)=0. AAV(L)=0. BBU(L)=1. @@ -119,7 +110,7 @@ C ENDDO DO K=1,KS RCDZR=CDZR(K) - DO L=LF,LL + DO L=2,LA CRU=RCDZR*RCX(L)*AVUI(L,K) CRV=RCDZR*RCY(L)*AVVI(L,K) AAU(L)=AAU(L)+CRU*DU(L,K) @@ -128,36 +119,40 @@ C BBV(L)=BBV(L)+CRV*VVV(L,K) ENDDO ENDDO - DO L=LF,LL + DO L=2,LA AAU(L)=AAU(L)/BBU(L) AAV(L)=AAV(L)/BBV(L) ENDDO DO K=1,KS RDZG=DZG(K) - RCDZD=CDZD(K) - DO L=LF,LL + DO L=2,LA DU(L,K)=RDZG*HU(L)*AVUI(L,K)*(DU(L,K)-AAU(L)*UUU(L,K)) DV(L,K)=RDZG*HV(L)*AVVI(L,K)*(DV(L,K)-AAV(L)*VVV(L,K)) + ENDDO + ENDDO C C ** CALCULATED U AND V C ** DUSUM+UHE=UHE, DVSUM+VHE=VHE C + DO K=1,KS + RCDZD=CDZD(K) + DO L=2,LA UHE(L)=UHE(L)+RCDZD*DU(L,K) VHE(L)=VHE(L)+RCDZD*DV(L,K) ENDDO ENDDO - DO L=LF,LL + DO L=2,LA UHDY(L,KC)=UHE(L)*SUB(L) VHDX(L,KC)=VHE(L)*SVB(L) ENDDO DO K=KS,1,-1 - DO L=LF,LL + DO L=2,LA UHDY(L,K)=UHDY(L,K+1)-DU(L,K)*SUB(L) VHDX(L,K)=VHDX(L,K+1)-DV(L,K)*SVB(L) ENDDO ENDDO DO K=1,KC - DO L=LF,LL + DO L=2,LA U(L,K)=UHDY(L,K)*HUI(L) V(L,K)=VHDX(L,K)*HVI(L) UHDY(L,K)=UHDY(L,K)*DYU(L) @@ -167,22 +162,26 @@ C C C ** ADD ADJUSTMENT TO 3D HORIZONTAL TRANSPORT C - DO L=LF,LL + DO L=2,LA TVAR3E(L)=0. TVAR3N(L)=0. ENDDO DO K=1,KC - DO L=LF,LL + DO L=2,LA TVAR3E(L)=TVAR3E(L)+UHDY(L,K)*DZC(K) TVAR3N(L)=TVAR3N(L)+VHDX(L,K)*DZC(K) ENDDO ENDDO - DO L=LF,LL + UERMX=-1.E+12 + UERMN=1.E+12 + VERMX=-1.E+12 + VERMN=1.E+12 + DO L=2,LA TVAR3E(L)=TVAR3E(L)-UHDYE(L) TVAR3N(L)=TVAR3N(L)-VHDXE(L) ENDDO DO K=1,KC - DO L=LF,LL + DO L=2,LA UHDY(L,K)=UHDY(L,K)-TVAR3E(L)*DZIC(K) VHDX(L,K)=VHDX(L,K)-TVAR3N(L)*DZIC(K) ENDDO @@ -190,50 +189,47 @@ C C C ** RESET VELOCITIES C - DO L=LF,LL + DO L=2,LA UHE(L)=0. VHE(L)=0. ENDDO DO K=1,KC - DO L=LF,LL + DO L=2,LA UHE(L)=UHE(L)+UHDY(L,K)*DZC(K) VHE(L)=VHE(L)+VHDX(L,K)*DZC(K) U(L,K)=UHDY(L,K)*HUI(L) V(L,K)=VHDX(L,K)*HVI(L) + ENDDO + ENDDO + DO K=1,KC + DO L=2,LA U(L,K)=U(L,K)*DYIU(L) V(L,K)=V(L,K)*DXIV(L) ENDDO ENDDO - DO L=LF,LL + DO L=2,LA UHE(L)=UHE(L)*DYIU(L) VHE(L)=VHE(L)*DXIV(L) ENDDO -c - enddo C C ** UNCOMMENT BELOW TO WRITE CONTINUITY DIAGNOSITCS C - 6661 FORMAT(' I,J,UHDYERMX = ',2I5,E14.5) - 6662 FORMAT(' I,J,UHDYERMN = ',2I5,E14.5) - 6663 FORMAT(' I,J,VHDYERMX = ',2I5,E14.5) - 6664 FORMAT(' I,J,VHDYERMX = ',2I5,E14.5) +C6661 FORMAT(' I,J,UHDYERMX = ',2I5,E14.5) +C6662 FORMAT(' I,J,UHDYERMN = ',2I5,E14.5) +C6663 FORMAT(' I,J,VHDYERMX = ',2I5,E14.5) +C6664 FORMAT(' I,J,VHDYERMX = ',2I5,E14.5) C C ** CALCULATE W C -!$OMP PARALLEL DO PRIVATE(LF,LL,LN,LE) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(ISTL_.EQ.3)THEN - DO L=LF,LL + DO L=2,LA TVAR3E(L)=UHDYE(L+1 ) TVAR3N(L)=VHDXE(LNC(L)) TVAR3W(L)=UHDY2E(L+1 ) TVAR3S(L)=VHDX2E(LNC(L)) ENDDO DO K=1,KC - DO L=LF,LL + DO L=2,LA TVAR1E(L,K)=UHDY(L+1 ,K) TVAR1N(L,K)=VHDX(LNC(L),K) TVAR1W(L,K)=UHDY2(L+1 ,K) @@ -241,7 +237,7 @@ c ENDDO ENDDO DO K=1,KS - DO L=LF,LL + DO L=2,LA LN=LNC(L) W(L,K)=W(L,K-1) - 0.5*DZC(K)*DXYIP(L)* & (TVAR1E(L,K)-UHDY(L,K)-TVAR3E(L)+UHDYE(L) @@ -255,7 +251,7 @@ c ELSEIF(ISTL_.EQ.2)THEN DO K=1,KS - DO L=LF,LL + DO L=2,LA LN=LNC(L) LE=L+1 W(L,K)=W(L,K-1) - 0.5*DZC(K)*DXYIP(L)* @@ -264,11 +260,10 @@ c & + VHDX(LN,K)- VHDX(L,K)- VHDXE(LN)+VHDXE(L) & +VHDX1(LN,K)-VHDX1(L,K)-VHDX1E(LN)+VHDX1E(L)) & +(QSUM(L,K)-DZC(K)*QSUME(L) )*DXYIP(L) + iii=0 ENDDO ENDDO ENDIF -c - enddo ! *** APPLY OPEN BOUNDARYS DO LL=1,NBCSOP @@ -278,9 +273,9 @@ c ENDDO ENDDO - 601 FORMAT(' IMAX,JMAX,QWSFMAX = ',2I5,E14.5) - 602 FORMAT(' IMIN,JMIN,QWSFMIN = ',2I5,E14.5) - 603 FORMAT(' TOTAL SURF Q ERR = ',E14.5) +C 601 FORMAT(' IMAX,JMAX,QWSFMAX = ',2I5,E14.5) +C 602 FORMAT(' IMIN,JMIN,QWSFMIN = ',2I5,E14.5) +C 603 FORMAT(' TOTAL SURF Q ERR = ',E14.5) C C ** CALCULATE U AND V ON OPEN BOUNDARIES C @@ -298,6 +293,8 @@ C V(LN,K)=0. ENDIF ENDDO + ENDDO + DO K=1,KC DO LL=1,NCBW L=LCBW(LL) LP=L+1 @@ -310,11 +307,15 @@ C U(LP,K)=0. ENDIF ENDDO + ENDDO + DO K=1,KC DO LL=1,NCBE L=LCBE(LL) UHDY(L,K)=UHDY(L-1,K)-UHDYE(L-1)+UHDYE(L) U(L,K)=UHDY(L,K)/(HU(L)*DYU(L)) ENDDO + ENDDO + DO K=1,KC DO LL=1,NCBN L=LCBN(LL) LS=LSC(L) @@ -326,14 +327,9 @@ C C ** CALCULATE AVERAGE CELL FACE TRANSPORTS FOR SALT, TEMPERATURE AND C ** SEDIMENT TRANSPORT AND PLACE IN UHDY2, VHDX2 AND W2 C -!$OMP PARALLEL DO PRIVATE(LF,LL,LN,LE) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(ISTL_.EQ.2)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA UHDY2(L,K)=0.5*(UHDY(L,K)+UHDY1(L,K)) VHDX2(L,K)=0.5*(VHDX(L,K)+VHDX1(L,K)) U2(L,K)=0.5*(U(L,K)+U1(L,K)) @@ -343,7 +339,7 @@ c ENDDO ELSE DO K=1,KC - DO L=LF,LL + DO L=2,LA UHDY2(L,K)=0.5*(UHDY(L,K)+UHDY2(L,K)) VHDX2(L,K)=0.5*(VHDX(L,K)+VHDX2(L,K)) U2(L,K)=0.5*(U(L,K)+U2(L,K)) @@ -355,7 +351,7 @@ c C IF(ISWVSD.GE.1)THEN DO K=1,KC - DO L=LF,LL + DO L=2,LA UHDY2(L,K)=UHDY2(L,K)+DYU(L)*UVPT(L,K) VHDX2(L,K)=VHDX2(L,K)+DXV(L)*VVPT(L,K) U2(L,K)=U2(L,K)+UVPT(L,K)/HMU(L) @@ -368,27 +364,18 @@ C C ** ADDITIONAL 3D CONTINUITY ADJUSTED ADDED BELOW C IF(KC.GT.1)THEN - DO L=LF,LL + DO L=2,LA TVAR3E(L)=0. TVAR3N(L)=0. ENDDO DO K=1,KC - DO L=LF,LL + DO L=2,LA TVAR3E(L)=TVAR3E(L)+UHDY2(L,K)*DZC(K) TVAR3N(L)=TVAR3N(L)+VHDX2(L,K)*DZC(K) ENDDO ENDDO - ENDIF -C - enddo - IF(KC.GT.1)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL,LN,HPPTMP) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c IF(ISTL_.EQ.3)THEN - DO L=LF,LL + DO L=2,LA LN=LNC(L) HPPTMP=H2P(L)+DELT*DXYIP(L)*( QSUME(L) & -TVAR3E(L+1)+TVAR3E(L) @@ -399,7 +386,7 @@ c HPI(L)=1./HP(L) ENDDO ELSE - DO L=LF,LL + DO L=2,LA LN=LNC(L) HPPTMP=H1P(L)+DELT*DXYIP(L)*( QSUME(L) & -TVAR3E(L+1)+TVAR3E(L) @@ -410,8 +397,6 @@ c HPI(L)=1./HP(L) ENDDO ENDIF -C - enddo IF(MDCHH.GE.1)THEN RLAMN=QCHERR RLAMO=1.-RLAMN @@ -441,14 +426,8 @@ C ** ACCUMULTATE MAX COURANT NUMBERS C C *** DSLLC BEGIN BLOCK IF(ISINWV.EQ.1.OR.ISNEGH.GT.0)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& CFLUUUT,CFLVVVT,CFLWWWT,CFLCACT) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c DO K=1,KC - DO L=LF,LL + DO L=2,LA CFLUUUT=DELT*ABS(DXIU(L)*U(L,K)) CFLUUU(L,K)=MAX(CFLUUUT,CFLUUU(L,K)) CFLVVVT=DELT*ABS(DYIV(L)*V(L,K)) @@ -459,8 +438,6 @@ c CFLCAC(L,K)=MAX(CFLCACT,CFLCAC(L,K)) ENDDO ENDDO -c - enddo ENDIF C *** DSLLC END BLOCK C @@ -472,8 +449,8 @@ C ** WRITE TO DIAGNOSTIC FILE CFL.OUT WITH DIAGNOSTICS OF MAXIMUM C ** TIME STEP C ** SEDIMENT TRANSPORT AND PLACE IN UHDY2, VHDX2 AND W2 C -! IF(ISCFL.GE.1.AND.ISTL_.EQ.3.AND.DEBUG)THEN ! GEOSR. 2011.11.29 - IF(ISCFL.GE.1.AND.DEBUG)THEN ! GEOSR. 2011.11.29 +! IF(ISCFL.GE.1.AND.ISTL_.EQ.3.AND.DEBUG)THEN + IF(ISCFL.GE.1)THEN OPEN(1,FILE='CFL.OUT',STATUS='UNKNOWN',POSITION='APPEND') IF(ISCFLM.GE.1.AND.N.EQ.1)THEN OPEN(2,FILE='CFLMP.OUT',STATUS='UNKNOWN') diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALUVW_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALUVW_mpi.for new file mode 100644 index 000000000..ab1c0d9c7 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALUVW_mpi.for @@ -0,0 +1,791 @@ + SUBROUTINE CALUVW_mpi (ISTL_,IS2TL_) +C +C CHANGE RECORD +C ** CALCULATE THE INTERNAL SOLUTION AT TIME LEVEL (N+1) +C ** THE VALUE OF ISTL INDICATES THE NUMBER OF TIME LEVELS IN THE STEP +C + USE GLOBAL + USE MPI + REAL DTCFL + DTCFL=0.0 +C + IF(ISDYNSTP.EQ.0)THEN + DELT=DT2 + DELTD2=DT + IF(ISTL_.EQ.2)THEN + DELT=DT + DELTD2=0.5*DT + ENDIF + DELTI=1./DELT + ELSE + DELT=DTDYN + DELTD2=0.5*DTDYN + DELTI=1./DELT + ENDIF + IF(KC.EQ.1) GOTO 30 +C +C ** CALCULATE BOTTOM FRICTION COEFFICIENT +C + IF(ISTL_.EQ.3)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + RCX(L)=AVCON1/H1U(L)+STBX(L)*SQRT(U1(L,1)*U1(L,1) + & +V1U(L)*V1U(L)) + RCY(L)=AVCON1/H1V(L)+STBY(L)*SQRT(U1V(L)*U1V(L) + & +V1(L,1)*V1(L,1)) + ENDDO + MPI_WTIMES(101)=MPI_WTIMES(101)+MPI_TOC(S1TIME) +C +C LF=2+(ND-1)*LDM +C + ELSE + S1TIME=MPI_TIC() + IF(AVCON1.LT.0.00001)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + ! *** FOR 2TL U1 & U AND V1 & V ARE THE SAME + ! *** THESE ARE ONLY DIFFERENCE FOR 3TL ISTL=2 TRAP CORRECTION STEP + RCX(L)=STBX(L)*SQRT(SQRT(U1(L,1)*U1(L,1)+V1U(L)*V1U(L)) + & *SQRT(U(L,1)*U(L,1)+VU(L)*VU(L))) + RCY(L)=STBY(L)*SQRT(SQRT(U1V(L)*U1V(L)+V1(L,1)*V1(L,1)) + & *SQRT(UV(L)*UV(L)+V(L,1)*V(L,1))) + ENDDO + ELSE +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + RCX(L)=AVCON1/SQRT(H1U(L)*HU(L))+STBX(L) + & *SQRT(SQRT(U1(L,1)*U1(L,1)+V1U(L)*V1U(L)) + & *SQRT(U(L,1)*U(L,1)+VU(L)*VU(L))) + RCY(L)=AVCON1/SQRT(H1V(L)*HV(L))+STBY(L) + & *SQRT(SQRT(U1V(L)*U1V(L)+V1(L,1)*V1(L,1)) + & *SQRT(UV(L)*UV(L)+V(L,1)*V(L,1))) + ENDDO + ENDIF + MPI_WTIMES(102)=MPI_WTIMES(102)+MPI_TOC(S1TIME) +C +C LF=2+(ND-1)*LDM +C + ENDIF +C + if(PRINT_SUM)then + call collect_in_zero(RCX ) + call collect_in_zero(RCY ) + call collect_in_zero(HU ) + call collect_in_zero(HV ) + call collect_in_zero_array(AVUI ) + call collect_in_zero_array(AVVI ) + IF(MYRANK.EQ.0) PRINT*, 'RCX = ', sum(abs(dble(RCX))) + IF(MYRANK.EQ.0) PRINT*, 'RCY = ', sum(abs(dble(RCY))) + IF(MYRANK.EQ.0) PRINT*, 'HU = ', sum(abs(dble(HU))) + IF(MYRANK.EQ.0) PRINT*, 'HV = ', sum(abs(dble(HV))) + IF(MYRANK.EQ.0) PRINT*, 'AVUI = ', sum(abs(dble(AVUI))) + IF(MYRANK.EQ.0) PRINT*, 'AVVI = ', sum(abs(dble(AVVI))) + endif +C ** CALCULATE THE U AND V SHEARS +C + S1TIME=MPI_TIC() + RCDZM=CDZM(1)*DELTI + RCDZU=CDZU(1) + RCDZL=CDZL(1) +!$OMP PARALLEL DO PRIVATE(CMU,CMV,EU,EV) + DO L=LMPI2,LMPILA + CMU=1.+RCDZM*HU(L)*AVUI(L,1) + CMV=1.+RCDZM*HV(L)*AVVI(L,1) + EU=1./CMU + EV=1./CMV + CU1(L,1)=RCDZU*EU + CU2(L,1)=RCDZU*EV + DU(L,1)=(DU(L,1)-RCDZL*RCX(L)*UHE(L)*HUI(L))*EU + DV(L,1)=(DV(L,1)-RCDZL*RCY(L)*VHE(L)*HVI(L))*EV + UUU(L,1)=EU + VVV(L,1)=EV + ENDDO + MPI_WTIMES(103)=MPI_WTIMES(103)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + DO K=2,KS + RCDZM=CDZM(K)*DELTI + RCDZU=CDZU(K) + RCDZL=CDZL(K) +!$OMP PARALLEL DO PRIVATE(CMU,CMV,EU,EV) + DO L=LMPI2,LMPILA + CMU=1.+RCDZM*HU(L)*AVUI(L,K) + CMV=1.+RCDZM*HV(L)*AVVI(L,K) + EU=1./(CMU-RCDZL*CU1(L,K-1)) + EV=1./(CMV-RCDZL*CU2(L,K-1)) + CU1(L,K)=RCDZU*EU + CU2(L,K)=RCDZU*EV + DU(L,K)=(DU(L,K)-RCDZL*DU(L,K-1))*EU + DV(L,K)=(DV(L,K)-RCDZL*DV(L,K-1))*EV + UUU(L,K)=-RCDZL*UUU(L,K-1)*EU + VVV(L,K)=-RCDZL*VVV(L,K-1)*EV + ENDDO + ENDDO + MPI_WTIMES(104)=MPI_WTIMES(104)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + DO K=KS-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + DU(L,K)=DU(L,K)-CU1(L,K)*DU(L,K+1) + DV(L,K)=DV(L,K)-CU2(L,K)*DV(L,K+1) + UUU(L,K)=UUU(L,K)-CU1(L,K)*UUU(L,K+1) + VVV(L,K)=VVV(L,K)-CU2(L,K)*VVV(L,K+1) + ENDDO + ENDDO + MPI_WTIMES(105)=MPI_WTIMES(105)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AAU(L)=0. + AAV(L)=0. + BBU(L)=1. + BBV(L)=1. + ENDDO + MPI_WTIMES(106)=MPI_WTIMES(106)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + DO K=1,KS + RCDZR=CDZR(K) +!$OMP PARALLEL DO PRIVATE(CRU,CRV) + DO L=LMPI2,LMPILA + CRU=RCDZR*RCX(L)*AVUI(L,K) + CRV=RCDZR*RCY(L)*AVVI(L,K) + AAU(L)=AAU(L)+CRU*DU(L,K) + AAV(L)=AAV(L)+CRV*DV(L,K) + BBU(L)=BBU(L)+CRU*UUU(L,K) + BBV(L)=BBV(L)+CRV*VVV(L,K) + ENDDO + ENDDO + MPI_WTIMES(107)=MPI_WTIMES(107)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + AAU(L)=AAU(L)/BBU(L) + AAV(L)=AAV(L)/BBV(L) + ENDDO + MPI_WTIMES(108)=MPI_WTIMES(108)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + DO K=1,KS + RDZG=DZG(K) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + DU(L,K)=RDZG*HU(L)*AVUI(L,K)*(DU(L,K)-AAU(L)*UUU(L,K)) + DV(L,K)=RDZG*HV(L)*AVVI(L,K)*(DV(L,K)-AAV(L)*VVV(L,K)) + ENDDO + ENDDO + MPI_WTIMES(109)=MPI_WTIMES(109)+MPI_TOC(S1TIME) +C +C ** CALCULATED U AND V +C ** DUSUM+UHE=UHE, DVSUM+VHE=VHE +C + if(PRINT_SUM)then + call collect_in_zero_array(UHDY ) + call collect_in_zero_array(VHDX ) + call collect_in_zero_array(U ) + call collect_in_zero_array(V ) + call collect_in_zero_array(W ) + IF(MYRANK.EQ.0) PRINT*, 'AUVW_UHDY = ', sum(abs(dble(UHDY))) + IF(MYRANK.EQ.0) PRINT*, 'AUVW_VHDX = ', sum(abs(dble(VHDX))) + IF(MYRANK.EQ.0) PRINT*, 'AUVW_U = ', sum(abs(dble(U ))) + IF(MYRANK.EQ.0) PRINT*, 'AUVW_V = ', sum(abs(dble(V ))) + IF(MYRANK.EQ.0) PRINT*, 'AUVW_W = ', sum(abs(dble(W ))) + endif + + if(PRINT_SUM)then + call collect_in_zero_array(DU ) + call collect_in_zero_array(DV ) + call collect_in_zero_array(UUU ) + call collect_in_zero_array(VVV ) + IF(MYRANK.EQ.0) PRINT*, 'AUVW_DU = ', sum(abs(dble(DU))) + IF(MYRANK.EQ.0) PRINT*, 'AUVW_DV = ', sum(abs(dble(DV))) + IF(MYRANK.EQ.0) PRINT*, 'AUVW_UUU = ', sum(abs(dble(UUU ))) + IF(MYRANK.EQ.0) PRINT*, 'AUVW_VVV = ', sum(abs(dble(VVV ))) + endif + S1TIME=MPI_TIC() + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHE(L)=UHE(L)+CDZD(K)*DU(L,K) + VHE(L)=VHE(L)+CDZD(K)*DV(L,K) + ENDDO + ENDDO + MPI_WTIMES(110)=MPI_WTIMES(110)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHDY(L,KC)=UHE(L)*SUB(L) + VHDX(L,KC)=VHE(L)*SVB(L) + ENDDO + MPI_WTIMES(111)=MPI_WTIMES(111)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + DO K=KS,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHDY(L,K)=UHDY(L,K+1)-DU(L,K)*SUB(L) + VHDX(L,K)=VHDX(L,K+1)-DV(L,K)*SVB(L) + ENDDO + ENDDO + MPI_WTIMES(112)=MPI_WTIMES(112)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + U(L,K)=UHDY(L,K)*HUI(L) + V(L,K)=VHDX(L,K)*HVI(L) + UHDY(L,K)=UHDY(L,K)*DYU(L) + VHDX(L,K)=VHDX(L,K)*DXV(L) + ENDDO + ENDDO + MPI_WTIMES(113)=MPI_WTIMES(113)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR3E(L)=SUM(UHDY(L,1:KC)*DZC(1:KC))-UHDYE(L) + TVAR3N(L)=SUM(VHDX(L,1:KC)*DZC(1:KC))-VHDXE(L) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHDY(L,1:KC)=UHDY(L,1:KC)-TVAR3E(L)*DZIC(1:KC) + VHDX(L,1:KC)=VHDX(L,1:KC)-TVAR3N(L)*DZIC(1:KC) + ENDDO + MPI_WTIMES(115)=MPI_WTIMES(115)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() +C +C ** RESET VELOCITIES +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHE(L)=0. + VHE(L)=0. + ENDDO + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHE(L)=UHE(L)+UHDY(L,K)*DZC(K) + VHE(L)=VHE(L)+VHDX(L,K)*DZC(K) + ENDDO + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + U(L,:)=UHDY(L,:)*HUI(L) + V(L,:)=VHDX(L,:)*HVI(L) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + U(L,:)=U(L,:)*DYIU(L) + V(L,:)=V(L,:)*DXIV(L) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHE(L)=UHE(L)*DYIU(L) + VHE(L)=VHE(L)*DXIV(L) + ENDDO + MPI_WTIMES(116)=MPI_WTIMES(116)+MPI_TOC(S1TIME) +C +C ** UNCOMMENT BELOW TO WRITE CONTINUITY DIAGNOSITCS +C +C6661 FORMAT(' I,J,UHDYERMX = ',2I5,E14.5) +C6662 FORMAT(' I,J,UHDYERMN = ',2I5,E14.5) +C6663 FORMAT(' I,J,VHDYERMX = ',2I5,E14.5) +C6664 FORMAT(' I,J,VHDYERMX = ',2I5,E14.5) +C +C ** CALCULATE W +C + IF(ISTL_.EQ.3)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR3E(L)=UHDYE(L+1 ) + TVAR3N(L)=VHDXE(LNC(L)) + TVAR3W(L)=UHDY2E(L+1 ) + TVAR3S(L)=VHDX2E(LNC(L)) + ENDDO + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR1E(L,K)=UHDY(L+1 ,K) + TVAR1N(L,K)=VHDX(LNC(L),K) + TVAR1W(L,K)=UHDY2(L+1 ,K) + TVAR1S(L,K)=VHDX2(LNC(L),K) + ENDDO + ENDDO + DO K=1,KS +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + W(L,K)=W(L,K-1) - 0.5*DZC(K)*DXYIP(L)* + & (TVAR1E(L,K)-UHDY(L,K)-TVAR3E(L)+UHDYE(L) + & +TVAR1W(L,K)-UHDY2(L,K)-TVAR3W(L)+UHDY2E(L) + & +TVAR1N(L,K)-VHDX(L,K)-TVAR3N(L)+VHDXE(L) + & +TVAR1S(L,K)-VHDX2(L,K)-TVAR3S(L)+VHDX2E(L)) + & +(QSUM(L,K)-DZC(K)*QSUME(L))*DXYIP(L) + ENDDO + ENDDO + MPI_WTIMES(117)=MPI_WTIMES(117)+MPI_TOC(S1TIME) + ELSEIF(ISTL_.EQ.2)THEN + S1TIME=MPI_TIC() + call broadcast_boundary_array(UHDY, ic) + call broadcast_boundary_array(UHDY1,ic) + call broadcast_boundary_array(VHDX, ic) + call broadcast_boundary_array(VHDX1,ic) + call broadcast_boundary(UHDYE ,ic) + call broadcast_boundary(UHDY1E,ic) + call broadcast_boundary(VHDXE ,ic) + call broadcast_boundary(VHDX1E,ic) + DO K=1,KS +!$OMP PARALLEL DO PRIVATE(LN,LE) + DO L=LMPI2,LMPILA + LN=LNC(L) + LE=L+1 + W(L,K)=W(L,K-1) - 0.5*DZC(K)*DXYIP(L)* + & ( UHDY(LE,K)- UHDY(L,K)- UHDYE(LE)+UHDYE(L) + & +UHDY1(LE,K)-UHDY1(L,K)-UHDY1E(LE)+UHDY1E(L) + & + VHDX(LN,K)- VHDX(L,K)- VHDXE(LN)+VHDXE(L) + & +VHDX1(LN,K)-VHDX1(L,K)-VHDX1E(LN)+VHDX1E(L)) + & +(QSUM(L,K)-DZC(K)*QSUME(L) )*DXYIP(L) + ENDDO + ENDDO + MPI_WTIMES(118)=MPI_WTIMES(118)+MPI_TOC(S1TIME) + ENDIF +C + ! *** APPLY OPEN BOUNDARYS + S1TIME=MPI_TIC() + DO LL=1,NBCSOP + L=LOBCS(LL) + DO K=1,KS + W(L,K)=0.0 + ENDDO + ENDDO + MPI_WTIMES(119)=MPI_WTIMES(119)+MPI_TOC(S1TIME) + +C 601 FORMAT(' IMAX,JMAX,QWSFMAX = ',2I5,E14.5) +C 602 FORMAT(' IMIN,JMIN,QWSFMIN = ',2I5,E14.5) +C 603 FORMAT(' TOTAL SURF Q ERR = ',E14.5) +C + S1TIME=MPI_TIC() + call broadcast_boundary_array(W,ic) + MPI_WTIMES(140)=MPI_WTIMES(140)+MPI_TOC(S1TIME) +C +C ** CALCULATE U AND V ON OPEN BOUNDARIES +C + 30 CONTINUE +C + if(PRINT_SUM)then + call collect_in_zero_array(UHDY ) + call collect_in_zero_array(VHDX ) + call collect_in_zero_array(U ) + call collect_in_zero_array(V ) + call collect_in_zero_array(W ) + IF(MYRANK.EQ.0) PRINT*, '0UVW_UHDY = ', sum(abs(dble(UHDY))) + IF(MYRANK.EQ.0) PRINT*, '0UVW_VHDX = ', sum(abs(dble(VHDX))) + IF(MYRANK.EQ.0) PRINT*, '0UVW_U = ', sum(abs(dble(U ))) + IF(MYRANK.EQ.0) PRINT*, '0UVW_V = ', sum(abs(dble(V ))) + IF(MYRANK.EQ.0) PRINT*, '0UVW_W = ', sum(abs(dble(W ))) + endif + S1TIME=MPI_TIC() + DO K=1,KC + DO LL=1,NCBS + L=LCBS(LL) + LN=LNC(L) + LNN=LNC(LN) + IF(LN.NE.LC)THEN + VHDX(LN,K)=VHDX(LNN,K)-VHDXE(LNN)+VHDXE(LN) + V(LN,K)=VHDX(LN,K)/(HV(LN)*DXV(LN)) + ELSE + VHDX(LN,K)=0. + V(LN,K)=0. + ENDIF + ENDDO + ENDDO + DO K=1,KC + DO LL=1,NCBW + L=LCBW(LL) + LP=L+1 + LPP=L+2 + IF(LP.NE.LC)THEN + UHDY(LP,K)=UHDY(LPP,K)-UHDYE(LPP)+UHDYE(LP) + U(LP,K)=UHDY(LP,K)/(HU(LP)*DYU(LP)) + ELSE + UHDY(LP,K)=0. + U(LP,K)=0. + ENDIF + ENDDO + ENDDO + DO K=1,KC + DO LL=1,NCBE + L=LCBE(LL) + UHDY(L,K)=UHDY(L-1,K)-UHDYE(L-1)+UHDYE(L) + U(L,K)=UHDY(L,K)/(HU(L)*DYU(L)) + ENDDO + ENDDO + DO K=1,KC + DO LL=1,NCBN + L=LCBN(LL) + LS=LSC(L) + VHDX(L,K)=VHDX(LS,K)-VHDXE(LS)+VHDXE(L) + V(L,K)=VHDX(L,K)/(HV(L)*DXV(L)) + ENDDO + ENDDO + MPI_WTIMES(120)=MPI_WTIMES(120)+MPI_TOC(S1TIME) +C +C ** CALCULATE AVERAGE CELL FACE TRANSPORTS FOR SALT, TEMPERATURE AND +C ** SEDIMENT TRANSPORT AND PLACE IN UHDY2, VHDX2 AND W2 +C + if(PRINT_SUM)then + call collect_in_zero_array(UHDY1 ) + call collect_in_zero_array(VHDX1 ) + call collect_in_zero_array(U1 ) + call collect_in_zero_array(V1 ) + call collect_in_zero_array(W1 ) + call collect_in_zero_array(UHDY ) + call collect_in_zero_array(VHDX ) + call collect_in_zero_array(U ) + call collect_in_zero_array(V ) + call collect_in_zero_array(W ) + IF(MYRANK.EQ.0) PRINT*, '1UVW_UHDY = ', sum(abs(dble(UHDY))) + IF(MYRANK.EQ.0) PRINT*, '1UVW_VHDX = ', sum(abs(dble(VHDX))) + IF(MYRANK.EQ.0) PRINT*, '1UVW_U = ', sum(abs(dble(U ))) + IF(MYRANK.EQ.0) PRINT*, '1UVW_V = ', sum(abs(dble(V ))) + IF(MYRANK.EQ.0) PRINT*, '1UVW_W = ', sum(abs(dble(W ))) + IF(MYRANK.EQ.0) PRINT*, '1UVW_UHDY1 = ', sum(abs(dble(UHDY1))) + IF(MYRANK.EQ.0) PRINT*, '1UVW_VHDX1 = ', sum(abs(dble(VHDX1))) + IF(MYRANK.EQ.0) PRINT*, '1UVW_U1 = ', sum(abs(dble(U1 ))) + IF(MYRANK.EQ.0) PRINT*, '1UVW_V1 = ', sum(abs(dble(V1 ))) + IF(MYRANK.EQ.0) PRINT*, '1UVW_W1 = ', sum(abs(dble(W1 ))) + endif + IF(ISTL_.EQ.2)THEN + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHDY2(L,K)=0.5*(UHDY(L,K)+UHDY1(L,K)) + VHDX2(L,K)=0.5*(VHDX(L,K)+VHDX1(L,K)) + U2(L,K)=0.5*(U(L,K)+U1(L,K)) + V2(L,K)=0.5*(V(L,K)+V1(L,K)) + W2(L,K)=0.5*(W(L,K)+W1(L,K)) + ENDDO + ENDDO + MPI_WTIMES(121)=MPI_WTIMES(121)+MPI_TOC(S1TIME) + ELSE + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHDY2(L,K)=0.5*(UHDY(L,K)+UHDY2(L,K)) + VHDX2(L,K)=0.5*(VHDX(L,K)+VHDX2(L,K)) + U2(L,K)=0.5*(U(L,K)+U2(L,K)) + V2(L,K)=0.5*(V(L,K)+V2(L,K)) + W2(L,K)=0.5*(W(L,K)+W2(L,K)) + ENDDO + ENDDO + MPI_WTIMES(122)=MPI_WTIMES(122)+MPI_TOC(S1TIME) + ENDIF +C + if(PRINT_SUM)then + call collect_in_zero_array(UHDY2 ) + call collect_in_zero_array(VHDX2 ) + call collect_in_zero_array(U2 ) + call collect_in_zero_array(V2 ) + call collect_in_zero_array(W2 ) + IF(MYRANK.EQ.0) PRINT*, '2UVW_UHDY2 = ', sum(abs(dble(UHDY2))) + IF(MYRANK.EQ.0) PRINT*, '2UVW_VHDX2 = ', sum(abs(dble(VHDX2))) + IF(MYRANK.EQ.0) PRINT*, '2UVW_U2 = ', sum(abs(dble(U2 ))) + IF(MYRANK.EQ.0) PRINT*, '2UVW_V2 = ', sum(abs(dble(V2 ))) + IF(MYRANK.EQ.0) PRINT*, '2UVW_W2 = ', sum(abs(dble(W2 ))) + endif +C + IF(ISWVSD.GE.1)THEN + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHDY2(L,K)=UHDY2(L,K)+DYU(L)*UVPT(L,K) + VHDX2(L,K)=VHDX2(L,K)+DXV(L)*VVPT(L,K) + U2(L,K)=U2(L,K)+UVPT(L,K)/HMU(L) + V2(L,K)=V2(L,K)+VVPT(L,K)/HMV(L) ! *** Scott James + W2(L,K)=W2(L,K)+WVPT(L,K) + ENDDO + ENDDO + MPI_WTIMES(123)=MPI_WTIMES(123)+MPI_TOC(S1TIME) + ENDIF +C + if(PRINT_SUM)then + call collect_in_zero_array(UHDY2 ) + call collect_in_zero_array(VHDX2 ) + call collect_in_zero_array(U2 ) + call collect_in_zero_array(V2 ) + call collect_in_zero_array(W2 ) + IF(MYRANK.EQ.0) PRINT*, '3UVW_UHDY2 = ', sum(abs(dble(UHDY2))) + IF(MYRANK.EQ.0) PRINT*, '3UVW_VHDX2 = ', sum(abs(dble(VHDX2))) + IF(MYRANK.EQ.0) PRINT*, '3UVW_U2 = ', sum(abs(dble(U2 ))) + IF(MYRANK.EQ.0) PRINT*, '3UVW_V2 = ', sum(abs(dble(V2 ))) + IF(MYRANK.EQ.0) PRINT*, '3UVW_W2 = ', sum(abs(dble(W2 ))) + endif +C +C ** ADDITIONAL 3D CONTINUITY ADJUSTED ADDED BELOW +C + IF(KC.GT.1)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR3E(L)=SUM(UHDY2(L,:)*DZC(:)) + TVAR3N(L)=SUM(VHDX2(L,:)*DZC(:)) + ENDDO + MPI_WTIMES(124)=MPI_WTIMES(124)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + call broadcast_boundary(TVAR3E,ic) + call broadcast_boundary(TVAR3N,ic) + MPI_WTIMES(141)=MPI_WTIMES(141)+MPI_TOC(S1TIME) + IF(ISGWIE.GE.1)THEN + IF(ISTL_.EQ.3)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(HPPTMP) + DO L=LMPI2,LMPILA + HPPTMP=H2P(L)+DELT*DXYIP(L)*( QSUME(L) + & -TVAR3E(L+1)+TVAR3E(L) + & -TVAR3N(LNC(L)) +TVAR3N(L) ) + & -DELT*DXYIP(L)*(RIFTR(L)+EVAPSW(L)) + HP(L)=SPB(L)*HPPTMP+(1.-SPB(L))*(GI*P(L)-BELV(L)) + HPI(L)=1./HP(L) + ENDDO + MPI_WTIMES(125)=MPI_WTIMES(125)+MPI_TOC(S1TIME) + ELSE + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(HPPTMP) + DO L=LMPI2,LMPILA + HPPTMP=H1P(L)+DELT*DXYIP(L)*( QSUME(L) + & -TVAR3E(L+1)+TVAR3E(L) + & -TVAR3N(LNC(L)) +TVAR3N(L) ) + & -DELT*DXYIP(L)*(RIFTR(L)+EVAPSW(L)) + HP(L)=SPB(L)*HPPTMP+(1.-SPB(L))*(GI*P(L)-BELV(L)) + HPI(L)=1./HP(L) + ENDDO + MPI_WTIMES(126)=MPI_WTIMES(126)+MPI_TOC(S1TIME) + ENDIF + ELSE + IF(ISTL_.EQ.3)THEN + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(HPPTMP) + DO L=LMPI2,LMPILA + HPPTMP=H2P(L)+DELT*DXYIP(L)*( QSUME(L) + & -TVAR3E(L+1)+TVAR3E(L) + & -TVAR3N(LNC(L)) +TVAR3N(L) ) + HP(L)=SPB(L)*HPPTMP+(1.-SPB(L))*(GI*P(L)-BELV(L)) + HPI(L)=1./HP(L) + ENDDO + MPI_WTIMES(127)=MPI_WTIMES(127)+MPI_TOC(S1TIME) + ELSE + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(HPPTMP) + DO L=LMPI2,LMPILA + HPPTMP=H1P(L)+DELT*DXYIP(L)*( QSUME(L) + & -TVAR3E(L+1)+TVAR3E(L) + & -TVAR3N(LNC(L)) +TVAR3N(L) ) + HP(L)=SPB(L)*HPPTMP+(1.-SPB(L))*(GI*P(L)-BELV(L)) + HPI(L)=1./HP(L) + ENDDO + MPI_WTIMES(128)=MPI_WTIMES(128)+MPI_TOC(S1TIME) + ENDIF + ENDIF + IF(MDCHH.GE.1)THEN + S1TIME=MPI_TIC() + RLAMN=QCHERR + RLAMO=1.-RLAMN + DO NMD=1,MDCHH + LHOST=LMDCHH(NMD) + LCHNU=LMDCHU(NMD) + LCHNV=LMDCHV(NMD) + IF(MDCHTYP(NMD).EQ.1)THEN + TMPVAL=DELT*(RLAMN*QCHANU(NMD)+RLAMO*QCHANUN(NMD)) + HP(LHOST)=HP(LHOST)+TMPVAL*DXYIP(LHOST) + HP(LCHNU)=HP(LCHNU)-TMPVAL*DXYIP(LCHNU) + HPI(LHOST)=1./HP(LHOST) + HPI(LCHNU)=1./HP(LCHNU) + ENDIF + IF(MDCHTYP(NMD).EQ.2)THEN + TMPVAL=DELT*(RLAMN*QCHANV(NMD)+RLAMO*QCHANVN(NMD)) + HP(LHOST)=HP(LHOST)+TMPVAL*DXYIP(LHOST) + HP(LCHNV)=HP(LCHNV)-TMPVAL*DXYIP(LCHNV) + HPI(LHOST)=1./HP(LHOST) + HPI(LCHNV)=1./HP(LCHNV) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(129)=MPI_WTIMES(129)+MPI_TOC(S1TIME) + ENDIF +C + S1TIME=MPI_TIC() + call broadcast_boundary(HP,IC) + call broadcast_boundary(HPI,IC) + MPI_WTIMES(142)=MPI_WTIMES(142)+MPI_TOC(S1TIME) +C +C ** ACCUMULTATE MAX COURANT NUMBERS +C +C *** DSLLC BEGIN BLOCK + IF(ISINWV.EQ.1.OR.ISNEGH.GT.0)THEN + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO PRIVATE(CFLUUUT,CFLVVVT,CFLWWWT,CFLCACT) + DO L=LMPI2,LMPILA + CFLUUUT=DELT*ABS(DXIU(L)*U(L,K)) + CFLUUU(L,K)=MAX(CFLUUUT,CFLUUU(L,K)) + CFLVVVT=DELT*ABS(DYIV(L)*V(L,K)) + CFLVVV(L,K)=MAX(CFLVVVT,CFLVVV(L,K)) + CFLWWWT=DELT*ABS(HPI(L)*DZIG(K)*W(L,K)) + CFLWWW(L,K)=MAX(CFLWWWT,CFLWWW(L,K)) + CFLCACT=DELT*ABS(CAC(L,K)*DXYIP(L)*HPI(L)) + CFLCAC(L,K)=MAX(CFLCACT,CFLCAC(L,K)) + ENDDO + ENDDO + MPI_WTIMES(130)=MPI_WTIMES(130)+MPI_TOC(S1TIME) + ENDIF +C *** DSLLC END BLOCK +C +C ** CALCULATE NONHYDROSTATIC PRESSURE +C + S1TIME=MPI_TIC() + IF(KC.GT.1.AND.ISPNHYDS.GE.1) CALL CALPNHS_mpi + MPI_WTIMES(131)=MPI_WTIMES(131)+MPI_TOC(S1TIME) +C +C ** WRITE TO DIAGNOSTIC FILE CFL.OUT WITH DIAGNOSTICS OF MAXIMUM +C ** TIME STEP +C ** SEDIMENT TRANSPORT AND PLACE IN UHDY2, VHDX2 AND W2 +C +! IF(ISCFL.GE.1.AND.ISTL_.EQ.3.AND.DEBUG)THEN +! IF(ISCFL.GE.1.AND.DEBUG)THEN + IF(ISCFL.GE.1)THEN + S1TIME=MPI_TIC() + IF(MYRANK.EQ.0)THEN + OPEN(1,FILE='CFL.OUT',STATUS='UNKNOWN',POSITION='APPEND') + ENDIF + IF(ISCFLM.GE.1.AND.N.EQ.1)THEN + IF(MYRANK.EQ.0)THEN + OPEN(2,FILE='CFLMP.OUT',STATUS='UNKNOWN') + CLOSE(2,STATUS='DELETE') + ENDIF + DO L=1,LC + ICFLMP(L)=0 + ENDDO + ENDIF + MPI_WTIMES(132)=MPI_WTIMES(132)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + DTCFL=1.E+18 + K=1 +!$OMP PARALLEL DO PRIVATE(LN,UWTMP,UETMP,VSTMP,VNTMP,WBTMP,WTTMP,DTMAXI,DTMAX +!$OMP+ ICFL,JCFL,KCFL) FIRSTPRIVATE(DTCFL) + DO L=LMPI2,LMPILA + LN=LNC(L) + UWTMP=ABS(DXIU(L )*U2(L ,K)) + UETMP=ABS(DXIU(L+1)*U2(L+1,K)) + VSTMP=ABS(DYIV(L )*V2(L ,K)) + VNTMP=ABS(DYIV(LN )*U2(LN ,K)) + WBTMP=0. + WTTMP=ABS(HPI(L)*DZIC(K)*W2(L,K)) + DTMAXI=MAX(UWTMP,UETMP)+MAX(VSTMP,VNTMP)+MAX(WBTMP,WTTMP) + & +1.0E-12 + DTMAX=0.5/DTMAXI + IF(DTMAX.LT.DTCFL)THEN + DTCFL=DTMAX + ICFL=IL(L) + JCFL=JL(L) + KCFL=K + ENDIF + ENDDO + MPI_WTIMES(133)=MPI_WTIMES(133)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(KC.GT.1)THEN + K=KC +!$OMP PARALLEL DO PRIVATE(LN,UWTMP,UETMP,VSTMP,VNTMP,WBTMP,WTTMP,DTMAXI,DTMAX +!$OMP+ ICFL,JCFL,KCFL) FIRSTPRIVATE(DTCFL) + DO L=LMPI2,LMPILA + LN=LNC(L) + UWTMP=ABS(DXIU(L )*U2(L ,K)) + UETMP=ABS(DXIU(L+1)*U2(L+1,K)) + VSTMP=ABS(DYIV(L )*V2(L ,K)) + VNTMP=ABS(DYIV(LN )*U2(LN ,K)) + WTTMP=0. + WBTMP=ABS(HPI(L)*DZIC(K)*W2(L,K-1)) + DTMAXI=MAX(UWTMP,UETMP)+MAX(VSTMP,VNTMP)+MAX(WBTMP,WTTMP) + & +1.0E-12 + DTMAX=0.5/DTMAXI + IF(DTMAX.LT.DTCFL)THEN + DTCFL=DTMAX + ICFL=IL(L) + JCFL=JL(L) + KCFL=K + ENDIF + ENDDO + ENDIF + MPI_WTIMES(134)=MPI_WTIMES(134)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(KC.GT.2)THEN + DO K=2,KS +!$OMP PARALLEL DO PRIVATE(LN,UWTMP,UETMP,VSTMP,VNTMP,WBTMP,WTTMP,DTMAXI,DTMAX +!$OMP+ ICFL,JCFL,KCFL) FIRSTPRIVATE(DTCFL) + DO L=LMPI2,LMPILA + LN=LNC(L) + UWTMP=ABS(DXIU(L )*U2(L ,K)) + UETMP=ABS(DXIU(L+1)*U2(L+1,K)) + VSTMP=ABS(DYIV(L )*V2(L ,K)) + VNTMP=ABS(DYIV(LN )*U2(LN ,K)) + WBTMP=ABS(HPI(L)*DZIC(K)*W2(L,K-1)) + WTTMP=ABS(HPI(L)*DZIC(K)*W2(L,K )) + DTMAXI=MAX(UWTMP,UETMP)+MAX(VSTMP,VNTMP)+MAX(WBTMP,WTTMP) + & +1.0E-12 + DTMAX=0.5/DTMAXI + IF(DTMAX.LT.DTCFL)THEN + DTCFL=DTMAX + ICFL=IL(L) + JCFL=JL(L) + KCFL=K + ENDIF + ENDDO + ENDDO + ENDIF + MPI_WTIMES(135)=MPI_WTIMES(135)+MPI_TOC(S1TIME) + + IF(.FALSE.)THEN + S1TIME=MPI_TIC() + IVAL=MOD(N,ISCFL) + IDTCFL=NINT(DTCFL) + MPI_WTIMES(136)=MPI_WTIMES(136)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(MYRANK.EQ.0)THEN + IF(ISCFL.EQ.1) WRITE(1,1212)DTCFL,N,ICFL,JCFL,KCFL + IF(ISCFL.GE.2.AND.IVAL.EQ.0 ) WRITE(1,1213)IDTCFL + ENDIF + MPI_WTIMES(137)=MPI_WTIMES(137)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(ISCFLM.GE.1 )THEN + LTMP=LIJ(ICFL,JCFL) + ICFLMP(LTMP)=ICFLMP(LTMP)+1 + ENDIF + IF(ISCFLM.GE.1.AND.N.EQ.NTS)THEN + IF(MYRANK.EQ.0)THEN + OPEN(2,FILE='CFLMP.OUT',STATUS='UNKNOWN') + TMPVALN=1./FLOAT(NTS) + DO L=2,LA + TMPVAL=TMPVALN*FLOAT(ICFLMP(L)) + WRITE(2,1214)IL(L),JL(L),ICFLMP(L),TMPVAL + ENDDO + CLOSE(2) + ENDIF + ENDIF + MPI_WTIMES(138)=MPI_WTIMES(138)+MPI_TOC(S1TIME) + ENDIF + IF(MYRANK.EQ.0) CLOSE(1) + + ENDIF + 1212 FORMAT(' MAX TIME STEP =',F10.2,' SEC FOR N,I,J,K =',I8,3I5) + 1213 FORMAT(I4) + 1214 FORMAT(2I5,I12,F10.2) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALVEGSER_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALVEGSER_mpi.for new file mode 100644 index 000000000..c02d4b33a --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALVEGSER_mpi.for @@ -0,0 +1,61 @@ + SUBROUTINE CALVEGSER_mpi (ISTL_) +C +C CHANGE RECORD +C NVEGSER = NUMBER OF VEGETATION TIME SERIES +C NVEGSERV(NVEGTPM) = TIME SERIES ID FOR SPECIFIC VEGETATION CLASS +C MVEGTLAST(NVEGSERM) = PLACE HOLDER IN INTERPOLATION TABLE +C TCVEGSER(NVEGSERM) = TIME CONVERSION FACTOR FOR TIME VARIABLE +C TVEGSER(NDVEGSER,NVEGSERM) = TIME OF DATA +C VEGSERRT(NVEGSERM) = CURRENT VALUE OF RDLPSQ +C VEGSERBT(NVEGSERM) = CURRENT VALUE OF BPVEG +C VEGSERHT(NVEGSERM) = CURRENT VALUE OF HPVEG +C VEGSERR(NDVEGSER,NVEGSERM) = TIME VARYING VALUES OF RDLPSQ +C VEGSERB(NDVEGSER,NVEGSERM) = TIME VARYING VALUES OF BPVEG +C VEGSERH(NDVEGSER,NVEGSERM) = TIME VARYING VALUES OF HPVEG +C ** SUBROUTINE CALVEGSR UPDATES TIME VARIABLE VEGETATION RESISTANCE +C ** PARAMETERS +C + USE GLOBAL + USE MPI + S1TIME=MPI_TIC() + IF(NVEGSER.GT.0)THEN + DO NS=1,NVEGSER + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N)/TCVEGSER(NS)+TBEGIN*(TCON/TCVEGSER(NS)) + ELSE + TIME=TIMESEC/TCVEGSER(NS) + ENDIF + M1=MVEGTLAST(NS) + 100 CONTINUE + M2=M1+1 + IF(TIME.GT.TVEGSER(M2,NS))THEN + M1=M2 + GOTO 100 + ELSE + MVEGTLAST(NS)=M1 + ENDIF + TDIFF=TVEGSER(M2,NS)-TVEGSER(M1,NS) + WTM1=(TVEGSER(M2,NS)-TIME)/TDIFF + WTM2=(TIME-TVEGSER(M1,NS))/TDIFF + VEGSERRT(NS)=WTM1*VEGSERR(M1,NS)+WTM2*VEGSERR(M2,NS) + VEGSERBT(NS)=WTM1*VEGSERB(M1,NS)+WTM2*VEGSERB(M2,NS) + VEGSERHT(NS)=WTM1*VEGSERH(M1,NS)+WTM2*VEGSERH(M2,NS) + ENDDO + DO M=1,MVEGTYP + NSTMP=NVEGSERV(M) + IF(NSTMP.GT.0)THEN + RDLPSQ(M)=VEGSERRT(NSTMP) + BPVEG(M)=VEGSERBT(NSTMP) + HPVEG(M)=VEGSERHT(NSTMP) + BDLTMP=BPVEG(M)*BPVEG(M)*RDLPSQ(M) + PVEGX(M)=1.-BETVEG(M)*BDLTMP + PVEGY(M)=1.-BETVEG(M)*BDLTMP + PVEGZ(M)=1.-ALPVEG(M)*BDLTMP + BDLPSQ(M)=BPVEG(M)*RDLPSQ(M) + ENDIF + ENDDO + ENDIF + MPI_WTIMES(1201)=MPI_WTIMES(1201)+MPI_TOC(S1TIME) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALWQC.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALWQC.for index 1d48a74e3..8c2036cd6 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALWQC.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALWQC.for @@ -7,7 +7,7 @@ C ** CALLED ONLY ON ODD THREE TIME LEVEL STEPS C USE GLOBAL - REAL TTMP, SECNDS + REAL TTMP,T1TMP DELT=DT2 IF(IS2TIM.GE.1) THEN @@ -23,7 +23,7 @@ C C ** UPDATED TIME SERIES CONCENTRATION BOUNDARY CONDITIONS C ** 3D ADVECTI0N TRANSPORT CALCULATION C - TTMP=SECNDS(0.0) + CALL CPU_TIME(TTMP) DO NW=1,NWQV IF(ISTRWQ(NW).EQ.1)THEN CALL CALTRAN(ISTL_,IS2TL_,8,NW,WQV(1,1,NW),WQV(1,1,NW)) @@ -33,26 +33,17 @@ C DO nsp=1,NXSP CALL CALTRAN(ISTL_,IS2TL_,8,nsp+NWQV,WQVX(1,1,nsp),WQVX(1,1,nsp)) ENDDO - - TWQADV=TWQADV+SECNDS(TTMP) + CALL CPU_TIME(T1TMP) + TWQADV=TWQADV+T1TMP-TTMP C C ** CALLS TO SOURCE-SINK CALCULATIONS C ** BYPASS OR INITIALIZE VERTICAL DIFFUSION CALCULATION C IF(KC.EQ.1) GOTO 2000 -! -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -! - DO L=LF,LL + DO L=2,LA HWQI(L)=1./HWQ(L) ENDDO -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO - TTMP=SECNDS(0.0) + CALL CPU_TIME(TTMP) C C ** VERTICAL DIFFUSION CALCULATION LEVEL 1 C @@ -323,15 +314,10 @@ C C ** VERTICAL DIFFUSION CALCULATION LEVEL 3 C ELSEIF(ISWQLVL.EQ.3)THEN -! -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& RCDZKK,CCUBTMP,CCMBTMP,EEB, -!$OMP& RCDZKMK,CCLBTMP, NSP) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -! RCDZKK=-DELT*CDZKK(1) + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 DO L=LF,LL CCUBTMP=RCDZKK*HWQI(L)*AB(L,1) CCMBTMP=1.-CCUBTMP @@ -371,6 +357,11 @@ C ENDDO enddo endif + !} GEOSR X-species : jgcho 2015.11.09 + ENDDO + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 DO K=2,KS RCDZKMK=-DELT*CDZKMK(K) RCDZKK=-DELT*CDZKK(K) @@ -421,8 +412,13 @@ C enddo enddo endif + !} GEOSR X-species : jgcho 2015.11.09 + ENDDO K=KC RCDZKMK=-DELT*CDZKMK(K) + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 DO L=LF,LL CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) CCMBTMP=1.-CCLBTMP @@ -461,6 +457,11 @@ C ENDDO enddo endif + !} GEOSR X-species : jgcho 2015.11.09 + ENDDO + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 DO K=KC-1,1,-1 DO L=LF,LL WQV(L,K, 1)=WQV(L,K, 1)-CU1(L,K)*WQV(L,K+1, 1) @@ -496,11 +497,10 @@ C enddo enddo endif -! - enddo !do ithds=0,nthds-1 -!$OMP END PARALLEL DO + ENDDO ENDIF - TWQDIF=TWQDIF+SECNDS(TTMP) + CALL CPU_TIME(T1TMP) + TWQDIF=TWQDIF+T1TMP-TTMP 2000 CONTINUE RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALWQC_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALWQC_mpi.for new file mode 100644 index 000000000..ab58f3e67 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CALWQC_mpi.for @@ -0,0 +1,507 @@ + SUBROUTINE CALWQC_mpi(ISTL_,IS2TL_) +C +C CHANGE RECORD +C ** SUBROUTINE CALWQC CALCULATES THE CONCENTRATION OF DISSOLVED AND +C ** SUSPENDED WATER QUALITY CONSTITUTENTS AT TIME LEVEL (N+1). +C ** CALLED ONLY ON ODD THREE TIME LEVEL STEPS +C + USE GLOBAL + USE MPI + + LOGICAL WQC_MPI +C + WQC_MPI=.TRUE. +C + DELT=DT2 + IF(IS2TIM.GE.1) THEN + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + ISUD=0 + ELSE + DELT=DTDYN + ISUD=0 + END IF + ENDIF +C +C ** UPDATED TIME SERIES CONCENTRATION BOUNDARY CONDITIONS +C ** 3D ADVECTI0N TRANSPORT CALCULATION +C +CGEO DO NW=0,NWQV +CGEO call collect_in_zero_array(WQV(:,:,NW)) +CGEO ENDDO +CGEO IF(MYRANK.EQ.0)THEN +CGEO PRINT*, n,'h1WQV = ', sum(abs(dble(WQV))) +CGEO ENDIF + S2TIME=MPI_TIC() + DO NW=1,NWQV + IF(ISTRWQ(NW).EQ.1)THEN + CALL CALTRAN_mpi(ISTL_,IS2TL_,8,NW,WQV(1,1,NW),WQV(1,1,NW)) + ENDIF + ENDDO + MPI_WTIMES(721)=MPI_WTIMES(721)+MPI_TOC(S2TIME) +C +CGEO DO NW=0,NWQV +CGEO call collect_in_zero_array(WQV(:,:,NW)) +CGEO ENDDO +CGEO IF(MYRANK.EQ.0)THEN +CGEO PRINT*, n,'h2WQV = ', sum(abs(dble(WQV))) +CGEO ENDIF + S2TIME=MPI_TIC() + DO NSP=1,NXSP + CALL CALTRAN_mpi(ISTL_,IS2TL_,8,NSP+NWQV, + & WQVX(1,1,NSP),WQVX(1,1,NSP)) + ENDDO + MPI_WTIMES(722)=MPI_WTIMES(722)+MPI_TOC(S2TIME) +CGEO DO NSP=1,NXSP; call collect_in_zero_array(WQVX(:,:,NSP)); ENDDO +CGEO DO NSP=1,NXSP +CGEO IF(MYRANK.EQ.0) PRINT*, 'a2',nsp,sum(abs(dble(WQVX(:,:,NSP)))) +CGEO ENDDO +C +C ** CALLS TO SOURCE-SINK CALCULATIONS +C ** BYPASS OR INITIALIZE VERTICAL DIFFUSION CALCULATION +C + IF(KC.EQ.1) GOTO 2000 + S2TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + HWQI(L)=1./HWQ(L) + ENDDO + MPI_WTIMES(723)=MPI_WTIMES(723)+MPI_TOC(S2TIME) +C +C ** VERTICAL DIFFUSION CALCULATION LEVEL 1 +C + IF(ISWQLVL.EQ.1)THEN + S2TIME=MPI_TIC() + RCDZKK=-DELT*CDZKK(1) + DO NW=1,NWQV +!$OMP PARALLEL DO PRIVATE(CCUBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCUBTMP=RCDZKK*HWQI(L)*AB(L,1) + CCMBTMP=1.-CCUBTMP + EEB=1./CCMBTMP + CU1(L,1)=CCUBTMP*EEB + WQV(L,1,NW)=WQV(L,1,NW)*EEB + ENDDO + ENDDO + MPI_WTIMES(724)=MPI_WTIMES(724)+MPI_TOC(S2TIME) +C + S2TIME=MPI_TIC() + DO NW=1,NWQV + DO K=2,KS + RCDZKMK=-DELT*CDZKMK(K) + RCDZKK=-DELT*CDZKK(K) +!$OMP PARALLEL DO PRIVATE(CCLBTMP,CCUBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCUBTMP=RCDZKK*HWQI(L)*AB(L,K) + CCMBTMP=1.-CCLBTMP-CCUBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + CU1(L,K)=CCUBTMP*EEB + WQV(L,K,NW)=(WQV(L,K,NW)-CCLBTMP*WQV(L,K-1,NW))*EEB + ENDDO + ENDDO + ENDDO + MPI_WTIMES(725)=MPI_WTIMES(725)+MPI_TOC(S2TIME) +C + S2TIME=MPI_TIC() + K=KC + RCDZKMK=-DELT*CDZKMK(K) + DO NW=1,NWQV +!$OMP PARALLEL DO PRIVATE(CCLBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCMBTMP=1.-CCLBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + WQV(L,K,NW)=(WQV(L,K,NW)-CCLBTMP*WQV(L,K-1,NW))*EEB + ENDDO + ENDDO + DO NW=1,NWQV + DO K=KC-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQV(L,K,NW)=WQV(L,K,NW)-CU1(L,K)*WQV(L,K+1,NW) + ENDDO + ENDDO + ENDDO + MPI_WTIMES(726)=MPI_WTIMES(726)+MPI_TOC(S2TIME) +C +C ** VERTICAL DIFFUSION CALCULATION LEVEL 2 +C + ELSEIF(ISWQLVL.EQ.2)THEN +C + S2TIME=MPI_TIC() + RCDZKK=-DELT*CDZKK(1) + DO NW=1,NWQV +!$OMP PARALLEL DO PRIVATE(CCUBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCUBTMP=RCDZKK*HWQI(L)*AB(L,1) + CCMBTMP=1.-CCUBTMP + EEB=1./CCMBTMP + CU1(L,1)=CCUBTMP*EEB + WQV(L,1,NW)=WQV(L,1,NW)*EEB + ENDDO + ENDDO + MPI_WTIMES(727)=MPI_WTIMES(727)+MPI_TOC(S2TIME) +C + S2TIME=MPI_TIC() + DO NW=1,NWQV + DO K=2,KS + RCDZKMK=-DELT*CDZKMK(K) + RCDZKK=-DELT*CDZKK(K) +!$OMP PARALLEL DO PRIVATE(CCLBTMP,CCUBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCUBTMP=RCDZKK*HWQI(L)*AB(L,K) + CCMBTMP=1.-CCLBTMP-CCUBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + CU1(L,K)=CCUBTMP*EEB + WQV(L,K,NW)=(WQV(L,K,NW)-CCLBTMP*WQV(L,K-1,NW))*EEB + ENDDO + ENDDO + ENDDO + MPI_WTIMES(728)=MPI_WTIMES(728)+MPI_TOC(S2TIME) +C + S2TIME=MPI_TIC() + K=KC + RCDZKMK=-DELT*CDZKMK(K) + DO NW=1,NWQV +!$OMP PARALLEL DO PRIVATE(CCLBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCMBTMP=1.-CCLBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + WQV(L,K,NW)=(WQV(L,K,NW)-CCLBTMP*WQV(L,K-1,NW))*EEB + ENDDO + ENDDO + DO NW=1,NWQV + DO K=KC-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQV(L,K,NW)=WQV(L,K,NW)-CU1(L,K)*WQV(L,K+1,NW) + ENDDO + ENDDO + ENDDO + MPI_WTIMES(729)=MPI_WTIMES(729)+MPI_TOC(S2TIME) +C +C ** VERTICAL DIFFUSION CALCULATION LEVEL 3 +C + ELSEIF(ISWQLVL.EQ.3)THEN + S2TIME=MPI_TIC() + IF(.FALSE.)THEN + RCDZKK=-DELT*CDZKK(1) + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO L=LF,LL + CCUBTMP=RCDZKK*HWQI(L)*AB(L,1) + CCMBTMP=1.-CCUBTMP + EEB=1./CCMBTMP + CU1(L,1)=CCUBTMP*EEB + WQV(L,1, 1)=WQV(L,1, 1)*EEB + WQV(L,1, 2)=WQV(L,1, 2)*EEB + WQV(L,1, 3)=WQV(L,1, 3)*EEB + WQV(L,1, 4)=WQV(L,1, 4)*EEB + WQV(L,1, 5)=WQV(L,1, 5)*EEB + WQV(L,1, 6)=WQV(L,1, 6)*EEB + WQV(L,1, 7)=WQV(L,1, 7)*EEB + WQV(L,1, 8)=WQV(L,1, 8)*EEB + WQV(L,1, 9)=WQV(L,1, 9)*EEB + WQV(L,1,10)=WQV(L,1,10)*EEB + WQV(L,1,11)=WQV(L,1,11)*EEB + WQV(L,1,12)=WQV(L,1,12)*EEB + WQV(L,1,13)=WQV(L,1,13)*EEB + WQV(L,1,14)=WQV(L,1,14)*EEB + WQV(L,1,15)=WQV(L,1,15)*EEB + WQV(L,1,16)=WQV(L,1,16)*EEB + WQV(L,1,17)=WQV(L,1,17)*EEB + WQV(L,1,18)=WQV(L,1,18)*EEB + WQV(L,1,19)=WQV(L,1,19)*EEB + WQV(L,1,20)=WQV(L,1,20)*EEB + WQV(L,1,21)=WQV(L,1,21)*EEB + ENDDO + !{ GEOSR X-species : jgcho 2015.11.09 + if (NXSP.gt.0) then + DO L=LF,LL + CCUBTMP=RCDZKK*HWQI(L)*AB(L,1) + CCMBTMP=1.-CCUBTMP + EEB=1./CCMBTMP + CU1(L,1)=CCUBTMP*EEB + DO nsp=1,NXSP + WQVX(L,1,nsp)=WQVX(L,1,nsp)*EEB + ENDDO + enddo + endif + !} GEOSR X-species : jgcho 2015.11.09 + ENDDO + ELSE + RCDZKK=-DELT*CDZKK(1) + DO NW=1,NWQV +!$OMP PARALLEL DO PRIVATE(CCUBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCUBTMP=RCDZKK*HWQI(L)*AB(L,1) + CCMBTMP=1.-CCUBTMP + EEB=1./CCMBTMP + CU1(L,1)=CCUBTMP*EEB + WQV(L,1,NW)=WQV(L,1,NW)*EEB + ENDDO + ENDDO + IF(NXSP.GT.0)THEN + DO NSP=1,NXSP +!$OMP PARALLEL DO PRIVATE(CCUBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCUBTMP=RCDZKK*HWQI(L)*AB(L,1) + CCMBTMP=1.-CCUBTMP + EEB=1./CCMBTMP + CU1(L,1)=CCUBTMP*EEB + WQVX(L,1,NSP)=WQVX(L,1,NSP)*EEB + ENDDO + ENDDO + ENDIF + ENDIF + MPI_WTIMES(730)=MPI_WTIMES(730)+MPI_TOC(S2TIME) +C + IF(.FALSE.)THEN + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO K=2,KS + RCDZKMK=-DELT*CDZKMK(K) + RCDZKK=-DELT*CDZKK(K) + DO L=LF,LL + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCUBTMP=RCDZKK*HWQI(L)*AB(L,K) + CCMBTMP=1.-CCLBTMP-CCUBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + CU1(L,K)=CCUBTMP*EEB + WQV(L,K, 1)=(WQV(L,K, 1)-CCLBTMP*WQV(L,K-1, 1))*EEB + WQV(L,K, 2)=(WQV(L,K, 2)-CCLBTMP*WQV(L,K-1, 2))*EEB + WQV(L,K, 3)=(WQV(L,K, 3)-CCLBTMP*WQV(L,K-1, 3))*EEB + WQV(L,K, 4)=(WQV(L,K, 4)-CCLBTMP*WQV(L,K-1, 4))*EEB + WQV(L,K, 5)=(WQV(L,K, 5)-CCLBTMP*WQV(L,K-1, 5))*EEB + WQV(L,K, 6)=(WQV(L,K, 6)-CCLBTMP*WQV(L,K-1, 6))*EEB + WQV(L,K, 7)=(WQV(L,K, 7)-CCLBTMP*WQV(L,K-1, 7))*EEB + WQV(L,K, 8)=(WQV(L,K, 8)-CCLBTMP*WQV(L,K-1, 8))*EEB + WQV(L,K, 9)=(WQV(L,K, 9)-CCLBTMP*WQV(L,K-1, 9))*EEB + WQV(L,K,10)=(WQV(L,K,10)-CCLBTMP*WQV(L,K-1,10))*EEB + WQV(L,K,11)=(WQV(L,K,11)-CCLBTMP*WQV(L,K-1,11))*EEB + WQV(L,K,12)=(WQV(L,K,12)-CCLBTMP*WQV(L,K-1,12))*EEB + WQV(L,K,13)=(WQV(L,K,13)-CCLBTMP*WQV(L,K-1,13))*EEB + WQV(L,K,14)=(WQV(L,K,14)-CCLBTMP*WQV(L,K-1,14))*EEB + WQV(L,K,15)=(WQV(L,K,15)-CCLBTMP*WQV(L,K-1,15))*EEB + WQV(L,K,16)=(WQV(L,K,16)-CCLBTMP*WQV(L,K-1,16))*EEB + WQV(L,K,17)=(WQV(L,K,17)-CCLBTMP*WQV(L,K-1,17))*EEB + WQV(L,K,18)=(WQV(L,K,18)-CCLBTMP*WQV(L,K-1,18))*EEB + WQV(L,K,19)=(WQV(L,K,19)-CCLBTMP*WQV(L,K-1,19))*EEB + WQV(L,K,20)=(WQV(L,K,20)-CCLBTMP*WQV(L,K-1,20))*EEB + WQV(L,K,21)=(WQV(L,K,21)-CCLBTMP*WQV(L,K-1,21))*EEB + ENDDO + ENDDO + !{ GEOSR X-species : jgcho 2015.11.09 + if (NXSP.gt.0) then + DO K=2,KS + RCDZKMK=-DELT*CDZKMK(K) + RCDZKK=-DELT*CDZKK(K) + DO L=LF,LL + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCUBTMP=RCDZKK*HWQI(L)*AB(L,K) + CCMBTMP=1.-CCLBTMP-CCUBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + CU1(L,K)=CCUBTMP*EEB + DO nsp=1,NXSP + WQVX(L,K,nsp)=(WQVX(L,K,nsp)-CCLBTMP*WQVX(L,K-1,nsp)) + & *EEB + ENDDO + enddo + enddo + endif + !} GEOSR X-species : jgcho 2015.11.09 + ENDDO + ELSE + S2TIME=MPI_TIC() +C DO NW=1,NWQV + DO K=2,KS + RCDZKMK=-DELT*CDZKMK(K) + RCDZKK=-DELT*CDZKK(K) +!$OMP PARALLEL DO PRIVATE(CCLBTMP,CCUBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCUBTMP=RCDZKK*HWQI(L)*AB(L,K) + CCMBTMP=1.-CCLBTMP-CCUBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + CU1(L,K)=CCUBTMP*EEB + WQV(L,K,1:NWQV)=(WQV(L,K,1:NWQV)-CCLBTMP + & *WQV(L,K-1,1:NWQV))*EEB + ENDDO + ENDDO +C ENDDO + MPI_WTIMES(731)=MPI_WTIMES(731)+MPI_TOC(S2TIME) + S2TIME=MPI_TIC() + IF(NXSP.GT.0)THEN +C DO NSP=1,NXSP + DO K=2,KS + RCDZKMK=-DELT*CDZKMK(K) + RCDZKK=-DELT*CDZKK(K) +!$OMP PARALLEL DO PRIVATE(CCLBTMP,CCUBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCUBTMP=RCDZKK*HWQI(L)*AB(L,K) + CCMBTMP=1.-CCLBTMP-CCUBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + CU1(L,K)=CCUBTMP*EEB + WQVX(L,K,1:NXSP)=(WQVX(L,K,1:NXSP)-CCLBTMP + & *WQVX(L,K-1,1:NXSP))*EEB + ENDDO + ENDDO +C ENDDO + ENDIF + MPI_WTIMES(732)=MPI_WTIMES(732)+MPI_TOC(S2TIME) + ENDIF +C + IF(.FALSE.)THEN + K=KC + RCDZKMK=-DELT*CDZKMK(K) + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO L=LF,LL + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCMBTMP=1.-CCLBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + WQV(L,K, 1)=(WQV(L,K, 1)-CCLBTMP*WQV(L,K-1, 1))*EEB + WQV(L,K, 2)=(WQV(L,K, 2)-CCLBTMP*WQV(L,K-1, 2))*EEB + WQV(L,K, 3)=(WQV(L,K, 3)-CCLBTMP*WQV(L,K-1, 3))*EEB + WQV(L,K, 4)=(WQV(L,K, 4)-CCLBTMP*WQV(L,K-1, 4))*EEB + WQV(L,K, 5)=(WQV(L,K, 5)-CCLBTMP*WQV(L,K-1, 5))*EEB + WQV(L,K, 6)=(WQV(L,K, 6)-CCLBTMP*WQV(L,K-1, 6))*EEB + WQV(L,K, 7)=(WQV(L,K, 7)-CCLBTMP*WQV(L,K-1, 7))*EEB + WQV(L,K, 8)=(WQV(L,K, 8)-CCLBTMP*WQV(L,K-1, 8))*EEB + WQV(L,K, 9)=(WQV(L,K, 9)-CCLBTMP*WQV(L,K-1, 9))*EEB + WQV(L,K,10)=(WQV(L,K,10)-CCLBTMP*WQV(L,K-1,10))*EEB + WQV(L,K,11)=(WQV(L,K,11)-CCLBTMP*WQV(L,K-1,11))*EEB + WQV(L,K,12)=(WQV(L,K,12)-CCLBTMP*WQV(L,K-1,12))*EEB + WQV(L,K,13)=(WQV(L,K,13)-CCLBTMP*WQV(L,K-1,13))*EEB + WQV(L,K,14)=(WQV(L,K,14)-CCLBTMP*WQV(L,K-1,14))*EEB + WQV(L,K,15)=(WQV(L,K,15)-CCLBTMP*WQV(L,K-1,15))*EEB + WQV(L,K,16)=(WQV(L,K,16)-CCLBTMP*WQV(L,K-1,16))*EEB + WQV(L,K,17)=(WQV(L,K,17)-CCLBTMP*WQV(L,K-1,17))*EEB + WQV(L,K,18)=(WQV(L,K,18)-CCLBTMP*WQV(L,K-1,18))*EEB + WQV(L,K,19)=(WQV(L,K,19)-CCLBTMP*WQV(L,K-1,19))*EEB + WQV(L,K,20)=(WQV(L,K,20)-CCLBTMP*WQV(L,K-1,20))*EEB + WQV(L,K,21)=(WQV(L,K,21)-CCLBTMP*WQV(L,K-1,21))*EEB + ENDDO + !{ GEOSR X-species : jgcho 2015.11.09 + if (NXSP.gt.0) then + DO L=LF,LL + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCMBTMP=1.-CCLBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + DO nsp=1,NXSP + WQVX(L,K,nsp)=(WQVX(L,K,nsp)-CCLBTMP*WQVX(L,K-1,nsp)) + & *EEB + ENDDO + enddo + endif + !} GEOSR X-species : jgcho 2015.11.09 + ENDDO + ELSE + S2TIME=MPI_TIC() + K=KC + RCDZKMK=-DELT*CDZKMK(K) +C DO NW=1,NWQV +!$OMP PARALLEL DO PRIVATE(CCLBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCMBTMP=1.-CCLBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + WQV(L,K,1:NWQV)=(WQV(L,K,1:NWQV)-CCLBTMP + & *WQV(L,K-1,1:NWQV))*EEB + ENDDO +C ENDDO + MPI_WTIMES(733)=MPI_WTIMES(733)+MPI_TOC(S2TIME) + S2TIME=MPI_TIC() + IF(NXSP.GT.0)THEN +C DO NSP=1,NXSP +!$OMP PARALLEL DO PRIVATE(CCLBTMP,CCMBTMP,EEB) + DO L=LMPI2,LMPILA + CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1) + CCMBTMP=1.-CCLBTMP + EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1)) + WQVX(L,K,1:NXSP)=(WQVX(L,K,1:NXSP)-CCLBTMP + & *WQVX(L,K-1,1:NXSP))*EEB + ENDDO +C ENDDO + ENDIF + ENDIF + MPI_WTIMES(734)=MPI_WTIMES(734)+MPI_TOC(S2TIME) +C + IF(.FALSE.)THEN + DO ND=1,NDM + LF=2+(ND-1)*LDM + LL=LF+LDM-1 + DO K=KC-1,1,-1 + DO L=LF,LL + WQV(L,K, 1)=WQV(L,K, 1)-CU1(L,K)*WQV(L,K+1, 1) + WQV(L,K, 2)=WQV(L,K, 2)-CU1(L,K)*WQV(L,K+1, 2) + WQV(L,K, 3)=WQV(L,K, 3)-CU1(L,K)*WQV(L,K+1, 3) + WQV(L,K, 4)=WQV(L,K, 4)-CU1(L,K)*WQV(L,K+1, 4) + WQV(L,K, 5)=WQV(L,K, 5)-CU1(L,K)*WQV(L,K+1, 5) + WQV(L,K, 6)=WQV(L,K, 6)-CU1(L,K)*WQV(L,K+1, 6) + WQV(L,K, 7)=WQV(L,K, 7)-CU1(L,K)*WQV(L,K+1, 7) + WQV(L,K, 8)=WQV(L,K, 8)-CU1(L,K)*WQV(L,K+1, 8) + WQV(L,K, 9)=WQV(L,K, 9)-CU1(L,K)*WQV(L,K+1, 9) + WQV(L,K,10)=WQV(L,K,10)-CU1(L,K)*WQV(L,K+1,10) + WQV(L,K,11)=WQV(L,K,11)-CU1(L,K)*WQV(L,K+1,11) + WQV(L,K,12)=WQV(L,K,12)-CU1(L,K)*WQV(L,K+1,12) + WQV(L,K,13)=WQV(L,K,13)-CU1(L,K)*WQV(L,K+1,13) + WQV(L,K,14)=WQV(L,K,14)-CU1(L,K)*WQV(L,K+1,14) + WQV(L,K,15)=WQV(L,K,15)-CU1(L,K)*WQV(L,K+1,15) + WQV(L,K,16)=WQV(L,K,16)-CU1(L,K)*WQV(L,K+1,16) + WQV(L,K,17)=WQV(L,K,17)-CU1(L,K)*WQV(L,K+1,17) + WQV(L,K,18)=WQV(L,K,18)-CU1(L,K)*WQV(L,K+1,18) + WQV(L,K,19)=WQV(L,K,19)-CU1(L,K)*WQV(L,K+1,19) + WQV(L,K,20)=WQV(L,K,20)-CU1(L,K)*WQV(L,K+1,20) + WQV(L,K,21)=WQV(L,K,21)-CU1(L,K)*WQV(L,K+1,21) + ENDDO + ENDDO + !{ GEOSR X-species : jgcho 2015.11.09 + if (NXSP.gt.0) then + DO K=KC-1,1,-1 + DO L=LF,LL + DO nsp=1,NXSP + WQVX(L,K,nsp)=WQVX(L,K,nsp)-CU1(L,K)*WQVX(L,K+1,nsp) + ENDDO + enddo + enddo + endif + !} GEOSR X-species : jgcho 2015.11.09 + ENDDO + ELSE + S2TIME=MPI_TIC() +C DO NW=1,NWQV + DO K=KC-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQV(L,K,1:NWQV)=WQV(L,K,1:NWQV)-CU1(L,K)*WQV(L,K+1,1:NWQV) + ENDDO + ENDDO +C ENDDO + MPI_WTIMES(735)=MPI_WTIMES(735)+MPI_TOC(S2TIME) + S2TIME=MPI_TIC() + IF(NXSP.GT.0)THEN +C DO NSP=1,NXSP + DO K=KC-1,1,-1 +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQVX(L,K,1:NXSP)=WQVX(L,K,1:NXSP)-CU1(L,K) + & *WQVX(L,K+1,1:NXSP) + ENDDO + ENDDO +C ENDDO + ENDIF + MPI_WTIMES(736)=MPI_WTIMES(736)+MPI_TOC(S2TIME) + ENDIF + ENDIF + 2000 CONTINUE + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CELLMAP.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CELLMAP.for index d9ec90a78..f797641b8 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CELLMAP.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CELLMAP.for @@ -4,6 +4,7 @@ C ** SUBROUTINE CELLMAP GENERATES CELL MAPPINGS C CHANGE RECORD C USE GLOBAL + USE MPI C C ** SET 1D CELL INDEX SEQUENCE AND MAPPINGS C @@ -24,7 +25,7 @@ C IF(IJCT(I,J).EQ.9) WRITE(1,1616)I,J ENDDO LA=L-1 LCTT=L - IF(LCTT.NE.LC)THEN + IF(LCTT.NE.LC.AND.MYRANK.EQ.0)THEN WRITE(6,1617)LCTT,LC WRITE(7,1617)LCTT,LC WRITE(8,1617)LCTT,LC @@ -35,8 +36,8 @@ C IF(IJCT(I,J).EQ.9) WRITE(1,1616)I,J JL(1)=0 JL(LC)=0 c WRITE(1,601)LA - WRITE(7,601)LA - WRITE(8,601)LA + IF(MYRANK.EQ.0) WRITE(7,601)LA + IF(MYRANK.EQ.0) WRITE(8,601)LA c CLOSE(1) 601 FORMAT(' LA=',I10,//) 1616 FORMAT(2I10) @@ -74,8 +75,8 @@ c CLOSE(1) LALT=L-1 LCLT=L ENDIF - WRITE(7,1616)LALT,LCLT - WRITE(8,1616)LALT,LCLT + IF(MYRANK.EQ.0) WRITE(7,1616)LALT,LCLT + IF(MYRANK.EQ.0) WRITE(8,1616)LALT,LCLT C C ** ASSIGN RED AND BLACK CELL SEQUENCES (PMC - NOT FUNCTIONAL) C @@ -104,31 +105,37 @@ C ELSE LNC(L)=LIJ(I,J+1) ENDIF +! IF(LNC(L).EQ.0) LNC(L)=LC IF(IJCT(I,J-1).EQ.9)THEN LSC(L)=LC ELSE LSC(L)=LIJ(I,J-1) ENDIF +! IF(LSC(L).EQ.0) LSC(L)=LC IF(IJCT(I+1,J+1).EQ.9)THEN LNEC(L)=LC ELSE LNEC(L)=LIJ(I+1,J+1) ENDIF +! IF(LNEC(L).EQ.0) LNEC(L)=LC IF(IJCT(I-1,J+1).EQ.9)THEN LNWC(L)=LC ELSE LNWC(L)=LIJ(I-1,J+1) ENDIF +! IF(LNWC(L).EQ.0) LNWC(L)=LC IF(IJCT(I+1,J-1).EQ.9)THEN LSEC(L)=LC ELSE LSEC(L)=LIJ(I+1,J-1) ENDIF +! IF(LSEC(L).EQ.0) LSEC(L)=LC IF(IJCT(I-1,J-1).EQ.9)THEN LSWC(L)=LC ELSE LSWC(L)=LIJ(I-1,J-1) ENDIF +! IF(LSWC(L).EQ.0) LSWC(L)=LC ENDDO C C ** MODIFY NORTH-SOUTH CELL MAPPING FOR PERIOD GRID IN N-S DIRECTION @@ -231,44 +238,44 @@ C !ENDDO ! 220 CONTINUE - 101 FORMAT(' LR,LTMP = ',2I6/) - 102 FORMAT(' LR,LTMP = ',2I6/) - 103 FORMAT(' LN= 1, LR,LTMP,ITMP,JTMP = ',4I6/) - 104 FORMAT(' LN=LC, LR,LTMP,ITMP,JTMP = ',4I6/) - 105 FORMAT(' NERR, LR,LTMP,ITMP,JTMP,INTMP,JNTMP = ',6I6/) - 106 FORMAT(' NERR, LR,LTMP,ITMP,JTMP,INTMP,JNTMP = ',6I6/) - 107 FORMAT(' LS= 1, LR,LTMP,ITMP,JTMP = ',4I6/) - 108 FORMAT(' LS=LC, LR,LTMP,ITMP,JTMP = ',4I6/) - 109 FORMAT(' SERR, LR,LTMP,ITMP,JTMP,ISTMP,JSTMP = ',6I6/) - 110 FORMAT(' SERR, LR,LTMP,ITMP,JTMP,ISTMP,JSTMP = ',6I6/) - 111 FORMAT(' LE= 1, LR,LTMP,ITMP,JTMP = ',4I6/) - 112 FORMAT(' LE=LC, LR,LTMP,ITMP,JTMP = ',4I6/) - 113 FORMAT(' EERR, LR,LTMP,ITMP,JTMP,IETMP,JETMP = ',6I6/) - 114 FORMAT(' EERR, LR,LTMP,ITMP,JTMP,IETMP,JETMP = ',6I6/) - 115 FORMAT(' LW= 1, LR,LTMP,ITMP,JTMP = ',4I6/) - 116 FORMAT(' LW=LC, LR,LTMP,ITMP,JTMP = ',4I6/) - 117 FORMAT(' WERR, LR,LTMP,ITMP,JTMP,IWTMP,JWTMP = ',6I6/) - 118 FORMAT(' WERR, LR,LTMP,ITMP,JTMP,IWTMP,JWTMP = ',6I6/) - 201 FORMAT(' LB,LTMP = ',2I6/) - 202 FORMAT(' LB,LTMP = ',2I6/) - 203 FORMAT(' LN= 1, LB,LTMP,ITMP,JTMP = ',4I6/) - 204 FORMAT(' LN=LC, LB,LTMP,ITMP,JTMP = ',4I6/) - 205 FORMAT(' NERR, LB,LTMP,ITMP,JTMP,INTMP,JNTMP = ',6I6/) - 206 FORMAT(' NERR, LB,LTMP,ITMP,JTMP,INTMP,JNTMP = ',6I6/) - 207 FORMAT(' LS= 1, LB,LTMP,ITMP,JTMP = ',4I6/) - 208 FORMAT(' LS=LC, LB,LTMP,ITMP,JTMP = ',4I6/) - 209 FORMAT(' SERR, LB,LTMP,ITMP,JTMP,ISTMP,JSTMP = ',6I6/) - 210 FORMAT(' SERR, LB,LTMP,ITMP,JTMP,ISTMP,JSTMP = ',6I6/) - 211 FORMAT(' LE= 1, LB,LTMP,ITMP,JTMP = ',4I6/) - 212 FORMAT(' LE=LC, LB,LTMP,ITMP,JTMP = ',4I6/) - 213 FORMAT(' EERR, LB,LTMP,ITMP,JTMP,IETMP,JETMP = ',6I6/) - 214 FORMAT(' EERR, LB,LTMP,ITMP,JTMP,IETMP,JETMP = ',6I6/) - 215 FORMAT(' LW= 1, LB,LTMP,ITMP,JTMP = ',4I6/) - 216 FORMAT(' LW=LC, LB,LTMP,ITMP,JTMP = ',4I6/) - 217 FORMAT(' WERR, LB,LTMP,ITMP,JTMP,IWTMP,JWTMP = ',6I6/) - 218 FORMAT(' WERR, LB,LTMP,ITMP,JTMP,IWTMP,JWTMP = ',6I6/) - 119 FORMAT(' SUB(LETMP) = ',F10.2/) - 120 FORMAT(' SUB(LTMP) = ',F10.2/) +C 101 FORMAT(' LR,LTMP = ',2I6/) +C 102 FORMAT(' LR,LTMP = ',2I6/) +C 103 FORMAT(' LN= 1, LR,LTMP,ITMP,JTMP = ',4I6/) +C 104 FORMAT(' LN=LC, LR,LTMP,ITMP,JTMP = ',4I6/) +C 105 FORMAT(' NERR, LR,LTMP,ITMP,JTMP,INTMP,JNTMP = ',6I6/) +C 106 FORMAT(' NERR, LR,LTMP,ITMP,JTMP,INTMP,JNTMP = ',6I6/) +C 107 FORMAT(' LS= 1, LR,LTMP,ITMP,JTMP = ',4I6/) +C 108 FORMAT(' LS=LC, LR,LTMP,ITMP,JTMP = ',4I6/) +C 109 FORMAT(' SERR, LR,LTMP,ITMP,JTMP,ISTMP,JSTMP = ',6I6/) +C 110 FORMAT(' SERR, LR,LTMP,ITMP,JTMP,ISTMP,JSTMP = ',6I6/) +C 111 FORMAT(' LE= 1, LR,LTMP,ITMP,JTMP = ',4I6/) +C 112 FORMAT(' LE=LC, LR,LTMP,ITMP,JTMP = ',4I6/) +C 113 FORMAT(' EERR, LR,LTMP,ITMP,JTMP,IETMP,JETMP = ',6I6/) +C 114 FORMAT(' EERR, LR,LTMP,ITMP,JTMP,IETMP,JETMP = ',6I6/) +C 115 FORMAT(' LW= 1, LR,LTMP,ITMP,JTMP = ',4I6/) +C 116 FORMAT(' LW=LC, LR,LTMP,ITMP,JTMP = ',4I6/) +C 117 FORMAT(' WERR, LR,LTMP,ITMP,JTMP,IWTMP,JWTMP = ',6I6/) +C 118 FORMAT(' WERR, LR,LTMP,ITMP,JTMP,IWTMP,JWTMP = ',6I6/) +C 201 FORMAT(' LB,LTMP = ',2I6/) +C 202 FORMAT(' LB,LTMP = ',2I6/) +C 203 FORMAT(' LN= 1, LB,LTMP,ITMP,JTMP = ',4I6/) +C 204 FORMAT(' LN=LC, LB,LTMP,ITMP,JTMP = ',4I6/) +C 205 FORMAT(' NERR, LB,LTMP,ITMP,JTMP,INTMP,JNTMP = ',6I6/) +C 206 FORMAT(' NERR, LB,LTMP,ITMP,JTMP,INTMP,JNTMP = ',6I6/) +C 207 FORMAT(' LS= 1, LB,LTMP,ITMP,JTMP = ',4I6/) +C 208 FORMAT(' LS=LC, LB,LTMP,ITMP,JTMP = ',4I6/) +C 209 FORMAT(' SERR, LB,LTMP,ITMP,JTMP,ISTMP,JSTMP = ',6I6/) +C 210 FORMAT(' SERR, LB,LTMP,ITMP,JTMP,ISTMP,JSTMP = ',6I6/) +C 211 FORMAT(' LE= 1, LB,LTMP,ITMP,JTMP = ',4I6/) +C 212 FORMAT(' LE=LC, LB,LTMP,ITMP,JTMP = ',4I6/) +C 213 FORMAT(' EERR, LB,LTMP,ITMP,JTMP,IETMP,JETMP = ',6I6/) +C 214 FORMAT(' EERR, LB,LTMP,ITMP,JTMP,IETMP,JETMP = ',6I6/) +C 215 FORMAT(' LW= 1, LB,LTMP,ITMP,JTMP = ',4I6/) +C 216 FORMAT(' LW=LC, LB,LTMP,ITMP,JTMP = ',4I6/) +C 217 FORMAT(' WERR, LB,LTMP,ITMP,JTMP,IWTMP,JWTMP = ',6I6/) +C 218 FORMAT(' WERR, LB,LTMP,ITMP,JTMP,IWTMP,JWTMP = ',6I6/) +C 119 FORMAT(' SUB(LETMP) = ',F10.2/) +C 120 FORMAT(' SUB(LTMP) = ',F10.2/) C C ** DEFINE MAPPING TO 3D GRAPHICS GRID C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CEQICM.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CEQICM.for index 82e403d71..99fe7ed8a 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CEQICM.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CEQICM.for @@ -4,6 +4,7 @@ C CHANGE RECORD C ** SUBROUTINE FOR INTERFACING CE-QUAL-ICM MODEL C USE GLOBAL + USE MPI ! *** DSLLC REAL,ALLOCATABLE,DIMENSION(:)::QINRCA @@ -63,7 +64,7 @@ C C ** WRITE I,J INDICES DEFINING FLOWS BETWEEN ARBITARY CELLS C ** (POSTIVE FLOW DIRECTION DEFINED FROM FIRST TO SECOND I,J PAIR) C - IF(IAUXICM.GE.1)THEN + IF(IAUXICM.GE.1.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='FLWMAP.INP',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='FLWMAP.INP',STATUS='UNKNOWN') @@ -111,6 +112,7 @@ C C C ** WRITE EXTERNAL INFLOW LOCATIONS C + IF(MYRANK.EQ.0)THEN OPEN(1,FILE='INFLOWIJ.DAT',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='INFLOWIJ.DAT',STATUS='UNKNOWN') @@ -213,9 +215,11 @@ C ENDIF CLOSE(1) IF(ISDICM.EQ.1) CLOSE(2) + ENDIF C C ** INITIALIZE OTHER FILES TO RECEIVE TIME VARYING DATA C + IF(MYRANK.EQ.0)THEN IF(IAUXICM.EQ.1)THEN OPEN(1,FILE='INFLOW.DAT',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') @@ -276,6 +280,7 @@ C WRITE(1,2006) WRITE(1,2007) CLOSE(1) + ENDIF JSWASP=0 RETURN 1000 CONTINUE @@ -294,6 +299,7 @@ C C C ** WRITE TIME AT END OF AVERAGING PERIOD TO EFDCICM.LOG C + IF(MYRANK.EQ.0)THEN OPEN(1,FILE='EFDCICM.LOG',STATUS='UNKNOWN',POSITION='APPEND') WRITE(1,106)TIME WRITE(1,2008) @@ -543,7 +549,7 @@ C LM=L-1 WRITE(14,402)LM,L,TVAR3C(L) ENDDO - 222 FORMAT(' ERROR ',2I5,6F12.2) +C 222 FORMAT(' ERROR ',2I5,6F12.2) 401 FORMAT(/,' LICM L QSUMLPF(L,K) K=1,KC',/) 402 FORMAT(2I6,12E13.5) 2294 FORMAT(2I6,4F12.5) @@ -722,39 +728,40 @@ C CLOSE(2) ENDIF ENDIF + ENDIF 100 FORMAT(120X) 101 FORMAT(4I10) 102 FORMAT(/,' NROW,NCOL,NLAYR = ',3I10/) 103 FORMAT(/,' NO INTERNAL FLOWS, NINTFL (LINES) IN FLWMAP.INP = ', & I10/) 104 FORMAT(/,' ROW, COLUMN INDICES OF DUMP CELL = ',2I10/) - 105 FORMAT(/,' SIMULATION STARTING TIME IN DAYS = ',F12.6/) +C 105 FORMAT(/,' SIMULATION STARTING TIME IN DAYS = ',F12.6/) 106 FORMAT(/,' TIME IN DAYS AT END OF AVERAGING PERIOD = ',F12.6/) 110 FORMAT(' LOCATION OF INFLOWS ',/) 111 FORMAT(' INFLOW # ROW INDEX COLUMN INDEX ',/) 112 FORMAT(2X,I5,7X,I5,7X,I5) 120 FORMAT(F12.6,13F12.4) 200 FORMAT(3I5,6E14.6) - 201 FORMAT(' L,I(ROW),J(COL),QX(I,J,K),K=1,KC ',/) - 202 FORMAT(' L,I(ROW),J(COL),QY(I,J,K),K=1,KC ',/) - 203 FORMAT(' L,I(ROW),J(COL),QZ(I,J,K),K=1,KS ',/) - 204 FORMAT(' L,I(ROW),J(COL),AX(I,J,K),K=1,KC ',/) - 205 FORMAT(' L,I(ROW),J(COL),AY(I,J,K),K=1,KC ',/) - 206 FORMAT(' L,I(ROW),J(COL),AZ(I,J,K),K=1,KS ',/) - 207 FORMAT(' L,I(ROW),J(COL),SELS(I,J),SELE(I,J),DSEL(I,J) ',/) - 208 FORMAT(' L,I(ROW),J(COL),SAL(I,J,K),K=1,KC ',/) - 209 FORMAT(' L,I(ROW),J(COL),TEM(I,J,K),K=1,KC ',/) - 210 FORMAT(//) +C 201 FORMAT(' L,I(ROW),J(COL),QX(I,J,K),K=1,KC ',/) +C 202 FORMAT(' L,I(ROW),J(COL),QY(I,J,K),K=1,KC ',/) +C 203 FORMAT(' L,I(ROW),J(COL),QZ(I,J,K),K=1,KS ',/) +C 204 FORMAT(' L,I(ROW),J(COL),AX(I,J,K),K=1,KC ',/) +C 205 FORMAT(' L,I(ROW),J(COL),AY(I,J,K),K=1,KC ',/) +C 206 FORMAT(' L,I(ROW),J(COL),AZ(I,J,K),K=1,KS ',/) +C 207 FORMAT(' L,I(ROW),J(COL),SELS(I,J),SELE(I,J),DSEL(I,J) ',/) +C 208 FORMAT(' L,I(ROW),J(COL),SAL(I,J,K),K=1,KC ',/) +C 209 FORMAT(' L,I(ROW),J(COL),TEM(I,J,K),K=1,KC ',/) +C 210 FORMAT(//) 211 FORMAT(I5,2X,6E15.6) 212 FORMAT(' L,I(ROW),J(ROW),RAINLPF(I,J),EVPSLPF(I,J),EVPGLPF(I,J), & RINFLPF(I,J),GWLPF(I,J) ',/) 213 FORMAT(' NQINTFL,QINTFL ',/) - 215 FORMAT(' L,I(ROW),J(COL),SURFELV START AVG INTERVAL',/) - 216 FORMAT(' L,I(ROW),J(COL),DEL SURFELV OVER INTERVAL',/) - 291 FORMAT(I8,F8.4) - 292 FORMAT(I8,E13.5) +C 215 FORMAT(' L,I(ROW),J(COL),SURFELV START AVG INTERVAL',/) +C 216 FORMAT(' L,I(ROW),J(COL),DEL SURFELV OVER INTERVAL',/) +C 291 FORMAT(I8,F8.4) +C 292 FORMAT(I8,E13.5) 293 FORMAT(I8,E13.5,3I8) - 294 FORMAT(I8,E13.5,E13.5,3I8) +C 294 FORMAT(I8,E13.5,E13.5,3I8) 2001 FORMAT(/,' TIME AT ICM INTERFACE INITIALIZATION = ',F12.4,/) 2002 FORMAT(/,' SIGMA LAYER FRACTIONAL THICKNESS: KICM, DZ, KEFDC',/) 2003 FORMAT(/,' HORIZONTAL CELL SURFACE AREAS, TOP LAYER : LICM, AREA' diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CGATEFLX.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CGATEFLX.for index f0794c37d..9fabc0b94 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CGATEFLX.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CGATEFLX.for @@ -7,6 +7,7 @@ C ** SUBROUTINE CGATEFLX C GATE CONTROL FLUX C USE GLOBAL + USE MPI implicit none integer:: I,K, LG, NCMP, NCTL, NS integer :: id, iu, jd, ju, ld, ldu, lu @@ -28,7 +29,14 @@ C REAL GQT(NQCTLM),LUA(NQCTLM),LDA(NQCTLM) REAL CG10 REAL CQ(LCM),CV(LCM) ! GEOSR UNG 2014.11.12 Warning message writing - CHARACTER*80 CTLE1 + CHARACTER*256 FMTSTR + M1=0 + NGATET=0 + GQPLO=0.0 + GQPHI=0.0 + GQ1=0.0 + GLOLEV=0.0 + GHILEV=0.0 ! open time control : jgcho 2010.8.17 temporary ! IF (N.EQ.1) GATEOTM=1.0 ! GTIMENOW=TIMEDAY !N*DT/86400. @@ -61,29 +69,30 @@ C IF (ISINK.EQ.1) THEN ! READY SINK#.OUT FSINK='SINK.OUT' + !IF(MYRANK.EQ.0.AND.DEBUG)THEN + IF(MYRANK.EQ.0)THEN OPEN(711,FILE=TRIM(FSINK),STATUS='UNKNOWN') ! OPEN OLD FILE CLOSE(711,STATUS='DELETE') ! DELETE OLD FILE OPEN(711,FILE=FSINK,STATUS='UNKNOWN') ! OPEN NEW FILE - WRITE(711,7101) - 7101 FORMAT(' N TIME ' - & ,('ID HUP HDW DIF Q',<8*(KC-1)+5>X - & ,20X)) + WRITE(FMTSTR, '("( N TIME ,",I0,"(ID HUP HDW + *DIF Q,",I0,"X,20X))" )') NQCTL, 8*(KC-1)+5 CLOSE(711) OPEN(712,FILE='SINKT.OUT',STATUS='UNKNOWN') ! OPEN OLD FILE CLOSE(712,STATUS='DELETE') ! DELETE OLD FILE OPEN(712,FILE='SINKT.OUT',STATUS='UNKNOWN') ! OPEN NEW FILE - WRITE(712,7102) ' N TIME',(NS,NS=1,NQCTL) - 7102 FORMAT(A,I8) + WRITE(FMTSTR, '("(A,",I0,"I8)")') NQCTL + WRITE(712,FMTSTR) ' N TIME',(NS,NS=1,NQCTL) ! GEOSR GATE: SINK2 OPEN(713,FILE='SINK2.OUT',STATUS='UNKNOWN') ! OPEN OLD FILE CLOSE(713,STATUS='DELETE') ! DELETE OLD FILE OPEN(713,FILE='SINK2.OUT',STATUS='UNKNOWN') ! OPEN NEW FILE - write(713,7103) ' N TIME', + write(FMTSTR, '("(A,",I0,"(3x,i2.2,a,i2.2))")') 1000 + write(713,FMTSTR) ' N TIME', & ((NS,'_K',k,k=1,KC),NS,'_O',00,NS=1,NQCTL) - 7103 FORMAT(A,<1000>(3x,i2.2,a,i2.2)) - +!} GEOSR GATE : jgcho 2016.07.14 + ENDIF ISINK=2 ! READY TO WRITE SINK##.OUT SNKW=DTSNK*60./DT ! WRITING TIME INTERVAL @@ -1446,12 +1455,15 @@ C IF (ISINK.EQ.2) THEN IF (MOD(FLOAT(N),SNKW).EQ.0. .OR. DTSNK.EQ.-1.) THEN C + IF(MYRANK.EQ.0)THEN FSINK='SINK.OUT' OPEN(711,FILE=TRIM(FSINK),POSITION='APPEND') - WRITE(711,7110) N,TIMEDAY,(IGCHECK(NS),HUPG(NS),HDWG(NS) + WRITE(FMTSTR, + & '("(I8,F10.4,",I0,"(I4,3F8.2,",I0,"F8.2,F20.1))")') + & NQCTL, KC + WRITE(711,FMTSTR) N,TIMEDAY,(IGCHECK(NS),HUPG(NS),HDWG(NS) & ,DELHG(NS),(QCTLT(K,NS),K=1,KC),GGQSUM(NS) & ,NS=1,NQCTL) !,(GGQSUM(NS),NS=1,NQCTL) - 7110 FORMAT(I8,F10.4,(I4,3F8.2,F8.2,F20.1)) CLOSE(711) C OPEN(712,FILE='SINKT.OUT',POSITION='APPEND') ! OPEN NEW FILE @@ -1460,17 +1472,18 @@ C GQT(NS)=GQT(NS)+QCTLT(K,NS) ENDDO ENDDO - WRITE(712,7120) N,TIMEDAY,(GQT(NS),NS=1,NQCTL) - 7120 FORMAT(I8,F10.4,F8.2) + WRITE(FMTSTR, '("(I8,F10.4,",I0,"F8.2)")') NQCTL + WRITE(712,FMTSTR) N,TIMEDAY,(GQT(NS),NS=1,NQCTL) ! GEOSR GATE: write sink2.out OPEN(713,FILE='SINK2.OUT',POSITION='APPEND') - WRITE(713,7130) N,TIMEDAY,((QCTLT(K,NS),K=1,KC-1) + WRITE(FMTSTR, '("(I8,F10.5,",I0,"(",I0,"F9.2))")') NQCTL, KC+1 + WRITE(713,FMTSTR) N,TIMEDAY,((QCTLT(K,NS),K=1,KC-1) & ,QCTLT(KC,NS)-DUMPG2(NS),DUMPG2(NS) & ,NS=1,NQCTL) - 7130 FORMAT(I8,F10.5,(F9.2)) CLOSE(713) + ENDIF ENDIF ! IF (MOD(FLOAT(N),SNKW).EQ.0.) THEN ENDIF ! IF (ISINK.EQ.2) THEN ! END: WRITE SINK.OUT diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CGATEFLX.patch b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CGATEFLX.patch deleted file mode 100644 index 068ceb834..000000000 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CGATEFLX.patch +++ /dev/null @@ -1,74 +0,0 @@ ---- model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CGATEFLX.for (revision 682) -+++ model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CGATEFLX.for (working copy) -@@ -46,25 +46,25 @@ - OPEN(711,FILE=TRIM(FSINK),STATUS='UNKNOWN') ! OPEN OLD FILE - CLOSE(711,STATUS='DELETE') ! DELETE OLD FILE - OPEN(711,FILE=FSINK,STATUS='UNKNOWN') ! OPEN NEW FILE -- WRITE(711,7101) -- 7101 FORMAT(' N TIME ' -- & ,('ID HUP HDW DIF Q',<8*(KC-1)+5>X -- & ,20X)) -+c WRITE(711,7101) -+c 7101 FORMAT(' N TIME ' -+c & ,('ID HUP HDW DIF Q',<8*(KC-1)+5>X -+c & ,20X)) - CLOSE(711) - - OPEN(712,FILE='SINKT.OUT',STATUS='UNKNOWN') ! OPEN OLD FILE - CLOSE(712,STATUS='DELETE') ! DELETE OLD FILE - OPEN(712,FILE='SINKT.OUT',STATUS='UNKNOWN') ! OPEN NEW FILE -- WRITE(712,7102) ' N TIME',(NS,NS=1,NQCTL) -- 7102 FORMAT(A,I8) -+c WRITE(712,7102) ' N TIME',(NS,NS=1,NQCTL) -+c 7102 FORMAT(A,I8) - - ! GEOSR GATE: SINK2 - OPEN(713,FILE='SINK2.OUT',STATUS='UNKNOWN') ! OPEN OLD FILE - CLOSE(713,STATUS='DELETE') ! DELETE OLD FILE - OPEN(713,FILE='SINK2.OUT',STATUS='UNKNOWN') ! OPEN NEW FILE -- write(713,7103) ' N TIME', -- & ((NS,'_K',k,k=1,KC),NS,'_O',00,NS=1,NQCTL) -- 7103 FORMAT(A,<1000>(3x,i2.2,a,i2.2)) -+c write(713,7103) ' N TIME', -+c & ((NS,'_K',k,k=1,KC),NS,'_O',00,NS=1,NQCTL) -+c 7103 FORMAT(A,<1000>(3x,i2.2,a,i2.2)) - - - ISINK=2 ! READY TO WRITE SINK##.OUT -@@ -1432,10 +1432,10 @@ - C - FSINK='SINK.OUT' - OPEN(711,FILE=TRIM(FSINK),POSITION='APPEND') -- WRITE(711,7110) N,TIMEDAY,(IGCHECK(NS),HUPG(NS),HDWG(NS) -- & ,DELHG(NS),(QCTLT(K,NS),K=1,KC),GGQSUM(NS) -- & ,NS=1,NQCTL) !,(GGQSUM(NS),NS=1,NQCTL) -- 7110 FORMAT(I8,F10.4,(I4,3F8.2,F8.2,F20.1)) -+c WRITE(711,7110) N,TIMEDAY,(IGCHECK(NS),HUPG(NS),HDWG(NS) -+c & ,DELHG(NS),(QCTLT(K,NS),K=1,KC),GGQSUM(NS) -+c & ,NS=1,NQCTL) !,(GGQSUM(NS),NS=1,NQCTL) -+c 7110 FORMAT(I8,F10.4,(I4,3F8.2,F8.2,F20.1)) - CLOSE(711) - C - OPEN(712,FILE='SINKT.OUT',POSITION='APPEND') ! OPEN NEW FILE -@@ -1444,15 +1444,15 @@ - GQT(NS)=GQT(NS)+QCTLT(K,NS) - ENDDO - ENDDO -- WRITE(712,7120) N,TIMEDAY,(GQT(NS),NS=1,NQCTL) -- 7120 FORMAT(I8,F10.4,F8.2) -+c WRITE(712,7120) N,TIMEDAY,(GQT(NS),NS=1,NQCTL) -+c 7120 FORMAT(I8,F10.4,F8.2) - - ! GEOSR GATE: write sink2.out - OPEN(713,FILE='SINK2.OUT',POSITION='APPEND') -- WRITE(713,7130) N,TIMEDAY,((QCTLT(K,NS),K=1,KC-1) -- & ,QCTLT(KC,NS)-DUMPG2(NS),DUMPG2(NS) -- & ,NS=1,NQCTL) -- 7130 FORMAT(I8,F10.5,(F9.2)) -+c WRITE(713,7130) N,TIMEDAY,((QCTLT(K,NS),K=1,KC-1) -+c & ,QCTLT(KC,NS)-DUMPG2(NS),DUMPG2(NS) -+c & ,NS=1,NQCTL) -+c 7130 FORMAT(I8,F10.5,(F9.2)) - CLOSE(713) - - ENDIF ! IF (MOD(FLOAT(N),SNKW).EQ.0.) THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRAD.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRAD.for index 2590c450c..f91361f96 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRAD.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRAD.for @@ -6,91 +6,71 @@ C ** GRADIENT SCHEME C USE GLOBAL - REAL TTMP, SECNDS + REAL TTMP,T1TMP ! *** DSLLC + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PNORTH + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PSOUTH REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TMPCG - IF(.NOT.ALLOCATED(TMPCG))THEN + IF(.NOT.ALLOCATED(PNORTH))THEN + ALLOCATE(PNORTH(LCM)) + ALLOCATE(PSOUTH(LCM)) ALLOCATE(TMPCG(LCM)) + PNORTH=0.0 + PSOUTH=0.0 TMPCG=0.0 ENDIF ! *** DSLLC C - TTMP=SECNDS(0.0) - RPCG=0. -!$OMP PARALLEL DO PRIVATE(LF,LL) REDUCTION(+:RPCG) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL - RCG(L)=FPTMP(L)-CCC(L)*P(L) - & -CCN(L)*P(LNC(L))-CCS(L)*P(LSC(L)) + CALL CPU_TIME(TTMP) + DO L=2,LA + PNORTH(L)=P(LNC(L)) + PSOUTH(L)=P(LSC(L)) + ENDDO + DO L=2,LA + RCG(L)=FPTMP(L)-CCC(L)*P(L)-CCN(L)*PNORTH(L)-CCS(L)*PSOUTH(L) & -CCW(L)*P(L-1)-CCE(L)*P(L+1) + ENDDO + DO L=2,LA PCG(L)=RCG(L)*CCCI(L) + ENDDO + RPCG=0.0 + DO L=2,LA RPCG=RPCG+RCG(L)*PCG(L) ENDDO - -c - enddo - IF(RPCG.EQ.0.0)RETURN ! *** DSLLC SINGLE LINE ITER=0 100 CONTINUE ITER=ITER+1 - PAPCG=0. -!$OMP PARALLEL DO PRIVATE(LF,LL) REDUCTION(+:PAPCG) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL - APCG(L)=CCC(L)*PCG(L) - & +CCS(L)*PCG(LSC(L))+CCN(L)*PCG(LNC(L)) + DO L=2,LA + PNORTH(L)=PCG(LNC(L)) + PSOUTH(L)=PCG(LSC(L)) + ENDDO + DO L=2,LA + APCG(L)=CCC(L)*PCG(L)+CCS(L)*PSOUTH(L)+CCN(L)*PNORTH(L) & +CCW(L)*PCG(L-1)+CCE(L)*PCG(L+1) + ENDDO + PAPCG=0.0 + DO L=2,LA PAPCG=PAPCG+APCG(L)*PCG(L) ENDDO - -c - enddo - -c t01=rtc() ALPHA=RPCG/PAPCG - - RPCGN=0. - RSQ=0. -!$OMP PARALLEL DO PRIVATE(LF,LL) REDUCTION(+:RPCGN,RSQ) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA P(L)=P(L)+ALPHA*PCG(L) + ENDDO + DO L=2,LA RCG(L)=RCG(L)-ALPHA*APCG(L) + ENDDO + DO L=2,LA TMPCG(L)=CCCI(L)*RCG(L) + ENDDO + RPCGN=0. + RSQ=0. + DO L=2,LA RPCGN=RPCGN+RCG(L)*TMPCG(L) RSQ=RSQ+RCG(L)*RCG(L) ENDDO -c - enddo - - IF(RSQ .LE. RSQM) GOTO 200 - IF(ITER .LT. ITERM)THEN - BETA=RPCGN/RPCG - RPCG=RPCGN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL - PCG(L)=TMPCG(L)+BETA*PCG(L) - ENDDO -c - enddo - GOTO 100 - ENDIF IF(ITER .GE. ITERM)THEN WRITE(6,600) C @@ -110,6 +90,12 @@ C CLOSE(8) STOP ENDIF + BETA=RPCGN/RPCG + RPCG=RPCGN + DO L=2,LA + PCG(L)=TMPCG(L)+BETA*PCG(L) + ENDDO + GOTO 100 600 FORMAT(' MAXIMUM ITERATIONS EXCEEDED IN EXTERNAL SOLUTION') C C ** CALCULATE FINAL RESIDUAL @@ -117,26 +103,26 @@ C 200 CONTINUE ! *** DSLLC BEGIN BLOCK IF(ISLOG.GE.1)THEN + DO L=2,LA + PNORTH(L)=P(LNC(L)) + PSOUTH(L)=P(LSC(L)) + ENDDO RSQ=0. -!$OMP PARALLEL DO PRIVATE(LF,LL) REDUCTION(+:RSQ) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL - RCG(L)=CCC(L)*P(L) - & +CCS(L)*P(LSC(L))+CCN(L)*P(LNC(L)) + DO L=2,LA + RCG(L)=CCC(L)*P(L)+CCS(L)*PSOUTH(L)+CCN(L)*PNORTH(L) & +CCW(L)*P(L-1)+CCE(L)*P(L+1)-FPTMP(L) + ENDDO + DO L=2,LA RCG(L)=RCG(L)*CCCI(L) + ENDDO + DO L=2,LA RSQ=RSQ+RCG(L)*RCG(L) ENDDO -c - enddo - ENDIF ! *** DSLLC END BLOCK - TCONG=TCONG+SECNDS(TTMP) - 800 FORMAT(I5,8E13.4) + CALL CPU_TIME(T1TMP) + TCONG=TCONG+T1TMP-TTMP +C 800 FORMAT(I5,8E13.4) 808 FORMAT(2I5,9E13.4) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRADC.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRADC.for index e3accd3d3..b205f85a3 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRADC.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRADC.for @@ -6,7 +6,7 @@ C ** GRADIENT SCHEME C USE GLOBAL - REAL TTMP, SECNDS + REAL TTMP, T1TMP ! *** DSLLC REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PNORTH @@ -22,7 +22,7 @@ C ENDIF ! *** DSLLC C - TTMP=SECNDS(0.0) + CALL CPU_TIME(TTMP) DO L=2,LA PNORTH(L)=P(LNC(L)) PSOUTH(L)=P(LSC(L)) @@ -173,7 +173,8 @@ C ENDDO ENDIF ! *** DSLLC END BLOCK - TCONG=TCONG+SECNDS(TTMP) + CALL CPU_TIME(T1TMP) + TCONG=TCONG+T1TMP-TTMP 800 FORMAT(2I6,6E13.4) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRAD_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRAD_mpi.for new file mode 100644 index 000000000..37def4a86 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CONGRAD_mpi.for @@ -0,0 +1,226 @@ + SUBROUTINE CONGRAD_mpi (ISTL_) +C +C CHANGE RECORD +C ** SUBROUTINE CONGRAD SOLVES THE EXTERNAL MODE BY A CONJUGATE +C ** GRADIENT SCHEME +C + USE GLOBAL + USE MPI + + ! *** DSLLC + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PNORTH + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PSOUTH + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TMPCG + REAL*8 :: RPC8G,PAPC8G,RPCG8N,ALPH8A,BET8A,RS8Q +! REAL*8 :: RPCG,PAPCG,RPCGN,RS8Q,ALPHA,BETA + IF(.NOT.ALLOCATED(PNORTH))THEN + ALLOCATE(PNORTH(LCM)) + ALLOCATE(PSOUTH(LCM)) + ALLOCATE(TMPCG(LCM)) + PNORTH=0.0 + PSOUTH=0.0 + TMPCG =0.0 + ENDIF + ! *** DSLLC +C +C CALL CPU_TIME(TTMP) +C + CALL broadcast_boundary(P,ic) + S2TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + PNORTH(L)=P(LNC(L)) + PSOUTH(L)=P(LSC(L)) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + RCG(L)=FPTMP(L)-CCC(L)*P(L)-CCN(L)*PNORTH(L)-CCS(L)*PSOUTH(L) + & -CCW(L)*P(L-1)-CCE(L)*P(L+1) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + PCG(L)=RCG(L)*CCCI(L) + ENDDO + CALL broadcast_boundary(PCG,ic) + RPC8G=0. +! RPCG =0. +C!$OMP PARALLEL DO REDUCTION(+:RPCG) + DO L=LMPI2,LMPILA + RPC8G=RPC8G+RCG(L)*PCG(L) +! RPCG =RPCG +RCG(L)*PCG(L) + ENDDO + CALL MPI_ALLREDUCE(RPC8G,MPI_R8,1,MPI_DOUBLE, + & MPI_SUM,MPI_COMM_WORLD,IERR) + RPC8G=MPI_R8 +! CALL MPI_ALLREDUCE(RPCG,MPI_R4,1,MPI_REAL, +! & MPI_SUM,MPI_COMM_WORLD,IERR) +! RPCG=MPI_R4 + MPI_WTIMES(242)=MPI_WTIMES(242)+MPI_TOC(S2TIME) +! PRINT*, '1',sum(abs(dble(RCG))),sum(abs(dble(PCG))),RPC8G + IF(RPC8G.EQ.0.0)RETURN ! *** DSLLC SINGLE LINE + ITER=0 + 100 CONTINUE + ITER=ITER+1 + S2TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + PNORTH(L)=PCG(LNC(L)) + PSOUTH(L)=PCG(LSC(L)) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + APCG(L)=CCC(L)*PCG(L)+CCS(L)*PSOUTH(L)+CCN(L)*PNORTH(L) + & +CCW(L)*PCG(L-1)+CCE(L)*PCG(L+1) + ENDDO + MPI_WTIMES(243)=MPI_WTIMES(243)+MPI_TOC(S2TIME) + PAPC8G=0. +! PAPCG =0. + S2TIME=MPI_TIC() +C!$OMP PARALLEL DO REDUCTION(+:PAPCG) + DO L=LMPI2,LMPILA + PAPC8G=PAPC8G+APCG(L)*PCG(L) +! PAPCG =PAPCG +APCG(L)*PCG(L) + ENDDO + CALL MPI_ALLREDUCE(PAPC8G,MPI_R8,1,MPI_DOUBLE, + & MPI_SUM,MPI_COMM_WORLD,IERR) + PAPC8G=MPI_R8 +! CALL MPI_ALLREDUCE(PAPCG,MPI_R4,1,MPI_REAL, +! & MPI_SUM,MPI_COMM_WORLD,IERR) +! PAPCG=MPI_R4 + ALPH8A=(RPC8G)/(PAPC8G) +! ALPHA =RPCG/PAPCG +! PRINT*, '2',iter,sum(abs(dble(APCG))),sum(abs(dble(PCG))),PAPC8G, +! & RPC8G,ALPH8A +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + P(L)=REAL(P(L)+(ALPH8A)*PCG(L),KIND(P)) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + RCG(L)=REAL(RCG(L)-(ALPH8A)*APCG(L),KIND(RCG)) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TMPCG(L)=CCCI(L)*RCG(L) + ENDDO + MPI_WTIMES(244)=MPI_WTIMES(244)+MPI_TOC(S2TIME) + RPCG8N=0. + RS8Q =0. +! RPCGN =0. +! RSQ =0. + S2TIME=MPI_TIC() +C!$OMP PARALLEL DO REDUCTION(+:RPCGN,RS8Q) + DO L=LMPI2,LMPILA + RPCG8N=RPCG8N+RCG(L)*TMPCG(L) + RS8Q =RS8Q +RCG(L)*RCG(L) +! RPCGN =RPCGN +RCG(L)*TMPCG(L) +! RSQ =RSQ +RCG(L)*RCG(L) + ENDDO + CALL MPI_ALLREDUCE(RPCG8N,MPI_R8,1,MPI_DOUBLE, + & MPI_SUM,MPI_COMM_WORLD,IERR) + RPCG8N=MPI_R8 + CALL MPI_ALLREDUCE(RS8Q,MPI_R8,1,MPI_DOUBLE, + & MPI_SUM,MPI_COMM_WORLD,IERR) + RS8Q=MPI_R8 +! CALL MPI_ALLREDUCE(RPCGN,MPI_R4,1,MPI_REAL, +! & MPI_SUM,MPI_COMM_WORLD,IERR) +! RPCGN=MPI_R4 +! CALL MPI_ALLREDUCE(RSQ,MPI_R4,1,MPI_REAL, +! & MPI_SUM,MPI_COMM_WORLD,IERR) +! RSQ=MPI_R4 +c IF(MYRANK.EQ.0) PRINT*,RPCG8N,RS8Q,RPCGN,RSQ + MPI_WTIMES(245)=MPI_WTIMES(245)+MPI_TOC(S2TIME) +! PRINT*, '3',iter,sum(abs(dble(APCG))),sum(abs(dble(P))),RPCG8N +! PRINT*, '4',iter,sum(abs(dble(RCG))),sum(abs(dble(TMPCG))),RS8Q + IF(RS8Q.LE.RSQM) GOTO 200 + IF(ITER.GE.ITERM.AND.MYRANK.EQ.0)THEN + WRITE(6,600) +C +C *** PMC BEGIN BLOCK +C + WRITE(8,*)' I J CCS CCW CCC + & CCE CCN CDIADOM FPTMP HU + & HV' +C +C *** PMC END BLOCK +C + DO L=1,LC + CDIADOM=CCC(L)+CCE(L)+CCN(L)+CCS(L)+CCW(L) + WRITE(8,808)IL(L),JL(L),CCS(L),CCW(L),CCC(L),CCE(L),CCN(L), + & CDIADOM,FPTMP(L),HU(L),HV(L) + END DO + CLOSE(8) + STOP + ENDIF + BET8A =(RPCG8N)/(RPC8G) +! BETA =RPCGN/RPCG + +! CALL MPI_BARRIER(MPI_COMM_WORLD,IERR); STOP + + RPC8G=RPCG8N +! RPCG =RPCGN + S2TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + PCG(L)=REAL(TMPCG(L)+(BET8A)*PCG(L),KIND(PCG)) + ENDDO + CALL broadcast_boundary(PCG,ic) + MPI_WTIMES(246)=MPI_WTIMES(246)+MPI_TOC(S2TIME) + GOTO 100 + 600 FORMAT(' MAXIMUM ITERATIONS EXCEEDED IN EXTERNAL SOLUTION') +C +C ** CALCULATE FINAL RESIDUAL +C + 200 CONTINUE + ! *** DSLLC BEGIN BLOCK + S2TIME=MPI_TIC() + CALL broadcast_boundary(P,ic) + IF(ISLOG.GE.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + PNORTH(L)=P(LNC(L)) + PSOUTH(L)=P(LSC(L)) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + RCG(L)=CCC(L)*P(L)+CCS(L)*PSOUTH(L)+CCN(L)*PNORTH(L) + & +CCW(L)*P(L-1)+CCE(L)*P(L+1)-FPTMP(L) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + RCG(L)=RCG(L)*CCCI(L) + ENDDO + RS8Q=0. +! RSQ =0. +C!$OMP PARALLEL DO REDUCTION(+:RQG) + DO L=LMPI2,LMPILA + RS8Q=RS8Q+RCG(L)*RCG(L) +! RSQ =RSQ+RCG(L)*RCG(L) + ENDDO + CALL MPI_ALLREDUCE(RS8Q,MPI_R8,1,MPI_DOUBLE, + & MPI_SUM,MPI_COMM_WORLD,IERR) + RS8Q=MPI_R8 +! CALL MPI_ALLREDUCE(RSQ,MPI_R4,1,MPI_REAL, +! & MPI_SUM,MPI_COMM_WORLD,IERR) +! RSQ=MPI_R4 + ENDIF + MPI_WTIMES(247)=MPI_WTIMES(247)+MPI_TOC(S2TIME) + ! *** DSLLC END BLOCK +C TCONG=TCONG+TTMP-SECOND() +C 800 FORMAT(I5,8E13.4) + 808 FORMAT(2I5,9E13.4) + CALL broadcast_boundary(P,ic) + + IF(PRINT_SUM)THEN + call collect_in_zero(P) + call collect_in_zero(RCG) + call collect_in_zero(PCG) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'P = ', sum(abs(dble(P))) + PRINT*, n,'RCG = ', sum(abs(dble(RCG))) + PRINT*, n,'PCG = ', sum(abs(dble(PCG))) + ENDIF + ENDIF + + RETURN + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/COSTRAN.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/COSTRAN.for index 1184e165c..71fb7cf2e 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/COSTRAN.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/COSTRAN.for @@ -10,6 +10,8 @@ C USE GLOBAL C DIMENSION CON(LCM,KCM),CON1(LCM,KCM) + REAL CTMP + REAL RDZIC C !*** DSLLC BEGIN REAL,ALLOCATABLE,DIMENSION(:,:)::CONCX @@ -29,9 +31,11 @@ C REAL,ALLOCATABLE,DIMENSION(:,:)::DELCX REAL,ALLOCATABLE,DIMENSION(:,:)::DELCY REAL,ALLOCATABLE,DIMENSION(:,:)::DELCZ - REAL,ALLOCATABLE,DIMENSION(:,:)::FQCPAD - REAL,ALLOCATABLE,DIMENSION(:,:)::QSUMNAD - REAL,ALLOCATABLE,DIMENSION(:,:)::QSUMPAD +! REAL,ALLOCATABLE,DIMENSION(:,:)::FQCPAD +! REAL,ALLOCATABLE,DIMENSION(:,:)::QSUMNAD +! REAL,ALLOCATABLE,DIMENSION(:,:)::QSUMPAD + CTMP=0.0 + RDZIC=0.0 IF(.NOT.ALLOCATED(CONCX))THEN ALLOCATE(CONCX(LCM,KCM)) @@ -127,7 +131,7 @@ C C C ** CALCULATED EXTERNAL SOURCES AND SINKS C - CALL CALFQC (ISTL_,IS2TL_,MVAR,M,CON,CON1,FQCPAD,QSUMPAD,QSUMNAD) + CALL CALFQC (ISTL_,IS2TL_,MVAR,M,CON,CON1)!,FQCPAD,QSUMPAD,QSUMNAD) C C ** BEGIN COMBINED ADVECTION SCHEME C ** INTERMEDIATE ADVECTION CALCULATIONS @@ -501,7 +505,7 @@ C ENDIF ENDDO ENDDO - 6001 FORMAT('N,K,CBTS = ',2I10,F12.3) +C6001 FORMAT('N,K,CBTS = ',2I10,F12.3) DO K=1,KC DO LL=1,NCBW NSID=NCSERW(LL,M) @@ -610,7 +614,7 @@ C ENDIF ENDDO ENDDO - 6002 FORMAT('N,K,CBTN = ',2I10,F12.3) +C6002 FORMAT('N,K,CBTN = ',2I10,F12.3) C C ** MODIFIY VERTICAL MASS DIFFUSION IF ANTI-DIFFUSIVE ADVECTIVE C ** IS TURNED OFF diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/COSTRANW.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/COSTRANW.for index ac46abd1a..00e4d8652 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/COSTRANW.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/COSTRANW.for @@ -46,9 +46,15 @@ C REAL,ALLOCATABLE,DIMENSION(:,:)::DELCX REAL,ALLOCATABLE,DIMENSION(:,:)::DELCY REAL,ALLOCATABLE,DIMENSION(:,:)::DELCZ - REAL,ALLOCATABLE,DIMENSION(:,:)::FQCPAD - REAL,ALLOCATABLE,DIMENSION(:,:)::QSUMNAD - REAL,ALLOCATABLE,DIMENSION(:,:)::QSUMPAD +! REAL,ALLOCATABLE,DIMENSION(:,:)::FQCPAD +! REAL,ALLOCATABLE,DIMENSION(:,:)::QSUMNAD +! REAL,ALLOCATABLE,DIMENSION(:,:)::QSUMPAD + REAL CSTARP + REAL CSTARN + REAL CTMP + CSTARP=0.0 + CSTARN=0.0 + CTMP=0.0 IF(.NOT.ALLOCATED(CONCX))THEN ALLOCATE(CONCX(LCM,KCM)) @@ -160,7 +166,7 @@ C ** CALCULATED EXTERNAL SOURCES AND SINKS C C----------------------------------------------------------------------C C - CALL CALFQC (ISTL_,IS2TL_,MVAR,M,CON,CON1,FQCPAD,QSUMPAD,QSUMNAD) + CALL CALFQC (ISTL_,IS2TL_,MVAR,M,CON,CON1)!,FQCPAD,QSUMPAD,QSUMNAD) C IF(ISTRAN(M).EQ.1) CALL CALFQC (ISTL_,M,CON,CON1) C IF(ISTRAN(M).EQ.3) CALL CALFQC (ISTL_,M,CON,CON1) C IF(M.EQ.4)THEN @@ -514,7 +520,7 @@ C ENDDO ENDDO C - 1069 FORMAT(I8,10E13.5) +C1069 FORMAT(I8,10E13.5) C DO K=1,KS DO L=2,LA @@ -779,7 +785,7 @@ C ENDDO ENDDO C - 6001 FORMAT('N,K,CBTS = ',2I10,F12.3) +C6001 FORMAT('N,K,CBTS = ',2I10,F12.3) C C----------------------------------------------------------------------C C @@ -901,7 +907,7 @@ C ENDDO ENDDO C - 6002 FORMAT('N,K,CBTN = ',2I10,F12.3) +C6002 FORMAT('N,K,CBTN = ',2I10,F12.3) C C**********************************************************************C C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDRESS.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDRESS.for index 5e3aa9485..99a1dab42 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDRESS.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDRESS.for @@ -15,6 +15,7 @@ C ** C ** SANFORD, L.P., AND J. P. Y. MAA, 2001: A UNIFIED EROSION FORMULATI C ** FOR FINE SEDIMENT, MARINE GEOLOGY, 179, 9-23. C + CSEDRESS=0.0 IF(IOPT.EQ.1)THEN BULKDEN=0.001*DENBULK ! *** PMC IF(BULKDEN.LE.1.065)THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDSET.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDSET.for index 6b46efdda..2a9a2edb1 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDSET.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDSET.for @@ -7,6 +7,7 @@ C ** CALCULATES CONCENTRATION DEPENDENT SETTLING VELOCITY OF COHESIVE C ** SEDIMENT C *** DSLLC BEGIN BLOCK C + CSEDSET=0.0 IF(SED.LE.0.0001)THEN CSEDSET=0.0 RETURN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDVIS.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDVIS.for index 80a131ac5..031df9c2a 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDVIS.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSEDVIS.for @@ -10,6 +10,7 @@ C ** MEHTA, A. J., AND F.JIANG, 1990: SOME OBSERVATIONS ON BOTTOM C ** MUD MOTION DUE TO WAVES. COASTAL AND OCEANOGRAPHIC ENGINEERING C ** DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661 C + VISR=0.0 IF(SED.LE.25667.) VISR=0.116883E-3*SED IF(SED.GE.36667.) VISR=1.52646E-6*SED+3.125 IF(SED.GT.25667.0.AND.SED.LT.36667.0)THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSNDEQC.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSNDEQC.for index 675dea6ae..abf22aa36 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSNDEQC.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/CSNDEQC.for @@ -11,6 +11,7 @@ C ** C ** GARCIA, M., AND G. PARKER, 1991: ENTRAINMENT OF BED SEDIMENT C ** INTO SUSPENSION, J. HYDRAULIC ENGINEERING, 117, 414-435. C + CSNDEQC=0.0 IF(IOPT.EQ.1)THEN REY=1.E6*SNDDIA*SQRT( 9.8*(SSG-1.)*SNDDIA ) REY=REY**0.6 @@ -61,7 +62,7 @@ C USTAR=SQRT(TAUB) IF(USTAR.LT.WS) CSNDEQC=0. ENDIF - 600 FORMAT(10E12.4) +C 600 FORMAT(10E12.4) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DEPPLT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DEPPLT.for index d03bf2a81..8101c47c0 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DEPPLT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DEPPLT.for @@ -4,9 +4,11 @@ C ** SUBROUTINE DEPPLT WRITES A FILE TO CONTOUR PLOT DEPTH C CHANGE RECORD C USE GLOBAL + USE MPI CHARACTER*80 TITLE + IF(MYRANK.EQ.0)THEN OPEN(1,FILE='BELVCON.OUT',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='BELVCON.OUT',STATUS='UNKNOWN') @@ -23,9 +25,11 @@ C WRITE(1,200)IL(L),JL(L),DLON(L),DLAT(L),BELV(L) ENDDO CLOSE(1) + ENDIF + 99 FORMAT(A80) 100 FORMAT(I10) - 101 FORMAT(2I10) +C 101 FORMAT(2I10) 200 FORMAT(2I5,1X,2D12.6,F12.6) 250 FORMAT(12F10.6) RETURN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DRIFTER.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DRIFTER.f90 index 847350c4e..8a1778191 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DRIFTER.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DRIFTER.f90 @@ -28,8 +28,7 @@ SUBROUTINE DRIFTERC ! ******************************************************** REAL(RKD) ::KDY1,KDY2,KDY3,KDY4 REAL(RKD) ::KDZ1,KDZ2,KDZ3,KDZ4 REAL(RKD) ::U1NP,V1NP,W1NP,U2NP,V2NP,W2NP - REAL(RKD) ::ZSIG - REAL, SAVE::TIMENEXT, PMC + REAL, SAVE::TIMENEXT CHARACTER*80 TITLE,METHOD !{GEOSR, OIL, CWCHO, 101104 @@ -39,13 +38,17 @@ SUBROUTINE DRIFTERC ! ******************************************************** !{GEOSR, 2014.11.25 CWCHO, OIL WIND TRANSFER COEFF. INTEGER(4):: NA, M1, M2, MSAVE - REAL(RKD) ::TIME, TDIFF, TIME_PRE + REAL(RKD) ::TIME, TDIFF REAL(RKD) ::WTM1, WTM2, DEGM1, DEGM2 REAL(RKD) ::WINDS1, WINDS2, WINDE1, WINDE2, WINDN1, WINDN2 REAL(RKD) ::WINDEE, WINDNN, WINDSPD REAL(RKD) ::UWIND, VWIND !}GEOSR, 2014.11.25 CWCHO, OIL WIND TRANSFER COEFF. + WINDNN = 0.0_RKD + WINDEE = 0.0_RKD + DIFFVEL = 0.0_RKD + TITLE='PREDICTION OF TRAJECTORIES OF DRIFTERS' !{GEOSR, OIL, CWCHO, 101103 @@ -88,7 +91,7 @@ SUBROUTINE DRIFTERC ! ******************************************************** !FLUSH(ULGR) CALL FLUSH(ULGR) !ykchoi] - TIMENEXT=TIMEDAY+LA_FREQ+0.000001 + TIMENEXT=REAL(TIMEDAY+LA_FREQ+0.000001,KIND(TIMENEXT)) ENDIF !----NEXT CALL--------------------------- @@ -102,7 +105,7 @@ SUBROUTINE DRIFTERC ! ******************************************************** ALFA = (CFAY_2*CFAY_2/32.0)*(DELTARHO*G*OILVOLINI**2/sqrt(WKVISC))**(1./3.) IF(OSPD.EQ.1) THEN TRANSTIME = (CFAY_2/CFAY_1)**4 * (OILVOLINI/(G*DELTARHO*WKVISC))**(1./3.) - DIFFCOEF = ALFA*(1/SQRT(TRANSTIME)) + DIFFCOEF = REAL(ALFA*1/SQRT(TRANSTIME), KIND(DIFFCOEF)) ALFA_OLD = ALFA OSPD=0 ELSE @@ -312,7 +315,7 @@ SUBROUTINE DRIFTERC ! ******************************************************** !FLUSH(ULGR) CALL FLUSH(ULGR) !ykchoi] - TIMENEXT = TIMENEXT+LA_FREQ + TIMENEXT = REAL(TIMENEXT+LA_FREQ,KIND(TIMENEXT)) ENDIF END SUBROUTINE @@ -320,8 +323,8 @@ SUBROUTINE DRIFTERINP ! ****************************************************** !READING INPUT DATA OF INITIAL LOCATIONS OF DRIFTERS !OUTPUT: NPD,XLA,YLA,ZLA,NP=1:NPD ! LA_BEGTI, LA_ENDTI, LA_FREQ,LANDT - INTEGER(4)::NP,I,J,K - REAL(RKD) ::XC(4),YC(4),AREA2,RANVAL + INTEGER(4)::NP + REAL(RKD) ::RANVAL REAL(8),EXTERNAL::DRAND !IT NEEDS THIS STATEMENT IN CASE OF IMPLICIT NONE OPEN(ULOC,FILE='DRIFTER.INP',ACTION='READ') @@ -396,10 +399,10 @@ SUBROUTINE CONTAINER(XLA,YLA,ZLA,LLA,KLA,NP) !******************************** INTEGER(4),INTENT(IN),OPTIONAL::NP INTEGER(4),INTENT(INOUT)::LLA(:),KLA(:) REAL(RKD) ,INTENT(INOUT)::ZLA(:) - INTEGER(4)::IPD,NPSTAT,LLA1,LLA2,KLA1 + INTEGER(4)::NPSTAT,LLA1,LLA2 INTEGER(4)::NI,LMILOC(1),K,L,N1,N2,I,J,ILN,JLN - INTEGER(4)::I1,I2,J1,J2,ITER,IPMC,JPMC - REAL(RKD) ::RADLA(LA),ZSIG,SCALE + INTEGER(4)::I1,I2,J1,J2 + REAL(RKD) ::RADLA(LA),SCALE LOGICAL(4)::MASK1,MASK2,MASK3,MASK4 LOGICAL(4)::CMASK,CMASK1,CMASK2,CMASK3,CMASK4 LOGICAL(4)::CPOS1,CPOS2,CPOS3,CPOS4 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DUMP.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DUMP.for index cefc85250..2925fa320 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DUMP.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/DUMP.for @@ -5,6 +5,7 @@ C ** SUBROUTINE DUMP WRITES FULL FIELD DUMPS OF MODEL VARIABLES C ** AT SPECIFIED TIME INTERVALS C USE GLOBAL + USE MPI CHARACTER*1 CZTT(0:9) CHARACTER*1 CCHTMF,CCHTMS C @@ -21,6 +22,8 @@ C REAL,ALLOCATABLE,DIMENSION(:)::TXWMAX REAL,ALLOCATABLE,DIMENSION(:)::TXWMIN REAL,ALLOCATABLE,DIMENSION(:,:)::DMPVAL + REAL SCALE + SCALE=0.0 ALLOCATE(CNTTOX(NTXM)) ALLOCATE(DMPVAL(LCM-2,KCM)) ALLOCATE(DMPVALL(LCM-2)) @@ -164,7 +167,7 @@ C FNDTBP(NT)='TBP'// CNTTOX(NT) // 'DPF.BIN' ENDDO ENDIF - IF(ISADMP.EQ.0)THEN + IF(ISADMP.EQ.0.AND.MYRANK.EQ.0)THEN OPEN(1,FILE=FNDSEL) CLOSE(1,STATUS='DELETE') OPEN(1,FILE=FNDUUU) @@ -386,7 +389,7 @@ C C C ** WATER SURFACE ELEVATION C - IF(ISDMPP.GE.1)THEN + IF(ISDMPP.GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDSEL,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDSEL,POSITION='APPEND',FORM='UNFORMATTED') @@ -411,7 +414,7 @@ C C C ** U VELOCITY COMPONENT C - IF(ISDMPU.GE.1)THEN + IF(ISDMPU.GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDUUU,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDUUU,POSITION='APPEND',FORM='UNFORMATTED') @@ -441,7 +444,7 @@ C C C ** V VELOCITY COMPONENT C - IF(ISDMPU.GE.1)THEN + IF(ISDMPU.GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDVVV,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDVVV,POSITION='APPEND',FORM='UNFORMATTED') @@ -471,7 +474,7 @@ C C C ** W VELOCITY COMPONENT C - IF(ISDMPW.GE.1)THEN + IF(ISDMPW.GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDWWW,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDWWW,POSITION='APPEND',FORM='UNFORMATTED') @@ -501,7 +504,7 @@ C C C ** SALINITY C - IF(ISDMPT.GE.1.AND.ISTRAN(1).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(1).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDSAL,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDSAL,POSITION='APPEND',FORM='UNFORMATTED') @@ -530,7 +533,7 @@ C C C ** TEMPATURE C - IF(ISDMPT.GE.1.AND.ISTRAN(2).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(2).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDTEM,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDTEM,POSITION='APPEND',FORM='UNFORMATTED') @@ -559,7 +562,7 @@ C C C ** DYE C - IF(ISDMPT.GE.1.AND.ISTRAN(3).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(3).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDDYE,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDDYE,POSITION='APPEND',FORM='UNFORMATTED') @@ -588,7 +591,7 @@ C C C ** TOTAL COHESIVE SEDIMENT WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(6).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(6).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDSDW,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDSDW,POSITION='APPEND',FORM='UNFORMATTED') @@ -617,7 +620,7 @@ C C C ** TOTAL NONCOHESIVE SEDIMENT IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(7).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(7).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDSNW,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDSNW,POSITION='APPEND',FORM='UNFORMATTED') @@ -646,7 +649,7 @@ C C C ** TOTAL TOXIC CONTAMINANTS IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDTWT(NT),POSITION='APPEND') IF(ISDUMP.EQ.2) @@ -678,7 +681,7 @@ C C C ** FREE DISSOLVED TOXIC CONTAMINANTS IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDTWF(NT),POSITION='APPEND') IF(ISDUMP.EQ.2) @@ -710,7 +713,7 @@ C C C ** COMPLEXED DISSOLVED TOXIC CONTAMINANTS IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDTWC(NT),POSITION='APPEND') IF(ISDUMP.EQ.2) @@ -742,7 +745,7 @@ C C C ** PARTICULATE TOXIC CONTAMINANT IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDTWP(NT),POSITION='APPEND') IF(ISDUMP.EQ.2) @@ -777,7 +780,7 @@ C C C ** TOTAL COHESIVE SEDIMENT IN BED C - IF(ISDMPT.GE.1.AND.ISTRAN(6).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(6).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDSDB,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDSDB,POSITION='APPEND',FORM='UNFORMATTED') @@ -802,7 +805,7 @@ C C C ** TOTAL NONCOHESIVE SEDIMENT IN BED C - IF(ISDMPT.GE.1.AND.ISTRAN(7).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(7).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDSNB,POSITION='APPEND') IF(ISDUMP.EQ.2) & OPEN(1,FILE=FNDSNB,POSITION='APPEND',FORM='UNFORMATTED') @@ -827,7 +830,7 @@ C C C ** THICKNESS OF SEDIMENT BED C - IF(ISDMPT.GE.1)THEN + IF(ISDMPT.GE.1.AND.MYRANK.EQ.0)THEN IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDBDH,POSITION='APPEND') IF(ISDUMP.EQ.2) @@ -854,7 +857,7 @@ C C C ** TOTAL TOXIC CONTAMINANTS IN SEDIMENT BED C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDTBT(NT),POSITION='APPEND') IF(ISDUMP.EQ.2) @@ -882,7 +885,7 @@ C C C ** FREE DISSOLVED TOXIC CONTAMINANTS IN SEDIMENT BED C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDTBF(NT),POSITION='APPEND') IF(ISDUMP.EQ.2) @@ -910,7 +913,7 @@ C C C ** COMPLEXED DISSOLVED TOXIC CONTAMINANTS IN SEDIMENT BED C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDTBC(NT),POSITION='APPEND') IF(ISDUMP.EQ.2) @@ -938,7 +941,7 @@ C C C ** PARTICULATE TOXIC CONTAMINANT IN SEDIMENT BED C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.1) OPEN(1,FILE=FNDTBP(NT),POSITION='APPEND') IF(ISDUMP.EQ.2) @@ -975,7 +978,7 @@ C C C ** WATER SURFACE ELEVATION C - IF(ISDMPP.GE.1)THEN + IF(ISDMPP.GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDSEL,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDSEL,POSITION='APPEND',FORM='UNFORMATTED') @@ -995,7 +998,7 @@ C C C ** U VELOCITY COMPONENT C - IF(ISDMPU.GE.1)THEN + IF(ISDMPU.GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDUUU,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDUUU,POSITION='APPEND',FORM='UNFORMATTED') @@ -1025,7 +1028,7 @@ C C C ** V VELOCITY COMPONENT C - IF(ISDMPU.GE.1)THEN + IF(ISDMPU.GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDVVV,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDVVV,POSITION='APPEND',FORM='UNFORMATTED') @@ -1055,7 +1058,7 @@ C C C ** W VELOCITY COMPONENT C - IF(ISDMPW.GE.1)THEN + IF(ISDMPW.GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDWWW,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDWWW,POSITION='APPEND',FORM='UNFORMATTED') @@ -1085,7 +1088,7 @@ C C C ** SALINITY C - IF(ISDMPT.GE.1.AND.ISTRAN(1).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(1).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDSAL,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDSAL,POSITION='APPEND',FORM='UNFORMATTED') @@ -1109,7 +1112,7 @@ C C C ** TEMPERATURE C - IF(ISDMPT.GE.1.AND.ISTRAN(2).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(2).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDTEM,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDTEM,POSITION='APPEND',FORM='UNFORMATTED') @@ -1133,7 +1136,7 @@ C C C ** DYE C - IF(ISDMPT.GE.1.AND.ISTRAN(3).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(3).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDDYE,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDDYE,POSITION='APPEND',FORM='UNFORMATTED') @@ -1157,7 +1160,7 @@ C C C ** TOTAL COHESIVE SEDIMENT IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(6).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(6).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDSDW,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDSDW,POSITION='APPEND',FORM='UNFORMATTED') @@ -1181,7 +1184,7 @@ C C C ** TOTAL NONCOHESIVE SEDIMENT IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(7).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(7).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDSNW,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDSNW,POSITION='APPEND',FORM='UNFORMATTED') @@ -1205,7 +1208,7 @@ C C C ** TOTAL TOXIC CONTAMINANTS IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDTWT(NT),POSITION='APPEND') IF(ISDUMP.EQ.4) @@ -1232,7 +1235,7 @@ C C C ** FREE DISSOLVED TOXIC CONTAMINANTS IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDTWF(NT),POSITION='APPEND') IF(ISDUMP.EQ.4) @@ -1259,7 +1262,7 @@ C C C ** COMPLEXED DISSOLVED TOXIC CONTAMINANTS IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDTWC(NT),POSITION='APPEND') IF(ISDUMP.EQ.4) @@ -1286,7 +1289,7 @@ C C C ** PARTICULATE TOXIC CONTAMINANT IN WATER COLUMN C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDTWP(NT),POSITION='APPEND') IF(ISDUMP.EQ.4) @@ -1313,7 +1316,7 @@ C C C ** TOTAL COHESIVE SEDIMENT IN BED C - IF(ISDMPT.GE.1.AND.ISTRAN(6).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(6).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDSDB,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDSDB,POSITION='APPEND',FORM='UNFORMATTED') @@ -1335,7 +1338,7 @@ C C C ** TOTAL NONCOHESIVE SEDIMENT IN BED C - IF(ISDMPT.GE.1.AND.ISTRAN(7).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(7).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDSNB,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDSNB,POSITION='APPEND',FORM='UNFORMATTED') @@ -1358,7 +1361,7 @@ C C ** THICKNESS OF SEDIMENT BED C IF(ISDMPT.GE.1)THEN - IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN + IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1.AND.MYRANK.EQ.0)THEN IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDBDH,POSITION='APPEND') IF(ISDUMP.EQ.4) & OPEN(1,FILE=FNDBDH,POSITION='APPEND',FORM='UNFORMATTED') @@ -1381,7 +1384,7 @@ C C C ** TOTAL TOXIC CONTAMINANTS IN SEDIMENT BED C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDTBT(NT),POSITION='APPEND') IF(ISDUMP.EQ.4) @@ -1406,7 +1409,7 @@ C C C ** FREE DISSOLVED TOXIC CONTAMINANTS IN SEDIMENT BED C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDTBF(NT),POSITION='APPEND') IF(ISDUMP.EQ.4) @@ -1431,7 +1434,7 @@ C C C ** COMPLEXED DISSOLVED TOXIC CONTAMINANTS IN SEDIMENT BED C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDTBC(NT),POSITION='APPEND') IF(ISDUMP.EQ.4) @@ -1456,7 +1459,7 @@ C C C ** PARTICULATE TOXIC CONTAMINANT IN SEDIMENT BED C - IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1)THEN + IF(ISDMPT.GE.1.AND.ISTRAN(5).GE.1.AND.MYRANK.EQ.0)THEN DO NT=1,NTOX IF(ISDUMP.EQ.3) OPEN(1,FILE=FNDTBP(NT),POSITION='APPEND') IF(ISDUMP.EQ.4) @@ -1492,15 +1495,15 @@ C READ(1)TIME,SALMAX,SALMIN C READ(1)IB16VAL C TMPVAL=(SALMAX-SALMIN)/RSCALE C - 100 FORMAT(A80) +C 100 FORMAT(A80) 101 FORMAT(8I6) - 102 FORMAT(8I4) +C 102 FORMAT(8I4) 111 FORMAT(10E12.4) - 201 FORMAT(//,' CHECK 2D 8 BIT VARIABLE',/) - 202 FORMAT(//,' CHECK 3D 8 BIT VARIABLE',/) - 203 FORMAT(//,' CHECK 2D 16 BIT VARIABLE',/) - 204 FORMAT(//,' CHECK 3D 16 BIT VARIABLE',/) - 205 FORMAT(8F8.2) +C 201 FORMAT(//,' CHECK 2D 8 BIT VARIABLE',/) +C 202 FORMAT(//,' CHECK 3D 8 BIT VARIABLE',/) +C 203 FORMAT(//,' CHECK 2D 16 BIT VARIABLE',/) +C 204 FORMAT(//,' CHECK 3D 16 BIT VARIABLE',/) +C 205 FORMAT(8F8.2) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/EEXPOUT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/EEXPOUT.for index d8bffe664..5ca9d59ae 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/EEXPOUT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/EEXPOUT.for @@ -28,6 +28,8 @@ INTEGER NP1 INTEGER COUNTCELL(LA) + LOGICAL FILE_EXISTS + SAVE IWQ SAVE NSEDSTEPS @@ -62,9 +64,14 @@ C ** INITIAL CALL IF(JSEXPLORER.EQ.1)THEN + + ! Check if the file exists + inquire(file='EE_WC.OUT', exist=FILE_EXISTS) + if (FILE_EXISTS) then OPEN(95,FILE='EE_WC.OUT',STATUS='UNKNOWN', & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') CLOSE(95,STATUS='DELETE') + end if OPEN(95,FILE='EE_WC.OUT',STATUS='UNKNOWN', & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') VER=106 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/EEXPOUT_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/EEXPOUT_mpi.for new file mode 100644 index 000000000..48a019413 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/EEXPOUT_mpi.for @@ -0,0 +1,849 @@ + SUBROUTINE EEXPOUT_mpi(JSEXPLORER) + + !---------------------------------------------------------------- + + ! ** SUBROUTINE EEXPOUT WRITES UNFORMATTED OUTPUT FILES: + ! ** EE_WC - WATER COLUMN AND TOP LAYER OF SEDIMENTS + ! ** EE_BED - SEDIMENT BED LAYER INFORMATION + ! ** EE_WQ - WATER QUALITY INFORMATION FOR THE WATER COLUMN + ! ** EE_SD - SEDIMENT DIAGENSIS INFORMATION + ! ** EE_ARRAYS - GENERAL/USER DEFINED ARRAY DUMP. LINKED TO + ! ** EFDC_EXPLORER FOR DISPLAY + ! ** EE_SEDZLJ - SEDIMENT BED DATA FOR SEDZLJ SUB-MODEL + + !---------------------------------------------------------------- + + ! *** Notes: + + USE GLOBAL + USE MPI + + INTEGER*4 VER + CHARACTER*8 ARRAYNAME + INTEGER*4 IWQ(40), NACTIVE + INTEGER*4 JSEXPLORER,NS,NW,MW,NSEDSTEPS,NSXD + INTEGER*4 L,K,ISYS,NT,NX,N1 + REAL*4 TMPVAL,WQ + REAL*4 ZERO, SHEAR + + INTEGER NP1 + INTEGER COUNTCELL(LA) + + SAVE IWQ + SAVE NSEDSTEPS + + LOGICAL FILE_EXISTS + + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + ELSE + DELT=DTDYN + ENDIF + NACTIVE=LA-1 + +!{GEOSR, OIL, CWCHO, 101121 + S1TIME=MPI_TIC() + IF (IDTOX.GE.4440) THEN + ISTRAN(5)=1 + NTOX=1 + DO L=2,LA + DO K=1,KC + COUNTCELL(L)=0 + OILCONC=0.0 + DO NP1=1,NPD + IF(L==LLA(NP1)) THEN + COUNTCELL(L)=COUNTCELL(L)+1 + ENDIF + ENDDO + OILCONC(L,K,1)=OILMASS/REAL(NPD)*REAL(COUNTCELL(L)) + OILCONC(L,K,1)=OILCONC(L,K,1)/(DXP(L)*DYP(L)*HP(L))*1000. ! [mg/L] + TOX(L,K,1)=OILCONC(L,K,1) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(991)=MPI_WTIMES(992)+MPI_TOC(S1TIME) +!} + IF(JSEXPLORER.eq.0)THEN + IF(ISSPH(8).GE.1)THEN + call collect_in_zero_int(KBT) + call collect_in_zero(TAUBSED) + call collect_in_zero(TAUBSND) + call collect_in_zero(TAUB) + DO K=0,KCM + call collect_in_zero(QQ(:,K)) + ENDDO + + call collect_in_zero(RSSBCE) + call collect_in_zero(RSSBCW) + call collect_in_zero(RSSBCN) + call collect_in_zero(RSSBCS) + call collect_in_zero(TBX) + call collect_in_zero(TBY) + + call collect_in_zero(WVWHA) + call collect_in_zero(WVFRQL) + call collect_in_zero(WACCWE) + + call collect_in_zero_array(SAL) + call collect_in_zero_array(TEM) + call collect_in_zero(TEMB) + call collect_in_zero_array(DYE) + call collect_in_zero_array(SFL) + + DO NT=1,NTXM + call collect_in_zero_array_kbm(TOXB(:,:,NT)) + call collect_in_zero_array(TOX(:,:,NT)) + ENDDO + + call collect_in_zero(BELV) + call collect_in_zero_array_kbm(HBED) + call collect_in_zero_array_kbm(BDENBED) + call collect_in_zero_array_kbm(PORBED) + + DO NS=1,NSED + call collect_in_zero_array_kbm(SEDB(:,:,NS)) + call collect_in_zero_array_kbm(VFRBED(:,:,NS)) + call collect_in_zero_array(SED(:,:,NS)) + ENDDO + + DO NX=1,NSND + call collect_in_zero_array_kbm(SNDB(:,:,NX)) + call collect_in_zero_array_kbm(VFRBED(:,:,NX+NSED)) + call collect_in_zero_array(SND(:,:,NX)) + call collect_in_zero(CQBEDLOADX(:,NX)) + call collect_in_zero(CQBEDLOADY(:,NX)) + ENDDO + + ENDIF + + IF(ISTRAN(6).GT.0.AND.NSEDFLUME.GT.0)THEN + call collect_in_zero_r8(TAU) + call collect_in_zero_r8(D50AVG) + call collect_in_zero_r8(ETOTO) + + DO NT=1,NSCM + call collect_in_zero_r8(CBL(1,:,NT)) + call collect_in_zero_r8(CBL(2,:,NT)) + call collect_in_zero_r8(XBLFLUX(:,NT)) + call collect_in_zero_r8(YBLFLUX(:,NT)) + DO K=1,KB + call collect_in_zero_r8(PER(NT,K,:)) + ENDDO + ENDDO + DO K=1,KB + call collect_in_zero_int(LAYER(K,:)) + call collect_in_zero_r8(TSED(K,:)) + call collect_in_zero_r8(BULKDENS(K,:)) + ENDDO + ENDIF + + IF(ISBEXP.GE.1)THEN + call collect_in_zero_int(KBT) + call collect_in_zero_array_kbm(HBED) + call collect_in_zero_array_kbm(BDENBED) + call collect_in_zero_array_kbm(PORBED) + + DO NT=1,NTOX + call collect_in_zero_array_kbm(TOXB(:,:,NT)) + ENDDO + + DO NS=1,NSED + call collect_in_zero_array_kbm(SEDB(:,:,NS)) + call collect_in_zero_array_kbm(VFRBED(:,:,NS)) + ENDDO + + DO NX=1,NSND + call collect_in_zero_array_kbm(SNDB(:,:,NX)) + call collect_in_zero_array_kbm(VFRBED(:,:,NX+NSED)) + ENDDO + ENDIF + + IF(ISINWV.EQ.2)THEN + call collect_in_zero_array(FXWAVE) + call collect_in_zero_array(FYWAVE) + + call collect_in_zero(HP) + call collect_in_zero_array(AH) + call collect_in_zero_array(AV) + DO K=0,KCM + call collect_in_zero(QQ(:,K)) + ENDDO + + call collect_in_zero_array(FMDUX) + call collect_in_zero_array(FMDUY) + call collect_in_zero_array(FMDVY) + call collect_in_zero_array(FMDVX) + call collect_in_zero_array(U) + call collect_in_zero_array(V) + + call collect_in_zero(UHDYE) + call collect_in_zero(VHDXE) + + call collect_in_zero(FXE) + call collect_in_zero(FYE) + call collect_in_zero(DXIU) + call collect_in_zero(DYIV) + call collect_in_zero(AHC(:,1)) + call collect_in_zero(AHC(:,2)) + + call collect_in_zero_array(AHU) + call collect_in_zero_array(AMCU) + call collect_in_zero_array(AMCV) + call collect_in_zero_array(AMSU) + ENDIF + + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + DO NSP=1,NXSP + call collect_in_zero_array(WQVX(:,:,NSP)) + ENDDO + + IF(PRINT_SUM.AND.MYRANK.EQ.0)THEN + PRINT*,n,'TAUBSED ',sum(abs(dble(TAUBSED))) + PRINT*,n,'TAUBSND ',sum(abs(dble(TAUBSND))) + PRINT*,n,'TAUB ',sum(abs(dble(TAUB))) + PRINT*,n,'RSSBCE ',sum(abs(dble(RSSBCE))) + PRINT*,n,'RSSBCW ',sum(abs(dble(RSSBCW))) + PRINT*,n,'RSSBCN ',sum(abs(dble(RSSBCN))) + PRINT*,n,'RSSBCS ',sum(abs(dble(RSSBCS))) + PRINT*,n,'TBX ',sum(abs(dble(TBX))) + PRINT*,n,'TBY ',sum(abs(dble(TBY))) + PRINT*,n,'WVWHA ',sum(abs(dble(WVWHA))) + PRINT*,n,'WVFRQL ',sum(abs(dble(WVFRQL))) + PRINT*,n,'WACCWE ',sum(abs(dble(WACCWE))) + PRINT*,n,'SAL ',sum(abs(dble(SAL))) + PRINT*,n,'TEM ',sum(abs(dble(TEM))) + PRINT*,n,'TEMB ',sum(abs(dble(TEMB))) + PRINT*,n,'DYE ',sum(abs(dble(DYE))) + PRINT*,n,'SFL ',sum(abs(dble(SFL))) + PRINT*,n,'TOXB ',sum(abs(dble(TOXB))) + PRINT*,n,'TOX ',sum(abs(dble(TOX))) + PRINT*,n,'HBED ',sum(abs(dble(HBED))) + PRINT*,n,'BDENBED ',sum(abs(dble(BDENBED))) + PRINT*,n,'PORBED ',sum(abs(dble(PORBED))) + PRINT*,n,'KBT ',sum(abs(dble(KBT))) + PRINT*,n,'SEDB ',sum(abs(dble(SEDB))) + PRINT*,n,'VFRBED ',sum(abs(dble(VFRBED))) + PRINT*,n,'SNDB ',sum(abs(dble(SNDB))) + PRINT*,n,'VFRBED ',sum(abs(dble(VFRBED))) + PRINT*,n,'CQBEDLOADX ',sum(abs(dble(CQBEDLOADX))) + PRINT*,n,'CQBEDLOADY ',sum(abs(dble(CQBEDLOADY))) + PRINT*,n,'WQV ',sum(abs(dble(WQV))) + PRINT*,n,'WQVX ',sum(abs(dble(WQVX))) + ENDIF + ENDIF + +C ** INITIAL CALL + S1TIME=MPI_TIC() + IF(JSEXPLORER.EQ.1.AND.MYRANK.EQ.0)THEN + inquire(file='EE_WC.OUT', exist=file_exists) + if (file_exists) then + OPEN(95,FILE='EE_WC.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(95,STATUS='DELETE') + end if + OPEN(95,FILE='EE_WC.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=106 + WRITE(95)VER + WRITE(95)ISTRAN(1),ISTRAN(2),ISTRAN(3),ISTRAN(4) + WRITE(95)ISTRAN(5),ISTRAN(6),ISTRAN(7) + WRITE(95)NSED,NSND,KB,KC,NTOX + NSXD=NSED+NSND + DO NS=1,NSXD + WRITE(95)SEDDIA(NS) + ENDDO + CLOSE(95,STATUS='KEEP') + + IF(ISTRAN(6).GT.0.AND.NSEDFLUME.GT.0)THEN + OPEN(95,FILE='EE_SEDZLJ.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(95,STATUS='DELETE') + OPEN(95,FILE='EE_SEDZLJ.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=100 + WRITE(95)VER + WRITE(95)ITBM,NSICM + CLOSE(95,STATUS='KEEP') + ENDIF + + IF(ISBEXP.GE.1)THEN + IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN + OPEN(10,FILE='EE_BED.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(10,STATUS='DELETE') + OPEN(10,FILE='EE_BED.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=106 + WRITE(10)VER + WRITE(10)ISTRAN(1),ISTRAN(2),ISTRAN(3),ISTRAN(4) + WRITE(10)ISTRAN(5),ISTRAN(6),ISTRAN(7) + WRITE(10)NSED,NSND,KB,KC,NTOX + DO NS=1,NSXD + WRITE(10)SEDDIA(NS) + ENDDO + CLOSE(10,STATUS='KEEP') + ENDIF + ENDIF + + IF(ISTRAN(8).GT.0)THEN + OPEN(95,FILE='EE_WQ.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(95,STATUS='DELETE') + OPEN(95,FILE='EE_WQ.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=100 + WRITE(95)VER + WRITE(95)NWQV + WRITE(95)(ISTRWQ(NW),NW=1,NWQV) + IWQ=0 + DO MW=1,NWQV + IWQ(MW)=ISTRWQ(MW) + ENDDO + WRITE(95)(IWQ(NW),NW=1,NWQV) + CLOSE(95,STATUS='KEEP') +!{ GEOSR X-species : jgcho 2015.10.14 + if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 + OPEN(95,FILE='EE_WQX.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(95,STATUS='DELETE') + OPEN(95,FILE='EE_WQX.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=100 + WRITE(95)VER + WRITE(95)NXSP,LA,KC + CLOSE(95,STATUS='KEEP') + endif ! if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 +!} GEOSR X-species : jgcho 2015.10.14 + + ! *** SAVE SEDIMENT DIAGENESIS RESULTS + IF(ISSDBIN.LT.0)THEN + OPEN(95,FILE='EE_SD.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(95,STATUS='DELETE') + OPEN(95,FILE='EE_SD.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=100 + WRITE(95)VER + WRITE(95)NACTIVE + CLOSE(95,STATUS='KEEP') + NSEDSTEPS=-1 + ENDIF + ENDIF + ELSEIF(JSEXPLORER.EQ.-1)THEN + ! *** FORCE ALL OUTPUT + NSEDSTEPS=32000 + ENDIF + MPI_WTIMES(992)=MPI_WTIMES(992)+MPI_TOC(S1TIME) + +C *** WRITE SNAPSHOT + S1TIME=MPI_TIC() + IF(ISDYNSTP.EQ.0)THEN + EETIME=DT*FLOAT(N)+TCON*TBEGIN + ELSE + EETIME=TIMESEC + ENDIF + IF(JSEXPLORER.EQ.1)EETIME=TCON*TBEGIN + EETIME=EETIME/86400. + + IF(ISSPH(8).GE.1.AND.MYRANK.EQ.0)THEN + OPEN(95,FILE='EE_WC.OUT',STATUS='OLD', + & POSITION='APPEND',FORM='UNFORMATTED') + WRITE(95)EETIME,NACTIVE + DO L=2,LA + N1=KBT(L) + IF(ISTRAN(6).GT.0.OR.ISTRAN(7).GT.0)THEN + IF(ISBEDSTR.GE.1.AND.NSEDFLUME.EQ.0)THEN + WRITE(95)TAUBSED(L) + IF(ISBEDSTR.EQ.1)THEN + WRITE(95)TAUBSND(L) + ENDIF + ELSE + WRITE(95)TAUB(L) + ENDIF + ELSE + SHEAR=MAX(QQ(L,0),QQMIN)/CTURB2 + WRITE(95)SHEAR + ENDIF + IF(ISWAVE.GE.1)THEN + ! *** Shear due to Current Only + SHEAR = (RSSBCE(L)*TBX(L+1 )+RSSBCW(L)*TBX(L))**2 + & +(RSSBCN(L)*TBY(LNC(L))+RSSBCS(L)*TBY(L))**2 + SHEAR=0.5*SQRT(SHEAR) + WRITE(95)SHEAR + IF(ISWAVE.EQ.3)THEN + WRITE(95)WVWHA(L),WVFRQL(L),WACCWE(L) + ENDIF + ENDIF + IF(ISTRAN(1).EQ.1)WRITE(95)(SAL(L,K),K=1,KC) + IF(ISTRAN(2).EQ.1)THEN + WRITE(95)(TEM(L,K),K=1,KC) + IF(TBEDIT.GT.0.)WRITE(95)TEMB(L) + ENDIF + IF(ISTRAN(3).EQ.1)WRITE(95,ERR=999,IOSTAT=ISYS) + & (DYE(L,K),K=1,KC) + IF(ISTRAN(4).EQ.1)WRITE(95)(SFL(L,K),K=1,KC) + IF(ISTRAN(5).EQ.1)THEN + WRITE(95)(TOXB(L,N1,NT),NT=1,NTOX) + WRITE(95)((TOX(L,K,NT),K=1,KC),NT=1,NTOX) + ENDIF + IF(ISTRAN(6).EQ.1.OR.ISTRAN(7).GE.1)THEN + WRITE(95)N1,BELV(L),HBED(L,N1),BDENBED(L,N1),PORBED(L,N1) + IF(ISTRAN(6).EQ.1)THEN + WRITE(95)(SEDB(L,N1,NS),VFRBED(L,N1,NS),NS=1,NSED) + WRITE(95)((SED(L,K,NS),K=1,KC),NS=1,NSED) + ENDIF + IF(ISTRAN(7).EQ.1)THEN + WRITE(95)(SNDB(L,N1,NX),VFRBED(L,N1,NX+NSED),NX=1,NSND) + WRITE(95)((SND(L,K,NX),K=1,KC),NX=1,NSND) + IF(ISBDLDBC.GT.0)THEN + WRITE(95)(CQBEDLOADX(L,NX),CQBEDLOADY(L,NX),NX=1,NSND) + ENDIF + ENDIF + ENDIF + ENDDO + IF(MYRANK.EQ.0) CALL FLUSH(95) + IF(MYRANK.EQ.0) CLOSE(95,STATUS='KEEP') + ENDIF + MPI_WTIMES(993)=MPI_WTIMES(993)+MPI_TOC(S1TIME) + + ! *** OUTPUT THE SEDZLJ VARIABLES + S1TIME=MPI_TIC() + IF(ISTRAN(6).GT.0.AND.NSEDFLUME.GT.0.AND.MYRANK.EQ.0)THEN + OPEN(95,FILE='EE_SEDZLJ.OUT',STATUS='OLD', + & POSITION='APPEND',FORM='UNFORMATTED') + + WRITE(95)EETIME,NACTIVE + + DO L=2,LA + WRITE(95) REAL(TAU(L)) !TAU(LCM) - Shear Stress in dynes/cm^2 + WRITE(95) REAL(D50AVG(L)) !D50AVG(LCM) - Average particle size of bed surface (microns) + WRITE(95) REAL(ETOTO(L)) !ETOTO(LCM) - Total erosion in the cell + DO NT=1,NSCM + WRITE(95) REAL(CBL(1,L,NT)) !CBL(NSCM,LCM) - This is the bedload concentration in g/cm^3 of each size class + WRITE(95) REAL(XBLFLUX(L,NT)) !XBLFLUX(LCM,NSCM) - Bedload flux in X direction (g/s) + WRITE(95) REAL(YBLFLUX(L,NT)) !YBLFLUX(LCM,NSCM) - Bedload flux in Y direction (g/s) + DO K=1,KB + WRITE(95) REAL(PER(NT,K,L)) !PER(NSCM,KB,LCM) - This is the mass percentage of each size class in a layer + ENDDO + ENDDO + DO K=1,KB + WRITE(95) LAYER(K,L) !LAYER(KB,LCM) - This is = 1 when a bed layer (KB index) exists with mass + WRITE(95) REAL(TSED(K,L)) !TSED(KB,LCM) - This is the mass in g/cm^2 in each layer + WRITE(95) REAL(BULKDENS(K,L)) !BULKDENS(KB,LCM) - Dry Bulk density of each layer (g/cm^3) + ENDDO + ENDDO + + IF(MYRANK.EQ.0) CALL FLUSH(95) + IF(MYRANK.EQ.0) CLOSE(95,STATUS='KEEP') + ENDIF + MPI_WTIMES(994)=MPI_WTIMES(994)+MPI_TOC(S1TIME) + +C *** NOW OUTPUT ALL THE BEDINFO TO A SINGLE FILE + S1TIME=MPI_TIC() + IF(ISBEXP.GE.1.AND.MYRANK.EQ.0)THEN + IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1.AND.KB.GT.1)THEN + OPEN(87,FILE='EE_BED.OUT',STATUS='UNKNOWN',POSITION='APPEND' + & ,FORM='UNFORMATTED') + WRITE(87)EETIME,NACTIVE + DO L=2,LA + WRITE(87)KBT(L) + ENDDO + DO L=2,LA + DO K=1,KB + WRITE(87)HBED(L,K),BDENBED(L,K),PORBED(L,K) + IF(ISTRAN(6).GE.1)THEN + DO NS=1,NSED + WRITE(87)SEDB(L,K,NS),VFRBED(L,K,NS) + ENDDO + ENDIF + IF(ISTRAN(7).GE.1)THEN + DO NX=1,NSND + NS=NSED+NX + WRITE(87)SNDB(L,K,NX),VFRBED(L,K,NS) + ENDDO + ENDIF + IF(ISTRAN(5).GE.1)THEN + DO NT=1,NTOX + WRITE(87)TOXB(L,K,NT) + ENDDO + ENDIF + ENDDO + ENDDO + CALL FLUSH(87) + CLOSE(87,STATUS='KEEP') + ENDIF + ENDIF + MPI_WTIMES(995)=MPI_WTIMES(995)+MPI_TOC(S1TIME) + +C *** INTERNAL ARRAYS + S1TIME=MPI_TIC() + IF(ISINWV.EQ.2.AND.JSEXPLORER.LE.0.AND.MYRANK.EQ.0)THEN + ZERO=0.0 + IF(N.LT.(2*NTSPTC/NPSPH(8)))THEN + OPEN(95,FILE='EE_ARRAYS.OUT',STATUS='UNKNOWN') + CLOSE(95,STATUS='DELETE') + OPEN(95,FILE='EE_ARRAYS.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=100 + WRITE(95)VER + WRITE(95)3 ! # OF TIME VARYING ARRAYS + + ! FLAGS: ARRAY TYPE, TIME VARIABLE + ! ARRAY TYPE: 0 = L DIM'D + ! 1 = L,KC DIM'D + ! 2 = L,0:KC DIM'D + ! 3 = L,KB DIM'D + ! 4 = L,KC,NCLASS DIM'D + ! TIME VARIABLE: 0 = NOT CHANGING + ! 1 = TIME VARYING + + !WRITE(95)0,0 + !ARRAYNAME='SUB' + !WRITE(95)ARRAYNAME + !DO L=2,LA + ! WRITE(95)SUB(L) + !ENDDO + + !WRITE(95)0,0 + !ARRAYNAME='SVB' + !WRITE(95)ARRAYNAME + !DO L=2,LA + ! WRITE(95)SVB(L) + !ENDDO + + WRITE(95)1,0 + ARRAYNAME='FXWAVE' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FXWAVE(L,K) + ENDDO + ENDDO + + WRITE(95)1,0 + ARRAYNAME='FYWAVE' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FYWAVE(L,K) + ENDDO + ENDDO + + ELSE + OPEN(95,FILE='EE_ARRAYS.OUT',STATUS='UNKNOWN', + & POSITION='APPEND',FORM='UNFORMATTED') + ENDIF + + IF(.TRUE.)THEN + + WRITE(95)1,1 + ARRAYNAME='AH' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)AH(L,K) + ENDDO + ENDDO + + WRITE(95)1,1 + ARRAYNAME='AV' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)(AV(L,K)*HP(L)) + ENDDO + ENDDO + + WRITE(95)2,1 + ARRAYNAME='QQ' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=0,KC + WRITE(95)QQ(L,K) + ENDDO + ENDDO + + IF(.FALSE.)THEN + ! *** FMDUX FMDUY FMDVY FMDVX + WRITE(95)1,1 + ARRAYNAME='FMDUX' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FMDUX(L,K) + ENDDO + ENDDO + + WRITE(95)1,1 + ARRAYNAME='FMDUY' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FMDUY(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='FMDVY' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FMDVY(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='FMDVX' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FMDVX(L,K) + ENDDO + ENDDO + + WRITE(95)1,1 + ARRAYNAME='U' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)U(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='V' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)V(L,K) + ENDDO + ENDDO + + WRITE(95)0,1 + ARRAYNAME='UHDYE' + WRITE(95)ARRAYNAME + DO L=2,LA + WRITE(95)UHDYE(L) + ENDDO + + WRITE(95)0,1 + ARRAYNAME='VHDXE' + WRITE(95)ARRAYNAME + DO L=2,LA + WRITE(95)VHDXE(L) + ENDDO + + WRITE(95)0,1 + ARRAYNAME='FXE' + WRITE(95)ARRAYNAME + DO L=2,LA + TMPVAL=FXE(L)*DELT*DXIU(L) + WRITE(95)TMPVAL + ENDDO + + WRITE(95)0,1 + ARRAYNAME='FYE' + WRITE(95)ARRAYNAME + DO L=2,LA + TMPVAL=FYE(L)*DELT*DYIV(L) + WRITE(95)TMPVAL + ENDDO + + WRITE(95)0,1 + ARRAYNAME='FUHX' + WRITE(95)ARRAYNAME + DO L=2,LA + TMPVAL=AHC(L,1)*DELT*DXIU(L) + WRITE(95)TMPVAL + ENDDO + + WRITE(95)0,1 + ARRAYNAME='FVHY' + WRITE(95)ARRAYNAME + DO L=2,LA + TMPVAL=AHC(L,2)*DELT*DYIV(L) + WRITE(95)TMPVAL + ENDDO + + WRITE(95)1,1 + ARRAYNAME='FUHU' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)AHU(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='FVHU' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)AMCU(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='FVHV' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)AMCV(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='FUHV' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)AMSU(L,K) + ENDDO + ENDDO + + ENDIF + + !WRITE(95)0,1 + !ARRAYNAME='TATMT' + !WRITE(95)ARRAYNAME + !DO L=2,LA + ! WRITE(95)TATMT(L) + !ENDDO + ENDIF +C + CALL FLUSH(95) + CLOSE(95,STATUS='KEEP') + + ENDIF + MPI_WTIMES(996)=MPI_WTIMES(996)+MPI_TOC(S1TIME) + +C *** WATER QUALITY + IF(ISTRAN(8).GT.0.AND.MYRANK.EQ.0)THEN + ! 1) CHC - cyanobacteria + ! 2) CHD - diatom algae + ! 3) CHG - green algae + ! 4) ROC - refractory particulate organic carbon + ! 5) LOC - labile particulate organic carbon + ! 6) DOC - dissolved organic carbon + ! 7) ROP - refractory particulate organic phosphorus + ! 8) LOP - labile particulate organic phosphorus + ! 9) DOP - dissolved organic phosphorus + ! 10) P4D - total phosphate + ! 11) RON - refractory particulate organic nitrogen 22) macroalgae + ! 12) LON - labile particulate organic nitrogen + ! 13) DON - dissolved organic nitrogen + ! 14) NHX - ammonia nitrogen + ! 15) NOX - nitrate nitrogen + ! 16) SUU - particulate biogenic silica + ! 17) SAA - dissolved available silica + ! 18) COD - chemical oxygen demand + ! 19) DOX - dissolved oxygen + ! 20) TAM - total active metal + ! 21) FCB - fecal coliform bacteria + S1TIME=MPI_TIC() + OPEN(95,FILE='EE_WQ.OUT',STATUS='UNKNOWN',POSITION='APPEND', + & FORM='UNFORMATTED') + WRITE(95)EETIME + DO L=2,LA + DO K=1,KC + DO NW=1,NWQV + IF(IWQ(NW).GT.0)THEN + WQ=WQV(L,K,NW) + WRITE(95)WQ + ENDIF + ENDDO + ENDDO + ENDDO + CALL FLUSH(95) + CLOSE(95,STATUS='KEEP') + MPI_WTIMES(997)=MPI_WTIMES(997)+MPI_TOC(S1TIME) +!{ GEOSR X-species : jgcho 2015.10.14 + S1TIME=MPI_TIC() + if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 + OPEN(95,FILE='EE_WQX.OUT',STATUS='UNKNOWN',POSITION='APPEND', + & FORM='UNFORMATTED') + WRITE(95)EETIME,N + do nsp=1,NXSP + do K=1,KC + do L=2,LA + WQ=WQVX(L,K,nsp) + WRITE(95)WQ + ENDDO + ENDDO + ENDDO + CALL FLUSH(95) + CLOSE(95,STATUS='KEEP') + endif !if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 + MPI_WTIMES(998)=MPI_WTIMES(998)+MPI_TOC(S1TIME) +!} GEOSR X-species : jgcho 2015.09.18 + ! *** SAVE SEDIMENT DIAGENESIS RESULTS + S1TIME=MPI_TIC() + IF(IWQBEN.GT.0.AND.ISSDBIN.LT.0)THEN + ! *** IF JSEXPLORER=1 THEN WRITE THE ARRAYS (I.E. IC'S) + NSEDSTEPS=NSEDSTEPS+1 + IF(NSEDSTEPS.GE.ABS(ISSDBIN).OR.JSEXPLORER.EQ.1)THEN + OPEN(95,FILE='EE_SD.OUT',STATUS='UNKNOWN',POSITION='APPEND', + & FORM='UNFORMATTED') + WRITE(95)EETIME + DO L=2,LA + + ! SMPON = Conc. Particulate Org. Nitrogen in G-class 1, 2 & 3 (g/m3) dim(LA,NSMGM) + ! SMPOP = Conc. Particulate Org. Phosphorus in G-class 1, 2 & 3 (g/m3) dim(LA,NSMGM) + ! SMPOC = Conc. Particulate Org. Carbon in G-class 1, 2 & 3 (g/m3) dim(LA,NSMGM) + + ! *** DEPOSITION FLUXES + ! SMDFN(LL,?) = Sediment Flux To The Sediment Bed From PON Into G1, G2, & G3 + ! SMDFP(LL,?) = Sediment Flux To The Sediment Bed From POP Into G1, G2, & G3 + ! SMDFC(LL,?) = Sediment Flux To The Sediment Bed From POC Into G1, G2, & G3 + + ! SM1NH4 = Conc. NH4-N in layer 1 (g/m3) dim(LA) + ! SM2NH4 = Conc. NH4-N in layer 2 (g/m3) + ! SM1NO3 = Conc. NO3-N in layer 1 (g/m3) + ! SM2NO3 = Conc. NO3-N in layer 2 (g/m3) + ! SM1PO4 = Conc. PO4-P in layer 1 (g/m3) + ! SM2PO4 = Conc. PO4-P in layer 2 (g/m3) + ! SM1H2S = Conc. Sulfide (H2S) in layer 1 (g/m3) + ! SM2H2S = Conc. Sulfide (H2S) in layer 2 (g/m3) + ! SMPSI = Conc. Particulate biogenic silica in layer 2 (g/m3) + ! SM1SI = Conc. Dissolved available silica in layer 1 (g/m3) + ! SM2SI = Conc. Dissolved available silica in layer 2 (g/m3) + ! SMBST = Accumulated benthic stress (days) + ! SMT = Sediment temperature (degC) + + ! *** SEDIMENT OXYGEN DEMANDS + ! SMCSOD = CARBONACEOUS SOD + ! SMNSOD = NITROGENOUS SOD + + ! *** BENTHIC FLUXES + ! WQBFNH4 = AMMONIUM FLUX + ! WQBFNO3 = NITRATE FLUX + ! WQBFO2 = O2 SEDIMENT FLUX (SOD) + ! WQBFCOD = COD FLUX + ! WQBFPO4D = PO4 FLUX + ! WQBFSAD = SILICA FLUX + + WRITE(95)(SMPON(L,K),K=1,3) + WRITE(95)(SMPOP(L,K),K=1,3) + WRITE(95)(SMPOC(L,K),K=1,3) + WRITE(95)(SMDFN(L,K),K=1,3) + WRITE(95)(SMDFP(L,K),K=1,3) + WRITE(95)(SMDFC(L,K),K=1,3) + WRITE(95)SM1NH4(L),SM2NH4(L) + WRITE(95)SM1NO3(L),SM2NO3(L) + WRITE(95)SM1PO4(L),SM2PO4(L) + WRITE(95)SM1H2S(L),SM2H2S(L) + WRITE(95)SM1SI(L), SM2SI(L) + WRITE(95)SMPSI(L) + WRITE(95)SMBST(L),SMT(L) + WRITE(95)SMCSOD(L),SMNSOD(L) + WRITE(95)WQBFNH4(L),WQBFNO3(L),WQBFO2(L),WQBFCOD(L), + & WQBFPO4D(L),WQBFSAD(L) + ENDDO + CALL FLUSH(95) + CLOSE(95,STATUS='KEEP') + NSEDSTEPS=0 + ENDIF + ENDIF + ENDIF + MPI_WTIMES(999)=MPI_WTIMES(999)+MPI_TOC(S1TIME) + + RETURN + + 999 STOP ' Error writing SNAPSHOT file' + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/EEXPOUT_opt_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/EEXPOUT_opt_mpi.for new file mode 100644 index 000000000..6cd1f3103 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/EEXPOUT_opt_mpi.for @@ -0,0 +1,971 @@ + SUBROUTINE EEXPOUT_opt_mpi(JSEXPLORER) + + !---------------------------------------------------------------- + + ! ** SUBROUTINE EEXPOUT WRITES UNFORMATTED OUTPUT FILES: + ! ** EE_WC - WATER COLUMN AND TOP LAYER OF SEDIMENTS + ! ** EE_BED - SEDIMENT BED LAYER INFORMATION + ! ** EE_WQ - WATER QUALITY INFORMATION FOR THE WATER COLUMN + ! ** EE_SD - SEDIMENT DIAGENSIS INFORMATION + ! ** EE_ARRAYS - GENERAL/USER DEFINED ARRAY DUMP. LINKED TO + ! ** EFDC_EXPLORER FOR DISPLAY + ! ** EE_SEDZLJ - SEDIMENT BED DATA FOR SEDZLJ SUB-MODEL + + !---------------------------------------------------------------- + + ! *** Notes: + + USE GLOBAL + USE MPI + + INTEGER*4 VER + CHARACTER*8 ARRAYNAME + INTEGER*4 IWQ(40), NACTIVE + INTEGER*4 JSEXPLORER,NS,NW,MW,NSEDSTEPS,NSXD + INTEGER*4 L,K,ISYS,NT,NX,N1 + REAL*4 TMPVAL,WQ + REAL*4 ZERO, SHEAR +c REAL SHEAR_1D(LCM),HBED_1D(LCM),BDENBED_1D(LCM),PORBED_1D(LCM) +c REAL SEDB_1D(LCM,NSED),SED_VFRBED_1D(LCM,NSED) +c REAL SNDB_1D(LCM,NSND),SND_VFRBED_1D(LCM,NSND) +c INTEGER N1_1D(LCM) + + INTEGER NP1 + INTEGER COUNTCELL(LA) + + LOGICAL FILE_EXISTS + + SAVE IWQ + SAVE NSEDSTEPS + + IF(.NOT.ALLOCATED(SEDB_1D))THEN + ALLOCATE(SEDB_1D(LCM,NSED)) + ALLOCATE(SED_VFRBED_1D(LCM,NSED)) + ALLOCATE(SNDB_1D(LCM,NSND)) + ALLOCATE(SND_VFRBED_1D(LCM,NSND)) + SEDB_1D =0. + SED_VFRBED_1D=0. + SNDB_1D =0. + SND_VFRBED_1D=0. + ENDIF + + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + ELSE + DELT=DTDYN + ENDIF + NACTIVE=LA-1 + +!{GEOSR, OIL, CWCHO, 101121 + S1TIME=MPI_TIC() + IF (IDTOX.GE.4440) THEN + ISTRAN(5)=1 + NTOX=1 + DO L=2,LA + DO K=1,KC + COUNTCELL(L)=0 + OILCONC=0.0 + DO NP1=1,NPD + IF(L==LLA(NP1)) THEN + COUNTCELL(L)=COUNTCELL(L)+1 + ENDIF + ENDDO + OILCONC(L,K,1)=OILMASS/REAL(NPD)*REAL(COUNTCELL(L)) + OILCONC(L,K,1)=OILCONC(L,K,1)/(DXP(L)*DYP(L)*HP(L))*1000. ! [mg/L] + TOX(L,K,1)=OILCONC(L,K,1) + ENDDO + ENDDO + ENDIF + MPI_WTIMES(991)=MPI_WTIMES(992)+MPI_TOC(S1TIME) +!} + IF(JSEXPLORER.eq.0)THEN + IF(ISSPH(8).GE.1)THEN + call collect_in_zero_int(KBT) + call collect_in_zero(TAUBSED) + call collect_in_zero(TAUBSND) + call collect_in_zero(TAUB) + DO K=0,KCM + call collect_in_zero(QQ(:,K)) + ENDDO + + call collect_in_zero(RSSBCE) + call collect_in_zero(RSSBCW) + call collect_in_zero(RSSBCN) + call collect_in_zero(RSSBCS) + call collect_in_zero(TBX) + call collect_in_zero(TBY) + + call collect_in_zero(WVWHA) + call collect_in_zero(WVFRQL) + call collect_in_zero(WACCWE) + + call collect_in_zero_array(SAL) + call collect_in_zero_array(TEM) + call collect_in_zero(TEMB) + call collect_in_zero_array(DYE) + call collect_in_zero_array(SFL) + + DO NT=1,NTXM + call collect_in_zero_array_kbm(TOXB(:,:,NT)) + call collect_in_zero_array(TOX(:,:,NT)) + ENDDO + + call collect_in_zero(BELV) + call collect_in_zero_array_kbm(HBED) + call collect_in_zero_array_kbm(BDENBED) + call collect_in_zero_array_kbm(PORBED) + + DO NS=1,NSED + call collect_in_zero_array_kbm(SEDB(:,:,NS)) + call collect_in_zero_array_kbm(VFRBED(:,:,NS)) + call collect_in_zero_array(SED(:,:,NS)) + ENDDO + + DO NX=1,NSND + call collect_in_zero_array_kbm(SNDB(:,:,NX)) + call collect_in_zero_array_kbm(VFRBED(:,:,NX+NSED)) + call collect_in_zero_array(SND(:,:,NX)) + call collect_in_zero(CQBEDLOADX(:,NX)) + call collect_in_zero(CQBEDLOADY(:,NX)) + ENDDO + + ENDIF + + IF(ISTRAN(6).GT.0.AND.NSEDFLUME.GT.0)THEN + call collect_in_zero_r8(TAU) + call collect_in_zero_r8(D50AVG) + call collect_in_zero_r8(ETOTO) + + DO NT=1,NSCM + call collect_in_zero_r8(CBL(1,:,NT)) + call collect_in_zero_r8(CBL(2,:,NT)) + call collect_in_zero_r8(XBLFLUX(:,NT)) + call collect_in_zero_r8(YBLFLUX(:,NT)) + DO K=1,KB + call collect_in_zero_r8(PER(NT,K,:)) + ENDDO + ENDDO + DO K=1,KB + call collect_in_zero_int(LAYER(K,:)) + call collect_in_zero_r8(TSED(K,:)) + call collect_in_zero_r8(BULKDENS(K,:)) + ENDDO + ENDIF + + IF(ISBEXP.GE.1)THEN + call collect_in_zero_int(KBT) + call collect_in_zero_array_kbm(HBED) + call collect_in_zero_array_kbm(BDENBED) + call collect_in_zero_array_kbm(PORBED) + + DO NT=1,NTOX + call collect_in_zero_array_kbm(TOXB(:,:,NT)) + ENDDO + + DO NS=1,NSED + call collect_in_zero_array_kbm(SEDB(:,:,NS)) + call collect_in_zero_array_kbm(VFRBED(:,:,NS)) + ENDDO + + DO NX=1,NSND + call collect_in_zero_array_kbm(SNDB(:,:,NX)) + call collect_in_zero_array_kbm(VFRBED(:,:,NX+NSED)) + ENDDO + ENDIF + + IF(ISINWV.EQ.2)THEN + call collect_in_zero_array(FXWAVE) + call collect_in_zero_array(FYWAVE) + + call collect_in_zero(HP) + call collect_in_zero_array(AH) + call collect_in_zero_array(AV) + DO K=0,KCM + call collect_in_zero(QQ(:,K)) + ENDDO + + call collect_in_zero_array(FMDUX) + call collect_in_zero_array(FMDUY) + call collect_in_zero_array(FMDVY) + call collect_in_zero_array(FMDVX) + call collect_in_zero_array(U) + call collect_in_zero_array(V) + + call collect_in_zero(UHDYE) + call collect_in_zero(VHDXE) + + call collect_in_zero(FXE) + call collect_in_zero(FYE) + call collect_in_zero(DXIU) + call collect_in_zero(DYIV) + call collect_in_zero(AHC(:,1)) + call collect_in_zero(AHC(:,2)) + + call collect_in_zero_array(AHU) + call collect_in_zero_array(AMCU) + call collect_in_zero_array(AMCV) + call collect_in_zero_array(AMSU) + ENDIF + + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + DO NSP=1,NXSP + call collect_in_zero_array(WQVX(:,:,NSP)) + ENDDO + + IF(PRINT_SUM)THEN + IF(MYRANK.EQ.0)THEN + PRINT*,n,'TAUBSED ',sum(abs(dble(TAUBSED))) + PRINT*,n,'TAUBSND ',sum(abs(dble(TAUBSND))) + PRINT*,n,'TAUB ',sum(abs(dble(TAUB))) + PRINT*,n,'RSSBCE ',sum(abs(dble(RSSBCE))) + PRINT*,n,'RSSBCW ',sum(abs(dble(RSSBCW))) + PRINT*,n,'RSSBCN ',sum(abs(dble(RSSBCN))) + PRINT*,n,'RSSBCS ',sum(abs(dble(RSSBCS))) + PRINT*,n,'TBX ',sum(abs(dble(TBX))) + PRINT*,n,'TBY ',sum(abs(dble(TBY))) + PRINT*,n,'WVWHA ',sum(abs(dble(WVWHA))) + PRINT*,n,'WVFRQL ',sum(abs(dble(WVFRQL))) + PRINT*,n,'WACCWE ',sum(abs(dble(WACCWE))) + PRINT*,n,'SAL ',sum(abs(dble(SAL))) + PRINT*,n,'TEM ',sum(abs(dble(TEM))) + PRINT*,n,'TEMB ',sum(abs(dble(TEMB))) + PRINT*,n,'DYE ',sum(abs(dble(DYE))) + PRINT*,n,'SFL ',sum(abs(dble(SFL))) + PRINT*,n,'TOXB ',sum(abs(dble(TOXB))) + PRINT*,n,'TOX ',sum(abs(dble(TOX))) + PRINT*,n,'HBED ',sum(abs(dble(HBED))) + PRINT*,n,'BDENBED ',sum(abs(dble(BDENBED))) + PRINT*,n,'PORBED ',sum(abs(dble(PORBED))) + PRINT*,n,'KBT ',sum(abs(dble(KBT))) + PRINT*,n,'SEDB ',sum(abs(dble(SEDB))) + PRINT*,n,'VFRBED ',sum(abs(dble(VFRBED))) + PRINT*,n,'SNDB ',sum(abs(dble(SNDB))) + PRINT*,n,'VFRBED ',sum(abs(dble(VFRBED))) + PRINT*,n,'CQBEDLOADX ',sum(abs(dble(CQBEDLOADX))) + PRINT*,n,'CQBEDLOADY ',sum(abs(dble(CQBEDLOADY))) + PRINT*,n,'WQV ',sum(abs(dble(WQV))) + PRINT*,n,'WQVX ',sum(abs(dble(WQVX))) + ENDIF + ENDIF + ENDIF + +C ** INITIAL CALL + S1TIME=MPI_TIC() + IF(JSEXPLORER.EQ.1.AND.MYRANK.EQ.0)THEN + inquire(file='EE_WC.OUT', exist=file_exists) + if (file_exists) then + OPEN(95,FILE='EE_WC.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(95,STATUS='DELETE') + end if + OPEN(95,FILE='EE_WC.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=106 + WRITE(95)VER + WRITE(95)ISTRAN(1),ISTRAN(2),ISTRAN(3),ISTRAN(4) + WRITE(95)ISTRAN(5),ISTRAN(6),ISTRAN(7) + WRITE(95)NSED,NSND,KB,KC,NTOX + NSXD=NSED+NSND + DO NS=1,NSXD + WRITE(95)SEDDIA(NS) + ENDDO + CLOSE(95,STATUS='KEEP') + + IF(ISTRAN(6).GT.0.AND.NSEDFLUME.GT.0)THEN + OPEN(95,FILE='EE_SEDZLJ.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(95,STATUS='DELETE') + OPEN(95,FILE='EE_SEDZLJ.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=100 + WRITE(95)VER + WRITE(95)ITBM,NSICM + CLOSE(95,STATUS='KEEP') + ENDIF + + IF(ISBEXP.GE.1)THEN + IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN + OPEN(10,FILE='EE_BED.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(10,STATUS='DELETE') + OPEN(10,FILE='EE_BED.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=106 + WRITE(10)VER + WRITE(10)ISTRAN(1),ISTRAN(2),ISTRAN(3),ISTRAN(4) + WRITE(10)ISTRAN(5),ISTRAN(6),ISTRAN(7) + WRITE(10)NSED,NSND,KB,KC,NTOX + DO NS=1,NSXD + WRITE(10)SEDDIA(NS) + ENDDO + CLOSE(10,STATUS='KEEP') + ENDIF + ENDIF + + IF(ISTRAN(8).GT.0)THEN + OPEN(95,FILE='EE_WQ.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(95,STATUS='DELETE') + OPEN(95,FILE='EE_WQ.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=100 + WRITE(95)VER + WRITE(95)NWQV + WRITE(95)(ISTRWQ(NW),NW=1,NWQV) + IWQ=0 + DO MW=1,NWQV + IWQ(MW)=ISTRWQ(MW) + ENDDO + WRITE(95)(IWQ(NW),NW=1,NWQV) + CLOSE(95,STATUS='KEEP') +!{ GEOSR X-species : jgcho 2015.10.14 + if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 + OPEN(95,FILE='EE_WQX.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(95,STATUS='DELETE') + OPEN(95,FILE='EE_WQX.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=100 + WRITE(95)VER + WRITE(95)NXSP,LA,KC + CLOSE(95,STATUS='KEEP') + endif ! if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 +!} GEOSR X-species : jgcho 2015.10.14 + + ! *** SAVE SEDIMENT DIAGENESIS RESULTS + IF(ISSDBIN.LT.0)THEN + OPEN(95,FILE='EE_SD.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + CLOSE(95,STATUS='DELETE') + OPEN(95,FILE='EE_SD.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=100 + WRITE(95)VER + WRITE(95)NACTIVE + CLOSE(95,STATUS='KEEP') + NSEDSTEPS=-1 + ENDIF + ENDIF + ELSEIF(JSEXPLORER.EQ.-1)THEN + ! *** FORCE ALL OUTPUT + NSEDSTEPS=32000 + ENDIF + MPI_WTIMES(992)=MPI_WTIMES(992)+MPI_TOC(S1TIME) + +C *** WRITE SNAPSHOT + S1TIME=MPI_TIC() + IF(ISDYNSTP.EQ.0)THEN + EETIME=DT*FLOAT(N)+TCON*TBEGIN + ELSE + EETIME=TIMESEC + ENDIF + IF(JSEXPLORER.EQ.1)EETIME=TCON*TBEGIN + EETIME=EETIME/86400. + + IF(ISSPH(8).GE.1.AND.MYRANK.EQ.0)THEN + OPEN(95,FILE='EE_WC.OUT',STATUS='OLD', + & POSITION='APPEND',FORM='UNFORMATTED') + WRITE(95)EETIME,NACTIVE + IF(.FALSE.)THEN + + DO L=2,LA + N1=KBT(L) + IF(ISTRAN(6).GT.0.OR.ISTRAN(7).GT.0)THEN + IF(ISBEDSTR.GE.1.AND.NSEDFLUME.EQ.0)THEN + WRITE(95)TAUBSED(L) + IF(ISBEDSTR.EQ.1)THEN + WRITE(95)TAUBSND(L) + ENDIF + ELSE + WRITE(95)TAUB(L) + ENDIF + ELSE + SHEAR=MAX(QQ(L,0),QQMIN)/CTURB2 + WRITE(95)SHEAR + ENDIF + IF(ISWAVE.GE.1)THEN + ! *** Shear due to Current Only + SHEAR = (RSSBCE(L)*TBX(L+1 )+RSSBCW(L)*TBX(L))**2 + & +(RSSBCN(L)*TBY(LNC(L))+RSSBCS(L)*TBY(L))**2 + SHEAR=0.5*SQRT(SHEAR) + WRITE(95)SHEAR + IF(ISWAVE.EQ.3)THEN + WRITE(95)WVWHA(L),WVFRQL(L),WACCWE(L) + ENDIF + ENDIF + IF(ISTRAN(1).EQ.1)WRITE(95)(SAL(L,K),K=1,KC) + IF(ISTRAN(2).EQ.1)THEN + WRITE(95)(TEM(L,K),K=1,KC) + IF(TBEDIT.GT.0.)WRITE(95)TEMB(L) + ENDIF + IF(ISTRAN(3).EQ.1)WRITE(95,ERR=999,IOSTAT=ISYS) + & (DYE(L,K),K=1,KC) + IF(ISTRAN(4).EQ.1)WRITE(95)(SFL(L,K),K=1,KC) + IF(ISTRAN(5).EQ.1)THEN + WRITE(95)(TOXB(L,N1,NT),NT=1,NTOX) + WRITE(95)((TOX(L,K,NT),K=1,KC),NT=1,NTOX) + ENDIF + IF(ISTRAN(6).EQ.1.OR.ISTRAN(7).GE.1)THEN + WRITE(95)N1,BELV(L),HBED(L,N1),BDENBED(L,N1),PORBED(L,N1) + IF(ISTRAN(6).EQ.1)THEN + WRITE(95)(SEDB(L,N1,NS),VFRBED(L,N1,NS),NS=1,NSED) + WRITE(95)((SED(L,K,NS),K=1,KC),NS=1,NSED) + ENDIF + IF(ISTRAN(7).EQ.1)THEN + WRITE(95)(SNDB(L,N1,NX),VFRBED(L,N1,NX+NSED),NX=1,NSND) + WRITE(95)((SND(L,K,NX),K=1,KC),NX=1,NSND) + IF(ISBDLDBC.GT.0)THEN + WRITE(95)(CQBEDLOADX(L,NX),CQBEDLOADY(L,NX),NX=1,NSND) + ENDIF + ENDIF + ENDIF + ENDDO + + ELSE + + IF(ISTRAN(6).GT.0.OR.ISTRAN(7).GT.0)THEN + IF(ISBEDSTR.GE.1.AND.NSEDFLUME.EQ.0)THEN + WRITE(95) TAUBSED + IF(ISBEDSTR.EQ.1)THEN + WRITE(95) TAUBSND + ENDIF + ELSE + WRITE(95) TAUB + ENDIF + ENDIF + + IF(ISWAVE.GE.1)THEN + DO L=2,LA + SHEAR_1D(L) = (RSSBCE(L)*TBX(L+1 )+RSSBCW(L)*TBX(L))**2 + & +(RSSBCN(L)*TBY(LNC(L))+RSSBCS(L)*TBY(L))**2 + SHEAR_1D(L)=0.5*SQRT(SHEAR_1D(L)) + ENDDO + WRITE(95) SHEAR_1D + IF(ISWAVE.EQ.3)THEN + WRITE(95) WVWHA + WRITE(95) WVFRQL + WRITE(95) WACCWE + ENDIF + ENDIF + + IF(ISTRAN(1).EQ.1) WRITE(95) SAL + IF(ISTRAN(2).EQ.1)THEN + WRITE(95) TEM + IF(TBEDIT.GT.0.) WRITE(95) TEMB + ENDIF + + IF(ISTRAN(3).EQ.1) WRITE(95) DYE + IF(ISTRAN(4).EQ.1) WRITE(95) SFL + IF(ISTRAN(5).EQ.1)THEN + WRITE(95) TOXB + WRITE(95) TOX + ENDIF + + IF(ISTRAN(6).EQ.1.OR.ISTRAN(7).GE.1)THEN + DO L=2,LA + N1=KBT(L) + N1_1D(L)=N1 + HBED_1D(L)=HBED(L,N1) + BDENBED_1D(L)=BDENBED(L,N1) + PORBED_1D(L)=PORBED(L,N1) + ENDDO + WRITE(95) N1_1D + WRITE(95) BELV + WRITE(95) HBED_1D + WRITE(95) BDENBED_1D + WRITE(95) PORBED_1D + + IF(ISTRAN(6).EQ.1)THEN + DO NS=1,NSED + DO L=2,LA + N1=KBT(L) + SEDB_1D(L,NS)=SEDB(L,N1,NS) + SED_VFRBED_1D(L,NS)=VFRBED(L,N1,NS) + ENDDO + ENDDO + WRITE(95) SEDB_1D + WRITE(95) SED_VFRBED_1D + WRITE(95) SED + ENDIF + + IF(ISTRAN(7).EQ.1)THEN + DO NX=1,NSND + DO L=2,LA + N1=KBT(L) + SNDB_1D(L,NX)=SNDB(L,N1,NX) + SND_VFRBED_1D(L,NX)=VFRBED(L,N1,NX+NSED) + ENDDO + ENDDO + WRITE(95) SNDB_1D + WRITE(95) SND_VFRBED_1D + WRITE(95) SND + IF(ISBDLDBC.GT.0)THEN + WRITE(95) CQBEDLOADX + WRITE(95) CQBEDLOADY + ENDIF + ENDIF + + ENDIF + + ENDIF + + CALL FLUSH(95) + CLOSE(95,STATUS='KEEP') + ENDIF + MPI_WTIMES(993)=MPI_WTIMES(993)+MPI_TOC(S1TIME) + + ! *** OUTPUT THE SEDZLJ VARIABLES + S1TIME=MPI_TIC() + IF(ISTRAN(6).GT.0.AND.NSEDFLUME.GT.0.AND.MYRANK.EQ.0)THEN + OPEN(95,FILE='EE_SEDZLJ.OUT',STATUS='OLD', + & POSITION='APPEND',FORM='UNFORMATTED') + + WRITE(95)EETIME,NACTIVE + + DO L=2,LA + WRITE(95) REAL(TAU(L)) !TAU(LCM) - Shear Stress in dynes/cm^2 + WRITE(95) REAL(D50AVG(L)) !D50AVG(LCM) - Average particle size of bed surface (microns) + WRITE(95) REAL(ETOTO(L)) !ETOTO(LCM) - Total erosion in the cell + DO NT=1,NSCM + WRITE(95) REAL(CBL(1,L,NT)) !CBL(NSCM,LCM) - This is the bedload concentration in g/cm^3 of each size class + WRITE(95) REAL(XBLFLUX(L,NT)) !XBLFLUX(LCM,NSCM) - Bedload flux in X direction (g/s) + WRITE(95) REAL(YBLFLUX(L,NT)) !YBLFLUX(LCM,NSCM) - Bedload flux in Y direction (g/s) + DO K=1,KB + WRITE(95) REAL(PER(NT,K,L)) !PER(NSCM,KB,LCM) - This is the mass percentage of each size class in a layer + ENDDO + ENDDO + DO K=1,KB + WRITE(95) LAYER(K,L) !LAYER(KB,LCM) - This is = 1 when a bed layer (KB index) exists with mass + WRITE(95) REAL(TSED(K,L)) !TSED(KB,LCM) - This is the mass in g/cm^2 in each layer + WRITE(95) REAL(BULKDENS(K,L)) !BULKDENS(KB,LCM) - Dry Bulk density of each layer (g/cm^3) + ENDDO + ENDDO + + IF(MYRANK.EQ.0) CALL FLUSH(95) + IF(MYRANK.EQ.0) CLOSE(95,STATUS='KEEP') + ENDIF + MPI_WTIMES(994)=MPI_WTIMES(994)+MPI_TOC(S1TIME) + +C *** NOW OUTPUT ALL THE BEDINFO TO A SINGLE FILE + S1TIME=MPI_TIC() + IF(ISBEXP.GE.1.AND.MYRANK.EQ.0)THEN + IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1.AND.KB.GT.1)THEN + OPEN(87,FILE='EE_BED.OUT',STATUS='UNKNOWN',POSITION='APPEND' + & ,FORM='UNFORMATTED') + WRITE(87)EETIME,NACTIVE + DO L=2,LA + WRITE(87)KBT(L) + ENDDO + DO L=2,LA + DO K=1,KB + WRITE(87)HBED(L,K),BDENBED(L,K),PORBED(L,K) + IF(ISTRAN(6).GE.1)THEN + DO NS=1,NSED + WRITE(87)SEDB(L,K,NS),VFRBED(L,K,NS) + ENDDO + ENDIF + IF(ISTRAN(7).GE.1)THEN + DO NX=1,NSND + NS=NSED+NX + WRITE(87)SNDB(L,K,NX),VFRBED(L,K,NS) + ENDDO + ENDIF + IF(ISTRAN(5).GE.1)THEN + DO NT=1,NTOX + WRITE(87)TOXB(L,K,NT) + ENDDO + ENDIF + ENDDO + ENDDO + CALL FLUSH(87) + CLOSE(87,STATUS='KEEP') + ENDIF + ENDIF + MPI_WTIMES(995)=MPI_WTIMES(995)+MPI_TOC(S1TIME) + +C *** INTERNAL ARRAYS + S1TIME=MPI_TIC() + IF(ISINWV.EQ.2.AND.JSEXPLORER.LE.0.AND.MYRANK.EQ.0)THEN + ZERO=0.0 + IF(N.LT.(2*NTSPTC/NPSPH(8)))THEN + OPEN(95,FILE='EE_ARRAYS.OUT',STATUS='UNKNOWN') + CLOSE(95,STATUS='DELETE') + OPEN(95,FILE='EE_ARRAYS.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=100 + WRITE(95)VER + WRITE(95)3 ! # OF TIME VARYING ARRAYS + + ! FLAGS: ARRAY TYPE, TIME VARIABLE + ! ARRAY TYPE: 0 = L DIM'D + ! 1 = L,KC DIM'D + ! 2 = L,0:KC DIM'D + ! 3 = L,KB DIM'D + ! 4 = L,KC,NCLASS DIM'D + ! TIME VARIABLE: 0 = NOT CHANGING + ! 1 = TIME VARYING + + !WRITE(95)0,0 + !ARRAYNAME='SUB' + !WRITE(95)ARRAYNAME + !DO L=2,LA + ! WRITE(95)SUB(L) + !ENDDO + + !WRITE(95)0,0 + !ARRAYNAME='SVB' + !WRITE(95)ARRAYNAME + !DO L=2,LA + ! WRITE(95)SVB(L) + !ENDDO + + WRITE(95)1,0 + ARRAYNAME='FXWAVE' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FXWAVE(L,K) + ENDDO + ENDDO + + WRITE(95)1,0 + ARRAYNAME='FYWAVE' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FYWAVE(L,K) + ENDDO + ENDDO + + ELSE + OPEN(95,FILE='EE_ARRAYS.OUT',STATUS='UNKNOWN', + & POSITION='APPEND',FORM='UNFORMATTED') + ENDIF + + IF(.TRUE.)THEN + + WRITE(95)1,1 + ARRAYNAME='AH' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)AH(L,K) + ENDDO + ENDDO + + WRITE(95)1,1 + ARRAYNAME='AV' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)(AV(L,K)*HP(L)) + ENDDO + ENDDO + + WRITE(95)2,1 + ARRAYNAME='QQ' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=0,KC + WRITE(95)QQ(L,K) + ENDDO + ENDDO + + IF(.FALSE.)THEN + ! *** FMDUX FMDUY FMDVY FMDVX + WRITE(95)1,1 + ARRAYNAME='FMDUX' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FMDUX(L,K) + ENDDO + ENDDO + + WRITE(95)1,1 + ARRAYNAME='FMDUY' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FMDUY(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='FMDVY' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FMDVY(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='FMDVX' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)FMDVX(L,K) + ENDDO + ENDDO + + WRITE(95)1,1 + ARRAYNAME='U' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)U(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='V' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)V(L,K) + ENDDO + ENDDO + + WRITE(95)0,1 + ARRAYNAME='UHDYE' + WRITE(95)ARRAYNAME + DO L=2,LA + WRITE(95)UHDYE(L) + ENDDO + + WRITE(95)0,1 + ARRAYNAME='VHDXE' + WRITE(95)ARRAYNAME + DO L=2,LA + WRITE(95)VHDXE(L) + ENDDO + + WRITE(95)0,1 + ARRAYNAME='FXE' + WRITE(95)ARRAYNAME + DO L=2,LA + TMPVAL=FXE(L)*DELT*DXIU(L) + WRITE(95)TMPVAL + ENDDO + + WRITE(95)0,1 + ARRAYNAME='FYE' + WRITE(95)ARRAYNAME + DO L=2,LA + TMPVAL=FYE(L)*DELT*DYIV(L) + WRITE(95)TMPVAL + ENDDO + + WRITE(95)0,1 + ARRAYNAME='FUHX' + WRITE(95)ARRAYNAME + DO L=2,LA + TMPVAL=AHC(L,1)*DELT*DXIU(L) + WRITE(95)TMPVAL + ENDDO + + WRITE(95)0,1 + ARRAYNAME='FVHY' + WRITE(95)ARRAYNAME + DO L=2,LA + TMPVAL=AHC(L,2)*DELT*DYIV(L) + WRITE(95)TMPVAL + ENDDO + + WRITE(95)1,1 + ARRAYNAME='FUHU' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)AHU(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='FVHU' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)AMCU(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='FVHV' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)AMCV(L,K) + ENDDO + ENDDO + WRITE(95)1,1 + ARRAYNAME='FUHV' + WRITE(95)ARRAYNAME + DO L=2,LA + DO K=1,KC + WRITE(95)AMSU(L,K) + ENDDO + ENDDO + + ENDIF + + !WRITE(95)0,1 + !ARRAYNAME='TATMT' + !WRITE(95)ARRAYNAME + !DO L=2,LA + ! WRITE(95)TATMT(L) + !ENDDO + ENDIF +C + CALL FLUSH(95) + CLOSE(95,STATUS='KEEP') + + ENDIF + MPI_WTIMES(996)=MPI_WTIMES(996)+MPI_TOC(S1TIME) + +C *** WATER QUALITY + IF(ISTRAN(8).GT.0.AND.MYRANK.EQ.0)THEN + ! 1) CHC - cyanobacteria + ! 2) CHD - diatom algae + ! 3) CHG - green algae + ! 4) ROC - refractory particulate organic carbon + ! 5) LOC - labile particulate organic carbon + ! 6) DOC - dissolved organic carbon + ! 7) ROP - refractory particulate organic phosphorus + ! 8) LOP - labile particulate organic phosphorus + ! 9) DOP - dissolved organic phosphorus + ! 10) P4D - total phosphate + ! 11) RON - refractory particulate organic nitrogen 22) macroalgae + ! 12) LON - labile particulate organic nitrogen + ! 13) DON - dissolved organic nitrogen + ! 14) NHX - ammonia nitrogen + ! 15) NOX - nitrate nitrogen + ! 16) SUU - particulate biogenic silica + ! 17) SAA - dissolved available silica + ! 18) COD - chemical oxygen demand + ! 19) DOX - dissolved oxygen + ! 20) TAM - total active metal + ! 21) FCB - fecal coliform bacteria + S1TIME=MPI_TIC() + OPEN(95,FILE='EE_WQ.OUT',STATUS='UNKNOWN',POSITION='APPEND', + & FORM='UNFORMATTED') + WRITE(95)EETIME + IF(.FALSE.)THEN + DO L=2,LA + DO K=1,KC + DO NW=1,NWQV + IF(IWQ(NW).GT.0)THEN + WQ=WQV(L,K,NW) + WRITE(95)WQ + ENDIF + ENDDO + ENDDO + ENDDO + ELSE + DO NW=1,NWQV + IF(IWQ(NW).GT.0)THEN + WRITE(95) WQV(:,:,NW) + ENDIF + ENDDO + ENDIF + CALL FLUSH(95) + CLOSE(95,STATUS='KEEP') + MPI_WTIMES(997)=MPI_WTIMES(997)+MPI_TOC(S1TIME) +!{ GEOSR X-species : jgcho 2015.10.14 + S1TIME=MPI_TIC() + if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 + OPEN(95,FILE='EE_WQX.OUT',STATUS='UNKNOWN',POSITION='APPEND', + & FORM='UNFORMATTED') + WRITE(95)EETIME,N + IF(.FALSE.)THEN + DO NSP=1,NXSP + DO K=1,KC + DO L=2,LA + WQ=WQVX(L,K,NSP) + WRITE(95)WQ + ENDDO + ENDDO + ENDDO + ELSE + DO NSP=1,NXSP + WRITE(95) WQVX(:,:,NSP) + ENDDO + ENDIF + CALL FLUSH(95) + CLOSE(95,STATUS='KEEP') + endif !if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 + MPI_WTIMES(998)=MPI_WTIMES(998)+MPI_TOC(S1TIME) +!} GEOSR X-species : jgcho 2015.09.18 + ! *** SAVE SEDIMENT DIAGENESIS RESULTS + S1TIME=MPI_TIC() + IF(IWQBEN.GT.0.AND.ISSDBIN.LT.0)THEN + ! *** IF JSEXPLORER=1 THEN WRITE THE ARRAYS (I.E. IC'S) + NSEDSTEPS=NSEDSTEPS+1 + IF(NSEDSTEPS.GE.ABS(ISSDBIN).OR.JSEXPLORER.EQ.1)THEN + OPEN(95,FILE='EE_SD.OUT',STATUS='UNKNOWN',POSITION='APPEND', + & FORM='UNFORMATTED') + WRITE(95)EETIME + DO L=2,LA + + ! SMPON = Conc. Particulate Org. Nitrogen in G-class 1, 2 & 3 (g/m3) dim(LA,NSMGM) + ! SMPOP = Conc. Particulate Org. Phosphorus in G-class 1, 2 & 3 (g/m3) dim(LA,NSMGM) + ! SMPOC = Conc. Particulate Org. Carbon in G-class 1, 2 & 3 (g/m3) dim(LA,NSMGM) + + ! *** DEPOSITION FLUXES + ! SMDFN(LL,?) = Sediment Flux To The Sediment Bed From PON Into G1, G2, & G3 + ! SMDFP(LL,?) = Sediment Flux To The Sediment Bed From POP Into G1, G2, & G3 + ! SMDFC(LL,?) = Sediment Flux To The Sediment Bed From POC Into G1, G2, & G3 + + ! SM1NH4 = Conc. NH4-N in layer 1 (g/m3) dim(LA) + ! SM2NH4 = Conc. NH4-N in layer 2 (g/m3) + ! SM1NO3 = Conc. NO3-N in layer 1 (g/m3) + ! SM2NO3 = Conc. NO3-N in layer 2 (g/m3) + ! SM1PO4 = Conc. PO4-P in layer 1 (g/m3) + ! SM2PO4 = Conc. PO4-P in layer 2 (g/m3) + ! SM1H2S = Conc. Sulfide (H2S) in layer 1 (g/m3) + ! SM2H2S = Conc. Sulfide (H2S) in layer 2 (g/m3) + ! SMPSI = Conc. Particulate biogenic silica in layer 2 (g/m3) + ! SM1SI = Conc. Dissolved available silica in layer 1 (g/m3) + ! SM2SI = Conc. Dissolved available silica in layer 2 (g/m3) + ! SMBST = Accumulated benthic stress (days) + ! SMT = Sediment temperature (degC) + + ! *** SEDIMENT OXYGEN DEMANDS + ! SMCSOD = CARBONACEOUS SOD + ! SMNSOD = NITROGENOUS SOD + + ! *** BENTHIC FLUXES + ! WQBFNH4 = AMMONIUM FLUX + ! WQBFNO3 = NITRATE FLUX + ! WQBFO2 = O2 SEDIMENT FLUX (SOD) + ! WQBFCOD = COD FLUX + ! WQBFPO4D = PO4 FLUX + ! WQBFSAD = SILICA FLUX + + WRITE(95)(SMPON(L,K),K=1,3) + WRITE(95)(SMPOP(L,K),K=1,3) + WRITE(95)(SMPOC(L,K),K=1,3) + WRITE(95)(SMDFN(L,K),K=1,3) + WRITE(95)(SMDFP(L,K),K=1,3) + WRITE(95)(SMDFC(L,K),K=1,3) + WRITE(95)SM1NH4(L),SM2NH4(L) + WRITE(95)SM1NO3(L),SM2NO3(L) + WRITE(95)SM1PO4(L),SM2PO4(L) + WRITE(95)SM1H2S(L),SM2H2S(L) + WRITE(95)SM1SI(L), SM2SI(L) + WRITE(95)SMPSI(L) + WRITE(95)SMBST(L),SMT(L) + WRITE(95)SMCSOD(L),SMNSOD(L) + WRITE(95)WQBFNH4(L),WQBFNO3(L),WQBFO2(L),WQBFCOD(L), + & WQBFPO4D(L),WQBFSAD(L) + ENDDO + CALL FLUSH(95) + CLOSE(95,STATUS='KEEP') + NSEDSTEPS=0 + ENDIF + ENDIF + ENDIF + MPI_WTIMES(999)=MPI_WTIMES(999)+MPI_TOC(S1TIME) + + RETURN + + 999 STOP ' Error writing SNAPSHOT file' + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/FSBDLD.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/FSBDLD.for index b5681fa97..f02340142 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/FSBDLD.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/FSBDLD.for @@ -8,6 +8,7 @@ C C ** CALCULATES DIMNSIONLESS BED LOAD TRANSPORT COEFFICIENT C ** ISOPT=0 USE CONSTANT VALUE C + FSBDLD=0.0 IF(ISOPT.EQ.0) FSBDLD=SBDLDP C C ** ISOPT=1 BASED ON diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/GATECTLREAD.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/GATECTLREAD.for index 6c5361a17..a7ccd6ae0 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/GATECTLREAD.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/GATECTLREAD.for @@ -8,7 +8,7 @@ C ** READ FROM GATECTL.INP FILE C ** GATE INFORMATION AND CONTROL ENVIROMENT C USE GLOBAL - + USE MPI CHARACTER*3 NCARD ! { GEOSR ESTURAY DIKE : JGCHO 2010.11.16 REAL JULDAY,AJULDAY(NGTYPES),YEARTMP @@ -24,16 +24,16 @@ C GC1** NUMBER OF GATE TYPE NCARD='1' CALL SEEK('GC1') READ(1,*,ERR=1000) NGTYPES,GARTM,IWSYS - WRITE(7,1002)NCARD - WRITE(7,*) NGTYPES,GARTM,IWSYS + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) NGTYPES,GARTM,IWSYS C C GC2** READ GATE INFORMATION 1 NCARD='2' CALL SEEK('GC2') DO L=1,NQCTL READ(1,*,ERR=1000) NGATEM(L),NGATEC(L),NGTYP(L) - WRITE(7,1002)NCARD - WRITE(7,*) NGATEM(L),NGATEC(L),NGTYP(L) + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) NGATEM(L),NGATEC(L),NGTYP(L) !NGATE(L),NGATEC(L),NGTYP(L) ENDDO C C GC3** READ GATE INFORMATION 2 @@ -43,8 +43,8 @@ C GC3** READ GATE INFORMATION 2 READ(1,*,ERR=1000) SILL(L),SILLHH(L),GATEHI(L),GATEHO(L) & ,GATEWI(L),GATEWO(L),MAXQ(L) & ,GOTIME(L),GCTIME(L),IATS(L) - WRITE(7,1002)NCARD - WRITE(7,*) SILL(L),SILLHH(L),GATEHI(L),GATEHO(L) + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) SILL(L),SILLHH(L),GATEHI(L),GATEHO(L) & ,GATEWI(L),GATEWO(L),MAXQ(L),GOTIME(L),GCTIME(L) & ,IATS(L) ENDDO @@ -55,9 +55,9 @@ C GC4** READ FLOW CONSTANT DO L=1,NGTYPES READ(1,*,ERR=1000) CGH1(L),CGH2(L),CG1(L),CG2(L),CG3(L),CG4(L) !ung 20141108 & ,CG5(L),CG6(L),CG7(L),CG8(L),NCG3FOM(L) !ung 20141108 - WRITE(7,1002)NCARD - WRITE(7,*) CGH1(L),CGH2(L),CG1(L),CG2(L),CG3(L),CG4(L) !ung 20141108 - & ,CG5(L),CG6(L),CG7(L),CG8(L),NCG3FOM(L),L !ung 20141108 + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) CGH1(L),CGH2(L),CG1(L),CG2(L), !ung 20141108 + & CG5(L),CG6(L),CG7(L),CG8(L),NCG3FOM(L),L !ung 20141108 ENDDO C C GC5** READ GATE CONTROL @@ -66,8 +66,8 @@ C GC5** READ GATE CONTROL DO L=1,NGTYPES READ(1,*,ERR=1000) DELHINOUT(L),DELHSEL1(L) & ,DUM,DUM,TIDCHK(L) - WRITE(7,1002)NCARD - WRITE(7,*) DELHINOUT(L),DELHSEL1(L),DUM,DUM + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) DELHINOUT(L),DELHSEL1(L),DUM,DUM ! SEL1, 2(L) -> DUM & ,TIDCHK(L),L ENDDO C @@ -76,8 +76,8 @@ C GC6** NUMBER OF SURFACE LEVEL COMPARE CELL CALL SEEK('GC6') DO L=1,NGTYPES READ(1,*,ERR=1000) NICMP(L),NOCMP(L) - WRITE(7,1002)NCARD - WRITE(7,*) NICMP(L),NOCMP(L),L + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) NICMP(L),NOCMP(L),L ENDDO C C GC7** CELL INDEX OF UPSTREAM @@ -86,8 +86,8 @@ C GC7** CELL INDEX OF UPSTREAM DO L=1,NGTYPES DO LL=1,NICMP(L) READ(1,*,ERR=1000) ICMPI(LL,L),JCMPI(LL,L) - WRITE(7,1002)NCARD - WRITE(7,*) ICMPI(LL,L),JCMPI(LL,L),L + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) ICMPI(LL,L),JCMPI(LL,L),L ENDDO ENDDO C @@ -97,8 +97,8 @@ C GC8** CELL INDEX OF DOWNSTREAM DO L=1,NGTYPES DO LL=1,NOCMP(L) READ(1,*,ERR=1000) ICMPO(LL,L),JCMPO(LL,L) - WRITE(7,1002)NCARD - WRITE(7,*) ICMPO(LL,L),JCMPO(LL,L),L + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) ICMPO(LL,L),JCMPO(LL,L),L ENDDO ENDDO ! { GEOSR ESTURAY DIKE : JGCHO 2010.11.15 @@ -108,8 +108,8 @@ C GC9** CONSIDER ESTUARY DIKE OUTER TIDE START TIME CALL SEEK('GC9') DO L=1,NGTYPES READ(1,*,ERR=1000) IGYY(L),IGMM(L),IGDD(L),CLOC(L) - WRITE(7,1002)NCARD - WRITE(7,*) IGYY(L),IGMM(L),IGDD(L),CLOC(L),L + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) IGYY(L),IGMM(L),IGDD(L),CLOC(L),L ENDDO ! } GEOSR ESTURAY DIKE : JGCHO 2010.11.15 C @@ -117,8 +117,8 @@ C GC10** GATE FLUX MONITORING NCARD='10' CALL SEEK('GC10') READ(1,*,ERR=1000) ISINK,DTSNK - WRITE(7,1002)NCARD - WRITE(7,*) ISINK,DTSNK + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) ISINK,DTSNK C CLOSE(1) C @@ -156,9 +156,11 @@ C ELSE YEARTMP=NINT(YEARTMP)*10. ENDIF + IF(MYRANK.EQ.0) THEN WRITE(FNTIDE,'(A,I4.4,A)') TRIM(CLOC(L)),INT(YEARTMP),'.INP' WRITE(*,*) 'READING PREDICTION TIDE DATA : ', TRIM(FNTIDE) WRITE(7,*) 'READING PREDICTION TIDE DATA : ', TRIM(FNTIDE) + ENDIF NTIDE=0 OPEN(1,FILE=TRIM(FNTIDE)) @@ -174,7 +176,8 @@ C ENDIF ! } GEOSR ESTURAY DIKE, READ DATE : JGCHO 2010.11.26 ESTIDE(L,NTIDE)=TIDETMP - WRITE(7,*) ESTIME(L,NTIDE),ESTIDE(L,NTIDE),IY,ID,HH + IF(MYRANK.EQ.0) WRITE(7,*) ESTIME(L,NTIDE), + & ESTIDE(L,NTIDE),IY,ID,HH IF (NTIDE .EQ. (NTC+1)*24+1) THEN CLOSE(1) GOTO 7003 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT.for index f659ed1dc..5afc00b38 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT.for @@ -28,21 +28,20 @@ C INTEGER::IMIN,JMIN,KMIN,NMD,ITMP,ICALLTP,LS INTEGER::IPLTTMP,NRESTO,ISSREST,IRRMIN,ILOGC INTEGER::LN,LNW,LSE,LF,LL,LSW - INTEGER::I1,I2 - REAL::T1TMP,SALMIN,HPPTMP,WTM,WTMP + REAL::T1TMP,T2TMP,SALMIN,HPPTMP,WTM,WTMP REAL::DELVOL,SALMAX,TAUB2,DELTD2,DZDDELT,TTMP REAL::TAUBC,TAUBC2,UTMP,VTMP,CURANG REAL::CTIM INTRINSIC ISNAN LOGICAL ISNAN - INTEGER::ithds - - REAL :: SECNDS ! { GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 INTEGER ISHYD,IHYDCNT REAL SNAPSHOTHYD + SNAPSHOTHYD=0.0 + IHYDCNT=0 + LN=0 ! } GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 ![ykchoi 10.04.26 for linux version @@ -467,7 +466,7 @@ C**********************************************************************C C C ** CALCULATE VERTICAL VISCOSITY AND DIFFUSIVITY AT TIME LEVEL (N) C - T1TMP=SECNDS(0.0) + CALL CPU_TIME(T1TMP) IF(KC.GT.1)THEN IF(ISQQ.EQ.1)THEN IF(ISTOPT(0).EQ.0)CALL CALAVBOLD (ISTL) @@ -475,7 +474,8 @@ C ENDIF IF(ISQQ.EQ.2) CALL CALAVB2 (ISTL) ENDIF - TAVB=TAVB+SECNDS(T1TMP) + CALL CPU_TIME(T2TMP) + TAVB=TAVB+T2TMP-T1TMP C C**********************************************************************C C @@ -492,7 +492,7 @@ C**********************************************************************C C C ** CALCULATE EXPLICIT MOMENTUM EQUATION TERMS C - T1TMP=SECNDS(0.0) + CALL CPU_TIME(T1TMP) C C NOTES ON VARIOUS VERSIONS OF CALEXP C @@ -538,7 +538,8 @@ C PMC IF(ISCDMA.EQ.5) CALL CALEXP2 (ISTL) C PMC IF(ISCDMA.EQ.6) CALL CALEXP2 (ISTL) C PMC IF(ISCDMA.EQ.9) CALL CALEXP9 (ISTL) C - TCEXP=TCEXP+SECNDS(T1TMP) + CALL CPU_TIME(T2TMP) + TCEXP=TCEXP+T2TMP-T1TMP C C**********************************************************************C C @@ -555,7 +556,7 @@ C**********************************************************************C C C ** SOLVE EXTERNAL MODE EQUATIONS FOR P, UHDYE, AND VHDXE C - T1TMP=SECNDS(0.0) + CALL CPU_TIME(T1TMP) C C NOTES ON VARIOUS VERSIONS OF CALPUV C @@ -629,9 +630,10 @@ CX IF(ISDRY.EQ.3.OR.ISDRY.EQ.4) CALL CALPUV6(ISTL) !7 MOVED TO 8 C IF(ISDRY.EQ.3.OR.ISDRY.EQ.4) CALL CALPUV8(ISTL) CJH ENDIF C - 5555 CONTINUE +C5555 CONTINUE C - TPUV=TPUV+SECNDS(T1TMP) + CALL CPU_TIME(T2TMP) + TPUV=TPUV+T2TMP-T1TMP C C**********************************************************************C C @@ -716,7 +718,7 @@ C ** SOLVE INTERNAL SHEAR MODE EQUATIONS FOR U, UHDY, V, VHDX, AND W C C----------------------------------------------------------------------C C - T1TMP=SECNDS(0.0) + CALL CPU_TIME(T1TMP) IF(KC.GT.1)THEN CALL CALUVW (ISTL,IS2TL) ELSE @@ -733,7 +735,8 @@ C ENDDO CALL CALUVW (ISTL,IS2TL) ENDIF - TUVW=TUVW+SECNDS(T1TMP) + CALL CPU_TIME(T2TMP) + TUVW=TUVW+T2TMP-T1TMP C C**********************************************************************C C @@ -1048,15 +1051,7 @@ C ENDIF C IF(BSC.GT.1.E-6)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - CALL CALBUOY(LF,LL) -c - enddo - + CALL CALBUOY ELSE DO K=1,KC DO L=2,LA @@ -1269,7 +1264,7 @@ C**********************************************************************C C C ** CALCULATE TURBULENT INTENSITY SQUARED C - T1TMP=SECNDS(0.0) + CALL CPU_TIME(T1TMP) IF(KC.GT.1)THEN IF(ISQQ.EQ.1)THEN IF(ISTOPT(0).EQ.0)CALL CALQQ1OLD (ISTL) @@ -1277,7 +1272,8 @@ C ENDIF IF(ISQQ.EQ.2) CALL CALQQ2 (ISTL) ENDIF - TQQQ=TQQQ+SECNDS(T1TMP) + CALL CPU_TIME(T2TMP) + TQQQ=TQQQ+T2TMP-T1TMP C C**********************************************************************C C @@ -1409,22 +1405,23 @@ C !{GEOSR, OIL, CWCHO, 101122 IF(ISPD.GE.2.AND.IDTOX.LT.4440) THEN IF (TIMEDAY.GE.LA_BEGTI.AND.TIMEDAY.LE.LA_ENDTI) THEN - T1TMP=SECNDS(0.0) + CALL CPU_TIME(T1TMP) CALL DRIFTERC - TLRPD=TLRPD+SECNDS(T1TMP) + CALL CPU_TIME(T2TMP) + TLRPD=TLRPD+T2TMP-T1TMP ENDIF ENDIF !} ! IF(ISLRPD.GE.1)THEN -! T1TMP=SECNDS(0.0) +! CALL CPU_TIME(T1TMP) ! IF(ISLRPD.LE.2)THEN ! IF(N.GE.NLRPDRT(1)) CALL LAGRES ! ENDIF ! IF(ISLRPD.GE.3)THEN ! IF(N.GE.NLRPDRT(1)) CALL GLMRES ! ENDIF -! TLRPD=TLRPD+SECNDS(T1TMP) +! TLRPD=TLRPD+T1TMP-SECOND() ! ENDIF C C**********************************************************************C @@ -1642,7 +1639,7 @@ C ENDIF IF(TIMEDAY.GE.SNAPSHOTHYD) THEN ! WRITE(*,*)'WRITE================',N,TIMEDAY,TIMEDAY*1440. - CALL RESTOUT(-21) +! CALL RESTOUT(-21) IHYDCNT=IHYDCNT+1 SNAPSHOTHYD=FLOAT(ISHYD*IHYDCNT)*60./86400.+TBEGIN ENDIF @@ -1687,11 +1684,11 @@ C**********************************************************************C C C ** TIME LOOP COMPLETED C - 1001 THDMT=THDMT+SECNDS(TTMP) +C1001 THDMT=THDMT+TTMP-SECOND() C C**********************************************************************C C - 2000 CONTINUE +C2000 CONTINUE C C**********************************************************************C C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT2T.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT2T.for index b93454402..55b5cd256 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT2T.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT2T.for @@ -25,12 +25,12 @@ C USE GLOBAL USE DRIFTER USE WINDWAVE ,ONLY:WINDWAVEINIT,WINDWAVETUR + USE MPI INTRINSIC ISNAN LOGICAL ISNAN - REAL TTMP, T1TMP, TMP, SECNDS + REAL TTMP, T1TMP, TMP, T2TMP - INTEGER::I1,I2 INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::ISSBCP LOGICAL BTEST, LTEST @@ -43,7 +43,15 @@ C ! { GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 INTEGER ISHYD,IHYDCNT + INTEGER NTMPVAL + INTEGER ISAVESEDDT + INTEGER LN REAL SNAPSHOTHYD + SNAPSHOTHYD=0.0 + NTMPVAL=0 + IHYDCNT=0 + ISAVESEDDT=0 + LN=0 ! } GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 C ![ykchoi 10.04.26 for linux version @@ -73,13 +81,15 @@ C LCORNSN=0 ENDIF C - TTMP=SECNDS(0.0) + CALL CPU_TIME(TTMP) ICALLTP=0 C ISTL=2 FOURDPI=4./PI ISTL=2 IS2TL=1 + MPI_WTIMES=0 + CALL MPI_INITIALIZE C C**********************************************************************C C @@ -315,7 +325,7 @@ C----------------------------------------------------------------------c C IF(ISCORTBC.GE.1) THEN C - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN IF(ISCORTBCD.GE.1)THEN OPEN(1,FILE='ADJSTRESSE.OUT') CLOSE(1,STATUS='DELETE') @@ -489,6 +499,9 @@ C 1001 CONTINUE IF(N.GE.NTS)GO TO 1000 C +C ITERATION START + TTIME=MPI_TIC() + STIME=MPI_TIC() IF(ISDYNSTP.EQ.0)THEN N=N+1 ETIMESEC=DT*FLOAT(N) @@ -517,10 +530,9 @@ C TIMESEC=(DT*FLOAT(N)+TCON*TBEGIN) TIMEDAY=(DT*FLOAT(N)+TCON*TBEGIN)/86400. ENDIF - PRINT*, "TIME: ", TIMEDAY C C PMC IF(ILOGC.EQ.NTSMMT)THEN - IF(ILOGC.EQ.NTSPTC)THEN + IF(ILOGC.EQ.NTSPTC.AND.MYRANK.EQ.0)THEN CLOSE(8,STATUS='DELETE') OPEN(8,FILE='EFDCLOG.OUT',STATUS='UNKNOWN') IF(DEBUG)THEN @@ -583,6 +595,9 @@ C GP=GPO ENDIF C + MPI_WTIMES(2)=MPI_WTIMES(2)+MPI_TOC(STIME) + STIME=MPI_TIC() +C C----------------------------------------------------------------------C C C ** INITIALIZE TWO-TIME LEVEL BALANCES @@ -593,17 +608,20 @@ C ENDIF ENDIF C + MPI_WTIMES(3)=MPI_WTIMES(3)+MPI_TOC(STIME) +C C----------------------------------------------------------------------C C C ** REENTER HERE FOR TWO TIME LEVEL LOOP C - 500 CONTINUE +C 500 CONTINUE C C**********************************************************************C C C ** CALCULATE VERTICAL VISCOSITY AND DIFFUSIVITY AT TIME LEVEL (N) C - T1TMP=SECNDS(0.0) + STIME=MPI_TIC() !!### WT_CALAVB +C CALL CPU_TIME(T1TMP) IF(KC.GT.1)THEN IF(ISQQ.EQ.1)THEN IF(ISTOPT(0).EQ.0)CALL CALAVBOLD (ISTL) @@ -611,16 +629,18 @@ C ENDIF IF(ISQQ.EQ.2) CALL CALAVB2 (ISTL) ENDIF - TAVB=TAVB+SECNDS(T1TMP) +C TAVB=TAVB+T1TMP-SECOND() + MPI_WTIMES(4)=MPI_WTIMES(4)+MPI_TOC(STIME) C C**********************************************************************C C C ** CALCULATE WAVE BOUNDARY LAYER AND WAVE REYNOLDS STRESS FORCINGS C + STIME=MPI_TIC() IF(ISWAVE.EQ.1) CALL WAVEBL IF(ISWAVE.EQ.2) CALL WAVESXY IF(ISWAVE.EQ.3.AND.NWSER > 0) CALL WINDWAVETUR !DHC NEXT CALL - + MPI_WTIMES(5)=MPI_WTIMES(5)+MPI_TOC(STIME) C C**********************************************************************C C @@ -629,43 +649,46 @@ C ** STRESSES *** DSLLC MOVED C C----------------------------------------------------------------------C C + STIME=MPI_TIC() !!### WT_CALTSXY CALL CALTSXY + MPI_WTIMES(6)=MPI_WTIMES(6)+MPI_TOC(STIME) C C**********************************************************************C C C ** CALCULATE EXPLICIT MOMENTUM EQUATION TERMS C - T1TMP=SECNDS(0.0) -c IF(IS2TIM.EQ.1) CALL CALEXP2T - IF(IS2TIM.EQ.1) THEN - IF(IDRYTBP.EQ.0)THEN - CALL CALEXP2T0 - ELSE - CALL CALEXP2T - ENDIF - ENDIF + STIME=MPI_TIC() !!### WT_CALEXP2T +C CALL CPU_TIME(T1TMP) + IF(IS2TIM.EQ.1.AND.N.EQ.1) PRINT*, 'RUN CALEXP2T' + IF(IS2TIM.EQ.2.AND.N.EQ.1) PRINT*, 'RUN CALIMP2T' + IF(IS2TIM.EQ.1) CALL CALEXP2T IF(IS2TIM.EQ.2) CALL CALIMP2T - TCEXP=TCEXP+SECNDS(T1TMP) +C TCEXP=TCEXP+T1TMP-SECOND() + MPI_WTIMES(7)=MPI_WTIMES(7)+MPI_TOC(STIME) C C**********************************************************************C C C ** UPDATE TIME VARIABLE VOLUME SOURCES AND SINKS, CONCENTRATIONS, C ** VEGETATION CHARACTERISTICS AND SURFACE ELEVATIONS C + STIME=MPI_TIC() !!### WT_CALCSER CALL CALCSER (ISTL) CALL CALVEGSER (ISTL) CALL CALQVS (ISTL) PSERT(0)=0. IF(NPSER.GE.1) CALL CALPSER (ISTL) + MPI_WTIMES(8)=MPI_WTIMES(8)+MPI_TOC(STIME) C C**********************************************************************C C C ** SOLVE EXTERNAL MODE EQUATIONS FOR P, UHDYE, AND VHDXE C - T1TMP=SECNDS(0.0) + STIME=MPI_TIC() !!### WT_CALPUV2C +C CALL CPU_TIME(T1TMP) IF(ISCHAN.EQ.0.AND.ISDRY.EQ.0) CALL CALPUV2T IF(ISCHAN.GE.1.OR.ISDRY.GE.1) CALL CALPUV2C - TPUV=TPUV+SECNDS(T1TMP) +C TPUV=TPUV+T1TMP-SECOND() + MPI_WTIMES(9)=MPI_WTIMES(9)+MPI_TOC(STIME) C C**********************************************************************C C @@ -694,14 +717,9 @@ C ** ADVANCE INTERNAL VARIABLES C C----------------------------------------------------------------------C C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) - !print*, lf, ll, omp_get_thread_num(), omp_get_num_threads() -c + STIME=MPI_TIC() !!### WT_ADVANCE DO K=1,KC - DO L=LF,LL + DO L=2,LA UHDY2(L,K)=UHDY1(L,K) UHDY1(L,K)=UHDY(L,K) VHDX2(L,K)=VHDX1(L,K) @@ -714,8 +732,7 @@ c W1(L,K)=W(L,K) ENDDO ENDDO -c - enddo + MPI_WTIMES(10)=MPI_WTIMES(10)+MPI_TOC(STIME) C C**********************************************************************C C @@ -723,7 +740,8 @@ C ** SOLVE INTERNAL SHEAR MODE EQUATIONS FOR U, UHDY, V, VHDX, AND W C C----------------------------------------------------------------------C C - T1TMP=SECNDS(0.0) + STIME=MPI_TIC() !!### WT_CALUVW +C CALL CPU_TIME(T1TMP) IF(KC.GT.1)THEN CALL CALUVW (ISTL,IS2TL) ELSE @@ -736,7 +754,8 @@ C ENDDO CALL CALUVW (ISTL,IS2TL) ENDIF - TUVW=TUVW+SECNDS(T1TMP) +C TUVW=TUVW+T1TMP-SECOND() + MPI_WTIMES(11)=MPI_WTIMES(11)+MPI_TOC(STIME) C C**********************************************************************C C @@ -745,63 +764,69 @@ C ** AT TIME LEVEL (N+1) C C----------------------------------------------------------------------C C + STIME=MPI_TIC() !!### WT_CALCONC CALL CALCONC (ISTL,IS2TL) + MPI_WTIMES(12)=MPI_WTIMES(12)+MPI_TOC(STIME) C C----------------------------------------------------------------------C +C + STIME=MPI_TIC() !!### WT_PMC C ! *** PMC BYPASS IF NOT SIMULATING SEDIMENTS IF(ISTRAN(6).GT.0.OR.ISTRAN(7).GT.0)THEN -!$OMP PARALLEL DO PRIVATE(LF,LL,SEDBT0,SNDBT0,SEDT0,SNDT0) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c DO K=1,KB - DO L=LF,LL + DO L=1,LC SEDBT(L,K)=0. SNDBT(L,K)=0. ENDDO ENDDO +C + DO NS=1,NSED + DO K=1,KB + DO L=1,LC + SEDBT(L,K)=SEDBT(L,K)+SEDB(L,K,NS) + ENDDO + ENDDO + ENDDO +C + DO NS=1,NSND + DO K=1,KB + DO L=1,LC + SNDBT(L,K)=SNDBT(L,K)+SNDB(L,K,NS) + ENDDO + ENDDO + ENDDO +C DO K=1,KC - DO L=LF,LL + DO L=1,LC SEDT(L,K)=0. SNDT(L,K)=0. ENDDO ENDDO C DO NS=1,NSED - DO K=1,KB - DO L=LF,LL - SEDBT(L,K)=SEDBT(L,K)+SEDB(L,K,NS) - ENDDO - ENDDO DO K=1,KC - DO L=LF,LL + DO L=1,LC SEDT(L,K)=SEDT(L,K)+SED(L,K,NS) ENDDO ENDDO ENDDO C DO NS=1,NSND - DO K=1,KB - DO L=LF,LL - SNDBT(L,K)=SNDBT(L,K)+SNDB(L,K,NS) - ENDDO - ENDDO DO K=1,KC - DO L=LF,LL + DO L=1,LC SNDT(L,K)=SNDT(L,K)+SND(L,K,NS) ENDDO ENDDO ENDDO - -c - enddo ENDIF C + MPI_WTIMES(13)=MPI_WTIMES(13)+MPI_TOC(STIME) C----------------------------------------------------------------------C C C ** CHECK RANGE OF SALINITY AND DYE CONCENTRATION +C + STIME=MPI_TIC() C IF(ISMMC.EQ.1)THEN C @@ -905,6 +930,8 @@ C C ENDIF C + MPI_WTIMES(14)=MPI_WTIMES(14)+MPI_TOC(STIME) +C 6001 FORMAT(' N=',I10) 6002 FORMAT(' SALMAX=',F14.4,5X,'I,J,K=',(3I10)) 6003 FORMAT(' SALMIN=',F14.4,5X,'I,J,K=',(3I10)) @@ -915,8 +942,10 @@ C 6008 FORMAT(' TEMMAX=',F14.4,5X,'I,J,K=',(3I10)) 6009 FORMAT(' TEMMIN=',F14.4,5X,'I,J,K=',(3I10)) + STIME=MPI_TIC() !!### MPI_WRITE +C ! *** DSLLC - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN BTEST=.FALSE. LTEST=.FALSE. DO L=2,LA @@ -1106,6 +1135,8 @@ C 918 FORMAT('ERROR: TIME, L, I, J, K, NW, WQV = ',F10.5,5I6,2F10.4) ENDIF C + MPI_WTIMES(15)=MPI_WTIMES(15)+MPI_TOC(STIME) +C C**********************************************************************C C C ** CALCULATE SHELL FISH LARVAE AND/OR WATER QUALITY CONSTITUENT @@ -1113,6 +1144,8 @@ C ** CONCENTRATIONS AT TIME LEVEL (N+1) AFTER SETTING DOUBLE TIME C ** STEP TRANSPORT FIELD C C----------------------------------------------------------------------C +C + STIME=MPI_TIC() !!### WT_WQ3D C ITMP=0 IF(ISTRAN(4).GE.1) ITMP=1 @@ -1170,6 +1203,8 @@ C C C END ADD CHANNEL INTERACTIONS C + IF(ISTRAN(8).GE.1.AND.N.EQ.1) PRINT*,'RUN WQ3D',ISTL,IS2TL + IF(ISTRAN(4).GE.1.AND.N.EQ.1) PRINT*,'RUN CALSFT',ISTL,IS2TL IF(ISTRAN(8).GE.1) CALL WQ3D(ISTL,IS2TL) IF(ISTRAN(4).GE.1) CALL CALSFT(ISTL,IS2TL) C @@ -1179,34 +1214,23 @@ C C ENDIF C + MPI_WTIMES(16)=MPI_WTIMES(16)+MPI_TOC(STIME) +C C**********************************************************************C C C ** UPDATE BUOYANCY AND CALCULATE NEW BUOYANCY USING C ** AN EQUATION OF STATE C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c + STIME=MPI_TIC() !!### WT_CALBUOY +C DO K=1,KC - DO L=LF,LL + DO L=2,LA B1(L,K)=B(L,K) ENDDO ENDDO -c - enddo C IF(BSC.GT.1.E-6)THEN -c t01=rtc() -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - CALL CALBUOY(LF,LL) -c - enddo + CALL CALBUOY ELSE DO K=1,KC DO L=2,LA @@ -1215,25 +1239,24 @@ c ENDDO ENDIF C + MPI_WTIMES(17)=MPI_WTIMES(17)+MPI_TOC(STIME) C ** CALL TWO-TIME LEVEL BALANCES +C + STIME=MPI_TIC() C IF(ISBAL.GE.1)THEN CALL BAL2T4 ENDIF C + MPI_WTIMES(18)=MPI_WTIMES(18)+MPI_TOC(STIME) +C C**********************************************************************C C C ** CALCULATE U AT V AND V AT U AT TIME LEVEL (N+1) C C----------------------------------------------------------------------C C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& LN,LS,LNW,LSE,LSW) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA LN=LNC(L) LS=LSC(L) LNW=LNWC(L) @@ -1246,40 +1269,43 @@ c VU(L)=0.25*(HP(L-1)*(V(LNW,1)+V(L-1,1)) & +HP(L)*(V(LN,1)+V(L,1)))*HUI(L) ENDDO -c - enddo C + MPI_WTIMES(19)=MPI_WTIMES(19)+MPI_TOC(STIME) +C C**********************************************************************C C C ** CALCULATE HORIZONTAL VISCOSITY AND MOMENTUM DIFFUSION FLUXES C ** AT TIME LEVEL (N) +C + STIME=MPI_TIC() !!### WT_CALHDMF C IF(ISHDMF.GE.1) CALL CALHDMF C + MPI_WTIMES(20)=MPI_WTIMES(20)+MPI_TOC(STIME) +C C**********************************************************************C C C ** CALCULATE BOTTOM STRESS AT LEVEL (N+1) C - T1TMP=SECNDS(0.0) +C CALL CPU_TIME(T1TMP) + STIME=MPI_TIC() !!### WT_CALTBXY C CALL CALTBXY(ISTL,IS2TL) -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL +C + DO L=2,LA TBX(L)=(AVCON1*HUI(L)+STBX(L)*SQRT(VU(L)*VU(L) & +U(L,1)*U(L,1)))*U(L,1) TBY(L)=(AVCON1*HVI(L)+STBY(L)*SQRT(UV(L)*UV(L) & +V(L,1)*V(L,1)))*V(L,1) ENDDO -c - enddo C + MPI_WTIMES(21)=MPI_WTIMES(21)+MPI_TOC(STIME) +C C**********************************************************************C C C ** SET DEPTH DEVIATION FROM UNIFORM FLOW ON FLOW FACES +C + STIME=MPI_TIC() C IF(ISBSDFUF.GE.1)THEN HDFUFM=1.E-12 @@ -1307,31 +1333,31 @@ C C ENDIF C + MPI_WTIMES(22)=MPI_WTIMES(22)+MPI_TOC(STIME) +C C**********************************************************************C C C ** SET BOTTOM AND SURFACE TURBULENT INTENSITY SQUARED AT (N+1) C C----------------------------------------------------------------------C C - IF(ISWAVE.EQ.0)THEN +C + IF(ISWAVE.EQ.0)THEN !!### WT_QQSQR +C + STIME=MPI_TIC() C C----------------------------------------------------------------------c C IF(ISCORTBC.EQ.0) THEN C -!$OMP PARALLEL DO PRIVATE(LF,LL, -!$OMP& TMP) - do ithds=0,nthds-1 - LF=jse(1,ithds) - LL=jse(2,ithds) -c - DO L=LF,LL + DO L=2,LA TVAR3S(L)=TSY(LNC(L)) TVAR3W(L)=TSX(L+1) TVAR3E(L)=TBX(L+1 ) TVAR3N(L)=TBY(LNC(L)) -c ENDDO + ENDDO C + DO L=2 ,LA ! { GEOSR (IBM request) IF (ISNAN(TVAR3S(L))) TVAR3S(L)=0. IF (ISNAN(TVAR3W(L))) TVAR3W(L)=0. @@ -1352,12 +1378,14 @@ C QQSQR(L,0)=SQRT(QQ(L,0)) ! *** DSLLC ENDDO -c - enddo C ENDIF C + MPI_WTIMES(23)=MPI_WTIMES(23)+MPI_TOC(STIME) +C C----------------------------------------------------------------------c +C + STIME=MPI_TIC() C IF(ISCORTBC.GE.1) THEN C @@ -1484,12 +1512,14 @@ C C C----------------------------------------------------------------------c C + MPI_WTIMES(25)=MPI_WTIMES(25)+MPI_TOC(STIME) +C ENDIF C 3678 FORMAT(2I6,4F13.3) - 3679 FORMAT(12x,4F13.3) - 3680 FORMAT(12x,6F13.5) - 3681 FORMAT(12X,5E13.4,F13.5) +C3679 FORMAT(12x,4F13.3) +C3680 FORMAT(12x,6F13.5) +C3681 FORMAT(12X,5E13.4,F13.5) 3677 FORMAT('CORNER',2I5,5E14.5) 3676 FORMAT(6X,2I5,5E14.5) 3675 FORMAT(F11.3,I6,' TIME IN DAYS AND NUMBER OF CORNERS') @@ -1501,6 +1531,8 @@ C C ** SET BOTTOM AND SURFACE TURBULENT INTENSITY SQUARED AT (N+1) C C----------------------------------------------------------------------C +C + STIME=MPI_TIC() C IF(ISWAVE.GE.1)THEN C @@ -1539,13 +1571,17 @@ C C ENDIF C - TTBXY=TTBXY+SECNDS(T1TMP) + MPI_WTIMES(26)=MPI_WTIMES(26)+MPI_TOC(STIME) +C +C TTBXY=TTBXY+T1TMP-SECOND() C C**********************************************************************C C C ** CALCULATE TURBULENT INTENSITY SQUARED C - T1TMP=SECNDS(0.0) + STIME=MPI_TIC() !!### WT_CALQQ2T +C +C CALL CPU_TIME(T1TMP) IF(KC.GT.1)THEN IF(ISQQ.EQ.1)THEN IF(ISTOPT(0).EQ.0)CALL CALQQ2TOLD (ISTL) @@ -1553,11 +1589,15 @@ C ENDIF IF(ISQQ.EQ.2) CALL CALQQ2 (ISTL) ENDIF - TQQQ=TQQQ+SECNDS(T1TMP) +C TQQQ=TQQQ+T1TMP-SECOND() +C + MPI_WTIMES(27)=MPI_WTIMES(27)+MPI_TOC(STIME) C C**********************************************************************C C C ** CALCULATE MEAN MASS TRANSPORT FIELD +C + STIME=MPI_TIC() C IF(ISSSMMT.NE.2)THEN IF(ISICM.GE.1)THEN @@ -1568,6 +1608,8 @@ C C C IF(ISSSMMT.NE.2) CALL CALMMT C + MPI_WTIMES(28)=MPI_WTIMES(28)+MPI_TOC(STIME) +C C**********************************************************************C C C ** HYDRODYNAMIC CALCULATIONS FOR THIS TIME STEP ARE COMPLETED @@ -1575,6 +1617,8 @@ C C**********************************************************************C C C ** WRITE TO TIME SERIES FILES +C + STIME=MPI_TIC() C IF(ISDYNSTP.EQ.0)THEN CTIM=DT*FLOAT(N)+TCON*TBEGIN @@ -1636,7 +1680,7 @@ C C----------------------------------------------------------------------C C IF(ISDRY.GE.1.AND.ISDRY.LT.98)THEN - IF(ICALLTP.EQ.1.AND.DEBUG)THEN + IF(ICALLTP.EQ.1.AND.DEBUG.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='ZVOLBAL.OUT',POSITION='APPEND',STATUS='UNKNOWN') DO LS=1,LORMAX IF(VOLZERD.GE.VOLSEL(LS).AND.VOLZERD.LT.VOLSEL(LS+1))THEN @@ -1673,9 +1717,13 @@ C ENDIF ENDIF C + MPI_WTIMES(29)=MPI_WTIMES(29)+MPI_TOC(STIME) +C C**********************************************************************C C C ** CALCULATE MEAN MASS TRANSPORT FIELD +C + STIME=MPI_TIC() C IF(ISSSMMT.NE.2)THEN IF(ISICM.EQ.0) CALL CALMMT @@ -1683,19 +1731,24 @@ C C C IF(ISSSMMT.NE.2) CALL CALMMT C + MPI_WTIMES(30)=MPI_WTIMES(30)+MPI_TOC(STIME) +C C**********************************************************************C C C ** ADVANCE NEUTRALLY BUOYANT PARTICLE DRIFTER TRAJECTORIES C !IF(ISPD.EQ.1)THEN ! IF(N.GE.NPDRT) CALL DRIFTER - +C + STIME=MPI_TIC() +C !{GEOSR, OIL, CWCHO, 101122 IF(ISPD.GE.2.AND.IDTOX.LT.4440) THEN !DHC IF (TIMEDAY.GE.LA_BEGTI.AND.TIMEDAY.LE.LA_ENDTI) THEN - T1TMP=SECNDS(0.0) + CALL CPU_TIME(T1TMP) CALL DRIFTERC - TLRPD=TLRPD+SECNDS(T1TMP) + CALL CPU_TIME(T2TMP) + TLRPD=TLRPD+T2TMP-T1TMP ENDIF ENDIF @@ -1707,16 +1760,18 @@ C ENDIF ENDIF !GEOSR} - +C + MPI_WTIMES(31)=MPI_WTIMES(31)+MPI_TOC(STIME) +C ! IF(ISLRPD.GE.1)THEN -! T1TMP=SECNDS(0.0) !DHC:13-04-09 +! CALL CPU_TIME(T1TMP) !DHC:13-04-09 ! IF(ISLRPD.LE.2)THEN ! IF(N.GE.NLRPDRT(1)) CALL LAGRES ! ENDIF ! IF(ISLRPD.GE.3)THEN ! IF(N.GE.NLRPDRT(1)) CALL GLMRES ! ENDIF -! TLRPD=TLRPD+SECNDS(T1TMP) +! TLRPD=TLRPD+T1TMP-SECOND() ! ENDIF C C**********************************************************************C @@ -1746,41 +1801,59 @@ C CALL BUDGOD5 C ENDIF C C ** CALL TWO-TIME LEVEL BALANCES +C + STIME=MPI_TIC() C IF(ISBAL.GE.1)THEN CALL BAL2T5 ENDIF +C + MPI_WTIMES(32)=MPI_WTIMES(32)+MPI_TOC(STIME) C C**********************************************************************C C C ** PERFORM AN M2 TIDE HARMONIC ANALYSIS EVERY 2 M2 PERIODS +C + STIME=MPI_TIC() C IF(ISHTA.EQ.1) CALL CALHTA +C + MPI_WTIMES(33)=MPI_WTIMES(33)+MPI_TOC(STIME) C C**********************************************************************C C C ** CALCULATE DISPERSION COEFFICIENTS C C IF(N.GE.NDISP)THEN + STIME=MPI_TIC() +C IF(N.GE.NDISP.AND.NCTBC.EQ.1)THEN IF(ISDISP.EQ.2) CALL CALDISP2 IF(ISDISP.EQ.3) CALL CALDISP3 ENDIF +C + MPI_WTIMES(34)=MPI_WTIMES(34)+MPI_TOC(STIME) C C**********************************************************************C C C ** PERFORM LEAST SQUARES HARMONIC ANALYSIS AT SELECTED LOCATIONS +C + STIME=MPI_TIC() C IF(ISLSHA.EQ.1.AND.N.EQ.NCLSHA)THEN CALL LSQHARM NCLSHA=NCLSHA+(NTSPTC/24) ENDIF +C + MPI_WTIMES(35)=MPI_WTIMES(35)+MPI_TOC(STIME) C C**********************************************************************C C C ** PRINT INTERMEDIATE RESULTS C C----------------------------------------------------------------------C +C + STIME=MPI_TIC() C IF(NPRINT .EQ. NTSPP)THEN NPRINT=1 @@ -1788,6 +1861,8 @@ C ELSE NPRINT=NPRINT+1 ENDIF +C + MPI_WTIMES(36)=MPI_WTIMES(36)+MPI_TOC(STIME) C C**********************************************************************C C @@ -1797,14 +1872,21 @@ C----------------------------------------------------------------------C C CDYN IF(N.EQ.NCPPH.AND.ISPPH.EQ.1)THEN Cpmc IF(N.GE.NCPPH.AND.ISPPH.GE.1)THEN +C + STIME=MPI_TIC() +C IF(TIMEDAY.GE.SNAPSHOTS(NSNAPSHOTS))THEN CALL SURFPLT ENDIF +C + MPI_WTIMES(37)=MPI_WTIMES(37)+MPI_TOC(STIME) C C C----------------------------------------------------------------------C C CDYN IF(N.EQ.NCBPH.AND.ISBPH.EQ.1)THEN +C + STIME=MPI_TIC() C IF(N.GE.NCBPH.AND.ISBPH.GE.1)THEN IF(ISBEXP.EQ.0)THEN @@ -1812,40 +1894,45 @@ C NCBPH=NCBPH+(NTSPTC/NPBPH) ENDIF ENDIF +C + MPI_WTIMES(38)=MPI_WTIMES(38)+MPI_TOC(STIME) C C----------------------------------------------------------------------C C CDYN IF(N.EQ.NCVPH.AND.ISVPH.GE.1)THEN +C + STIME=MPI_TIC() !!### WT_VELPLTH C IPLTTMP=0 IF(ISVPH.EQ.1.OR.ISVPH.EQ.2)IPLTTMP=1 IF(TIMEDAY.GE.SNAPSHOTS(NSNAPSHOTS).AND.IPLTTMP.EQ.1)THEN CALL VELPLTH ENDIF +C + MPI_WTIMES(39)=MPI_WTIMES(39)+MPI_TOC(STIME) C C----------------------------------------------------------------------C C CDYN IF(N.EQ.NCVPV.AND.ISVPV.GE.1)THEN +C + STIME=MPI_TIC() C IF(N.GE.NCVPV.AND.ISVPV.GE.1)THEN CALL VELPLTV NCVPV=NCVPV+(NTSPTC/NPVPV) ENDIF +C + MPI_WTIMES(40)=MPI_WTIMES(40)+MPI_TOC(STIME) C C----------------------------------------------------------------------C C -!$OMP PARALLEL DO PRIVATE(LF,LL) - do ithds=0,nthds-1 - LF=jse_LC(1,ithds) - LL=jse_LC(2,ithds) -c + STIME=MPI_TIC() !!### WT_SALPLTH +C DO K=1,KC - DO L=LF,LL + DO L=1,LC TVAR1S(L,K)=TOX(L,K,1) ENDDO ENDDO -c - enddo C IPLTTMP=0 IF(ISSPH(1).EQ.1.OR.ISSPH(1).EQ.2)IPLTTMP=1 @@ -1895,8 +1982,12 @@ C IF(ISTRAN(7).GE.1) CALL SALPLTH (7,SNDT) NCSPH(7)=NCSPH(7)+(NTSPTC/NPSPH(7)) ENDIF +C + MPI_WTIMES(41)=MPI_WTIMES(41)+MPI_TOC(STIME) C C----------------------------------------------------------------------C +C + STIME=MPI_TIC() C DO ITMP=1,7 IF(N.GE.NCSPV(ITMP).AND.ISSPV(ITMP).GE.1)THEN @@ -1904,10 +1995,14 @@ C NCSPV(ITMP)=NCSPV(ITMP)+(NTSPTC/NPSPV(ITMP)) ENDIF ENDDO +C + MPI_WTIMES(42)=MPI_WTIMES(42)+MPI_TOC(STIME) C C----------------------------------------------------------------------C C C ** WRITE EFDC EXPLORER FORMAT OUTPUT +C + STIME=MPI_TIC() !!### WT_EEXPOUT C IF(ISSPH(8).EQ.1.OR.ISBEXP.EQ.1)THEN IF(TIMEDAY.GE.SNAPSHOTS(NSNAPSHOTS))THEN @@ -1917,21 +2012,29 @@ C IF(TIMEDAY.GE.SNAPSHOTS(NSNAPSHOTS))THEN NSNAPSHOTS=NSNAPSHOTS+1 ENDIF +C + MPI_WTIMES(43)=MPI_WTIMES(43)+MPI_TOC(STIME) C C**********************************************************************C C C ** WRITE TO TIME VARYING 3D HDF GRAPHICS FILES C C----------------------------------------------------------------------C +C + STIME=MPI_TIC() C IF(N.EQ.NC3DO.AND.IS3DO.EQ.1)THEN CALL OUT3D NC3DO=NC3DO+(NTSPTC/NP3DO) ENDIF +C + MPI_WTIMES(44)=MPI_WTIMES(44)+MPI_TOC(STIME) C C**********************************************************************C C C ** WRITE RESTART FILE EVERY ISRESTO M2 TIDAL CYCLES +C + STIME=MPI_TIC() C IF(ISRESTO.GE.1)THEN IF((N-ISSREST).GT.NRESTO)THEN @@ -1965,12 +2068,14 @@ C ENDIF IF(TIMEDAY.GE.SNAPSHOTHYD) THEN ! WRITE(*,*)'WRITE================',N,TIMEDAY,TIMEDAY*1440. - CALL RESTOUT(-21) +! CALL RESTOUT(-21) IHYDCNT=IHYDCNT+1 SNAPSHOTHYD=FLOAT(ISHYD*IHYDCNT)*60./86400.+TBEGIN ENDIF ENDIF ! } GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 +C + MPI_WTIMES(45)=MPI_WTIMES(45)+MPI_TOC(STIME) C C**********************************************************************C C @@ -1996,6 +2101,16 @@ C**********************************************************************C C C *** DJB ![ykchoi 10.04.26 for linux version + MPI_WTIMES(1)=MPI_WTIMES(1)+MPI_TOC(TTIME) + IF(N.GE.NTSPTC/200)THEN + DO II=1,45 + IF(NINT(200*REAL(MPI_WTIMES(II))).GE.1) + & WRITE(*,'(I5,F10.3)') II, (10*REAL(MPI_WTIMES(II))) + + ENDDO + STOP 'LOOP MPI' + ENDIF + GOTO 1001 ! IF(.NOT.KBHIT())GOTO 1001 ! I1=GETCH() @@ -2012,7 +2127,8 @@ C**********************************************************************C C C ** TIME LOOP COMPLETED C - THDMT=THDMT+SECNDS(TTMP) + CALL CPU_TIME(T1TMP) + THDMT=THDMT+T1TMP-TTMP C C**********************************************************************C C *** EE BEGIN BLOCK @@ -2021,7 +2137,7 @@ C UNNECESSARY DUPLICATION C *** EE END BLOCK C**********************************************************************C C - 2000 CONTINUE +C2000 CONTINUE C C**********************************************************************C C @@ -2066,7 +2182,7 @@ C C ** OUTPUT COURANT NUMBER DIAGNOSTICS C C *** DSLLC BEGIN BLOCK - IF(ISINWV.GT.0.AND.DEBUG)THEN + IF(ISINWV.GT.0.AND.DEBUG.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='CFLMAX.OUT') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='CFLMAX.OUT') @@ -2090,7 +2206,7 @@ C**********************************************************************C C C ** OUTPUT COSMETIC VOLUME LOSSES FORM DRY CELLS C - IF(NDRYSTP.LT.0.AND.DEBUG) THEN + IF(NDRYSTP.LT.0.AND.DEBUG.AND.MYRANK.EQ.0) THEN C OPEN(1,FILE='DRYLOSS.OUT') CLOSE(1,STATUS='DELETE') diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT2T_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT2T_mpi.for new file mode 100644 index 000000000..0f246445d --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/HDMT2T_mpi.for @@ -0,0 +1,2718 @@ + SUBROUTINE HDMT2T_mpi +C +C ** SUBROUTINE HDMT2T EXECUTES THE FULL HYDRODYNAMIC AND MASS +C ** TRANSPORT TIME INTERGATION USING A TWO TIME LEVEL SCHEME +C +C ** THIS SUBROUTINE IS PART OF EFDC-FULL VERSION +C +C----------------------------------------------------------------------C +C +C CHANGE RECORD +C DATE MODIFIED BY DATE APPROVED BY +C +C 05/01/2002 John Hamrick 05/01/2002 John Hamrick +C modified calls to calbal and budget subroutines +C added calls to bal2t1, bal2t4, bal2t5 +C 05/02/2002 John Hamrick 05/01/2002 John Hamrick +C modified calculation of cell center bed stress (stored as QQ(l,0)) +C for cells have source/sinks +C 09-22-2004 Paul M. Craig +C Merged DS and TT versions with the 06-04-2004 TT code +C----------------------------------------------------------------------C +C +C**********************************************************************C +C + USE GLOBAL + USE DRIFTER + USE WINDWAVE ,ONLY:WINDWAVEINIT,WINDWAVETUR + USE MPI + + REAL TTMP, T1TMP, TMP, T2TMP + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::ISSBCP + LOGICAL BTEST, LTEST, ERRTEST + + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WCOREW + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WCORNS + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LCORNER + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LCORNWE + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LCORNSN + +! { GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 + INTEGER ISHYD,IHYDCNT + INTEGER ISAVESEDDT + INTEGER LN + REAL SNAPSHOTHYD + INTEGER NTMPVAL + IHYDCNT=0 + NTMPVAL=0 + SNAPSHOTHYD=0.0 + BTEST=.FALSE. + LN=0 + ISAVESEDDT=0 +! } GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 +C +![ykchoi 10.04.26 for linux version +! INTERFACE TO FUNCTION KBHIT +! & [C,ALIAS:'__kbhit'] +! & () +! LOGICAL KBHIT*1 +! END +! INTERFACE TO FUNCTION GETCH +! & [C,ALIAS:'__getch'] +! & () +! INTEGER GETCH*1 +! END +!ykchoi] +C + IF(.NOT.ALLOCATED(WCOREW))THEN + ALLOCATE(WCOREW(LCM)) + ALLOCATE(WCORNS(LCM)) + ALLOCATE(LCORNER(LCM)) + ALLOCATE(LCORNWE(LCM)) + ALLOCATE(LCORNSN(LCM)) + ! *** ALLOCATE LOCAL ARRAYS + WCOREW=0.0 + WCORNS=0.0 + LCORNER=0 + LCORNWE=0 + LCORNSN=0 + ENDIF +C + CALL CPU_TIME(TTMP) + ICALLTP=0 +C + ISTL=2 + FOURDPI=4./PI + ISTL=2 + IS2TL=1 + MPI_WTIMES=0 + CALL ISINPUTS(IS_PSER,IS_CSER,IS_QSER,IS_QCTL) +C +C**********************************************************************C +C +C ** SET FLAGS FOR CORNER CELL BED STRESS CORRECTIONS +C +C *** DSLLC BEGIN BLOCK + IF(ISCORTBC.GE.1) THEN +C +C ** SET FLAG FOR CELLS HAVING VOLUME SOURCE OR SINKS +C + IF(.NOT.ALLOCATED(ISSBCP))ALLOCATE(ISSBCP(LCM)) + DO L=1,LC + ISSBCP(L)=0 + ENDDO +C + DO L=2,LA + IF(RSSBCE(L).GT.1.5)ISSBCP(L)=1 + IF(RSSBCW(L).GT.1.5)ISSBCP(L)=1 + IF(RSSBCN(L).GT.1.5)ISSBCP(L)=1 + IF(RSSBCS(L).GT.1.5)ISSBCP(L)=1 + ENDDO +C + ENDIF +C + DO L=2,LA + WCOREST(L)=1. + WCORWST(L)=1. + WCORNTH(L)=1. + WCORSTH(L)=1. + ENDDO + ! *** DSLLC +C +C**********************************************************************C +C +C ** REINITIALIZE VARIABLES +C + DO L=2,LA + H1P(L)=HP(L) + H1U(L)=HU(L) + H1UI(L)=HUI(L) + H1V(L)=HV(L) + H1VI(L)=HVI(L) + UHDY1E(L)=UHDYE(L) + VHDX1E(L)=VHDXE(L) + ENDDO +C + DO K=1,KC + DO L=2,LA + U1(L,K)=U(L,K) + V1(L,K)=V(L,K) + UHDY1(L,K)=UHDY(L,K) + VHDX1(L,K)=VHDX(L,K) + ENDDO + ENDDO +C +C**********************************************************************C +C +C ** INITIALIZE COURANT NUMBER DIAGNOSTICS +C + DO K=1,KC + DO L=2,LA + CFLUUU(L,K)=0. + CFLVVV(L,K)=0. + CFLWWW(L,K)=0. + CFLCAC(L,K)=0. + ENDDO + ENDDO +C +C**********************************************************************C +C + ILOGC=0 +C +C**********************************************************************C +C +C ** CALCULATE U AT V AND V AT U USING ENERGY CONSERVING WEIGHTING +C ** CALCULATE VELOCITY GRADIENTS +C +C----------------------------------------------------------------------C +C + DO L=2,LA + LN=LNC(L) + LS=LSC(L) + LNW=LNWC(L) + LSE=LSEC(L) + LSW=LSWC(L) + + UV(L)=0.25*(HP(LS)*(U(LSE,1)+U(LS,1)) + & +HP(L)*(U(L+1,1)+U(L,1)))*HVI(L) + U1V(L)=0.25*(H1P(LS)*(U1(LSE,1)+U1(LS,1)) + & +H1P(L)*(U1(L+1,1)+U1(L,1)))*H1VI(L) + VU(L)=0.25*(HP(L-1)*(V(LNW,1)+V(L-1,1)) + & +HP(L)*(V(LN,1)+V(L,1)))*HUI(L) + V1U(L)=0.25*(H1P(L-1)*(V1(LNW,1)+V1(L-1,1)) + & +H1P(L)*(V1(LN,1)+V1(L,1)))*H1UI(L) + ! *** DSLLC END BLOCK + ENDDO + +C +C**********************************************************************C +C +C ** CALCULATE WAVE BOUNDARY LAYER AND WAVE REYNOLDS STRESS FORCINGS +C +CC IF(N.EQ.1.AND.MYRANK.EQ.0) PRINT*,'SWITCH ISWAVE',ISWAVE + IF(ISWAVE.EQ.1) CALL WAVEBL + IF(ISWAVE.EQ.2) CALL WAVESXY + IF(ISWAVE.EQ.3.AND.NWSER > 0) THEN + CALL WINDWAVEINIT + CALL WINDWAVETUR !DHC FIRST CALL + ENDIF +C +C**********************************************************************C +C +C ** FIRST CALL TO INITIALIZE BOTTOM STRESS COEFFICINETS +C + DTDYN=DT ! *** PMC - FOR INITIALIZATION + CALL CALTBXY_mpi(ISTL,IS2TL) +C +C**********************************************************************C +C +C ** CALCULATE HORIZONTAL VISCOSITY AND DIFFUSIVE MOMENTUM FLUXES +C + IF(ISHDMF.GE.1) CALL CALHDMF_mpi +C +C**********************************************************************C +C +C ** CALCULATE BOTTOM AND SURFACE STRESS AT TIME LEVEL (N-1) AND N +C +C----------------------------------------------------------------------C +C + N=-1 + CALL CALTSXY_mpi +C +C**********************************************************************C +C +C ** SECOND CALL TO INITIALIZE BOTTOM STRESS COEFFICINETS +C + CALL CALTBXY_mpi(ISTL,IS2TL) +C +C**********************************************************************C +C +C ** SET BOTTOM AND SURFACE STRESSES +C +C----------------------------------------------------------------------C +C + DO L=2,LA + TBX(L)=(AVCON1*HUI(L)+STBX(L)*SQRT(VU(L)*VU(L) + & +U(L,1)*U(L,1)))*U(L,1) + TBY(L)=(AVCON1*HVI(L)+STBY(L)*SQRT(UV(L)*UV(L) + & +V(L,1)*V(L,1)))*V(L,1) + ENDDO + CALL broadcast_boundary(TBX,ic) + CALL broadcast_boundary(TBY,ic) +C + N=0 + CALL CALTSXY_mpi +C +C----------------------------------------------------------------------C +C +C ** SET DEPTH DEVIATION FROM UNIFORM FLOW ON FLOW FACES +C + DO L=2,LA + HDFUFX(L)=1. + HDFUFY(L)=1. + HDFUF(L)=1. + ENDDO +C + IF(ISBSDFUF.GE.1)THEN + HDFUFM=1.E-12 +C + DO L=2,LA + LS=LSC(L) + HDFUFX(L)=HDFUFM+G*SUB(L)*HU(L)*(BELV(L-1)-BELV(L))*DXIU(L) + HDFUFY(L)=HDFUFM+G*SVB(L)*HV(L)*(BELV(LS )-BELV(L))*DYIV(L) + ENDDO +C + DO L=2,LA + HDFUFX(L)=TBX(L)/HDFUFX(L) + HDFUFY(L)=TBY(L)/HDFUFY(L) + ENDDO +C + DO L=2,LA + HDFUFX(L)=MAX(HDFUFX(L),-1.0) + HDFUFY(L)=MAX(HDFUFY(L),-1.0) + ENDDO +C + DO L=2,LA + HDFUFX(L)=MIN(HDFUFX(L),1.0) + HDFUFY(L)=MIN(HDFUFY(L),1.0) + ENDDO +C + ENDIF +C +C**********************************************************************C +C +C ** SET BOTTOM AND SURFACE TURBULENT INTENSITY SQUARED +C +C----------------------------------------------------------------------C +C + IF(ISWAVE.EQ.0)THEN +C +C----------------------------------------------------------------------c +C + IF(ISCORTBC.EQ.0) THEN +C + DO L=2,LA + TVAR3S(L)=TSY(LNC(L)) + TVAR3W(L)=TSX(L+1) + TVAR3E(L)=TBX(L+1 ) + TVAR3N(L)=TBY(LNC(L)) + ENDDO +C + DO L=2,LA +! { GEOSR (IBM request) + IF (ISNAN(TVAR3S(L))) TVAR3S(L)=0. + IF (ISNAN(TVAR3W(L))) TVAR3W(L)=0. + IF (ISNAN(TVAR3E(L))) TVAR3E(L)=0. + IF (ISNAN(TVAR3N(L))) TVAR3N(L)=0. + IF (ISNAN(TSY(L))) TSY(L)=0. + IF (ISNAN(TSX(L))) TSX(L)=0. + IF (ISNAN(TBY(L))) TBY(L)=0. + IF (ISNAN(TBX(L))) TBX(L)=0. +! } GEOSR (IBM request) + QQ(L,0 )=0.5*CTURB2*SQRT( + & (RSSBCE(L)*TVAR3E(L)+RSSBCW(L)*TBX(L))**2 + & +(RSSBCN(L)*TVAR3N(L)+RSSBCS(L)*TBY(L))**2) + TAUBSED(L)=QQ(L,0 )/CTURB2 + QQ(L,KC)=0.5*CTURB2*SQRT( + & (RSSBCE(L)*TVAR3W(L)+RSSBCW(L)*TSX(L))**2 + & +(RSSBCN(L)*TVAR3S(L)+RSSBCS(L)*TSY(L))**2) + QQSQR(L,0)=SQRT(QQ(L,0)) ! *** DSLLC + ENDDO +C + ENDIF +C +C----------------------------------------------------------------------c +C + IF(ISCORTBC.GE.1) THEN +C + IF(DEBUG)THEN + IF(ISCORTBCD.GE.1)THEN + OPEN(1,FILE='ADJSTRESSE.OUT') + CLOSE(1,STATUS='DELETE') + ENDIF +C + OPEN(1,FILE='TBCORINIT.OUT') + ENDIF +C + DO L=2,LA + IF(ISSBCP(L).EQ.0)THEN + IF(SUB(L+1).LT.0.5) WCOREST(L)=FSCORTBCV(L) + IF(SUB(L).LT.0.5) WCORWST(L)=FSCORTBCV(L) + IF(SVB(LNC(L)).LT.0.5) WCORNTH(L)=FSCORTBCV(L) + IF(SVB(L).LT.0.5) WCORSTH(L)=FSCORTBCV(L) + ENDIF + ENDDO +C + DO L=2,LA + WCOREW(L)=1./(WCOREST(L)+WCORWST(L)) + WCORNS(L)=1./(WCORNTH(L)+WCORSTH(L)) + ENDDO +C + DO L=2,LA + WCOREST(L)=WCOREST(L)*WCOREW(L) + WCORWST(L)=WCORWST(L)*WCOREW(L) + WCORNTH(L)=WCORNTH(L)*WCORNS(L) + WCORSTH(L)=WCORSTH(L)*WCORNS(L) + ENDDO +C + DO L=2,LA + TVAR3S(L)=TSY(LNC(L)) + TVAR3W(L)=TSX(L+1) + TVAR3E(L)=TBX(L+1 ) + TVAR3N(L)=TBY(LNC(L)) + ENDDO +C + DO L=2,LA +! { GEOSR (IBM request) + IF (ISNAN(TVAR3S(L))) TVAR3S(L)=0. + IF (ISNAN(TVAR3W(L))) TVAR3W(L)=0. + IF (ISNAN(TVAR3E(L))) TVAR3E(L)=0. + IF (ISNAN(TVAR3N(L))) TVAR3N(L)=0. + IF (ISNAN(TSY(L))) TSY(L)=0. + IF (ISNAN(TSX(L))) TSX(L)=0. + IF (ISNAN(TBY(L))) TBY(L)=0. + IF (ISNAN(TBX(L))) TBX(L)=0. +! } GEOSR (IBM request) + QQ(L,0 )=CTURB2*SQRT( + & (RSSBCE(L)*WCOREST(L)*TVAR3E(L) + & +RSSBCW(L)*WCORWST(L)*TBX(L))**2 + & +(RSSBCN(L)*WCORNTH(L)*TVAR3N(L) + & +RSSBCS(L)*WCORSTH(L)*TBY(L))**2) + QQ(L,KC)=0.5*CTURB2*SQRT( + & (RSSBCE(L)*TVAR3W(L)+RSSBCW(L)*TSX(L))**2 + & +(RSSBCN(L)*TVAR3S(L)+RSSBCS(L)*TSY(L))**2) + QQSQR(L,0)=SQRT(QQ(L,0)) ! *** DSLLC + ENDDO +C + DO L=2,LA + TAUBSED(L)=QQ(L,0 )/CTURB2 + TAUBSND(L)=QQ(L,0 )/CTURB2 + ENDDO + + IF(DEBUG)THEN + DO L=2,LA + IF(WCORSTH(L).LT.0.49.OR.WCORSTH(L).GT.0.51)THEN + IF(WCORWST(L).LT.0.49.OR.WCORWST(L).GT.0.51)THEN + WRITE(1,3678)IL(L),JL(L),WCORWST(L),WCOREST(L), + & WCORSTH(L),WCORNTH(L) + ENDIF + ENDIF + ENDDO +C + CLOSE(1) + ENDIF +C + ENDIF +C +C----------------------------------------------------------------------c +C + ENDIF +C +C ENDIF +C +C**********************************************************************C +C +C ** SET BOTTOM AND SURFACE TURBULENT INTENSITY SQUARED +C +C----------------------------------------------------------------------C +C + IF(ISWAVE.GE.1)THEN +C + DO L=2,LA + TVAR3S(L)=TSY(LNC(L)) + TVAR3W(L)=TSX(L+1) + TVAR3E(L)=TBX(L+1 ) + TVAR3N(L)=TBY(LNC(L)) + ENDDO +C + DO L=2,LA +! { GEOSR (IBM request) + IF (ISNAN(TVAR3S(L))) TVAR3S(L)=0. + IF (ISNAN(TVAR3W(L))) TVAR3W(L)=0. + IF (ISNAN(TVAR3E(L))) TVAR3E(L)=0. + IF (ISNAN(TVAR3N(L))) TVAR3N(L)=0. + IF (ISNAN(TSY(L))) TSY(L)=0. + IF (ISNAN(TSX(L))) TSX(L)=0. + IF (ISNAN(TBY(L))) TBY(L)=0. + IF (ISNAN(TBX(L))) TBX(L)=0. +! } GEOSR (IBM request) + TAUBC2 = (RSSBCE(L)*TVAR3E(L)+RSSBCW(L)*TBX(L))**2 + & +(RSSBCN(L)*TVAR3N(L)+RSSBCS(L)*TBY(L))**2 + TAUBC=0.5*SQRT(TAUBC2) + UTMP=0.5*STCUV(L)*(U(L+1,1)+U(L,1))+1.E-12 + VTMP=0.5*STCUV(L)*(V(LN,1)+V(L,1)) + CURANG=ATAN2(VTMP,UTMP) + TAUB2=TAUBC*TAUBC+0.5*(QQWV1(L)*QQWV1(L)) + & +FOURDPI*TAUBC*QQWV1(L)*COS(CURANG-WACCWE(L)) + TAUB2=MAX(TAUB2,0.) + QQ(L,0 )=CTURB2*SQRT(TAUB2) + QQ(L,KC)=0.5*CTURB2*SQRT((TVAR3W(L)+TSX(L))**2 + & +(TVAR3S(L)+TSY(L))**2) + QQSQR(L,0)=SQRT(QQ(L,0)) ! *** DSLLC + ENDDO +C + ENDIF +C +C ENDIF +C +C**********************************************************************C +C +C ** SET SWITCHES FOR TWO TIME LEVEL INTEGRATION +C + ISTL=2 + IS2TL=1 + DELT=DT + DELTD2=DT/2. + DZDDELT=DZ/DELT +C +C**********************************************************************C +C +C ** BEGIN TIME LOOP FOR FULL HYDRODYNAMIC AND MASS TRANSPORT +C ** CALCULATION +C +C ** SET CYCLE COUNTER AND CALL TIMER +C + NTIMER=0 + ISSREST=0 + NRESTO=ISRESTO*NTSPTC + N=0 +C +C *** EE BEGIN BLOCK +C ** INITIALZE & RECORD TIME +C + TIMEDAY=TCON*TBEGIN/86400. + IF(MYRANK.EQ.0) CALL TIMELOG(0,TIMEDAY) + IF(ISDYNSTP.GT.0)THEN + ! *** ALLOW FOR SEDIMENT RAMPUP + ISAVESEDDT=ISEDDT + ISEDDT=1 + ENDIF +C +C *** EE END BLOCK +C + NTIMER=1 + NINCRMT=1 + NLOOP=0 +C + PRINT_SUM=.FALSE. + IF(PRINT_SUM)THEN + call collect_in_zero(TSX) + call collect_in_zero(TSY) + call collect_in_zero(TBX) + call collect_in_zero(TBY) + call collect_in_zero_array(AV) + call collect_in_zero_array(AB) + call collect_in_zero_array(AQ) + call collect_in_zero(HP) + call collect_in_zero(HU) + call collect_in_zero(HV) + call collect_in_zero(P) + call collect_in_zero_array(U) + call collect_in_zero_array(V) + call collect_in_zero_array(W) + call collect_in_zero_array(TEM) + call collect_in_zero_array(SEDT) + do k=0,kcm + call collect_in_zero(QQ(:,k)) + call collect_in_zero(QQL(:,k)) + enddo + DO NW=1,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + DO NSP=1,NXSP + call collect_in_zero_array(WQVX(:,:,NSP)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, 0,'TSX = ', sum(abs(dble(TSX))) + PRINT*, 0,'TSY = ', sum(abs(dble(TSY))) + PRINT*, 0,'TBX = ', sum(abs(dble(TBX))) + PRINT*, 0,'TBY = ', sum(abs(dble(TBY))) + PRINT*, 0,'AV = ', sum(abs(dble(AV))) + PRINT*, 0,'AB = ', sum(abs(dble(AB))) + PRINT*, 0,'AQ = ', sum(abs(dble(AQ))) + PRINT*, 0,'HP = ', sum(abs(dble(HP))) + PRINT*, 0,'HU = ', sum(abs(dble(HU))) + PRINT*, 0,'HV = ', sum(abs(dble(HV))) + PRINT*, 0,'P = ', sum(abs(dble(P))) + PRINT*, 0,'U = ', sum(abs(dble(U))) + PRINT*, 0,'V = ', sum(abs(dble(V))) + PRINT*, 0,'W = ', sum(abs(dble(W))) + PRINT*, 0,'TEM = ', sum(abs(dble(TEM))) + PRINT*, 0,'SEDT = ', sum(abs(dble(SEDT))) + PRINT*, 0,'QQ = ', sum(abs(dble(QQ))) + PRINT*, 0,'QQL = ', sum(abs(dble(QQL))) + PRINT*, 0,'WQV = ', sum(abs(dble(WQV))) + PRINT*, 0,'WQVX = ', sum(abs(dble(WQVX))) + ENDIF + ENDIF +C----------------------------------------------------------------------C +C + 1001 CONTINUE + IF(N.GE.NTS)GO TO 1000 +C +C ITERATION START + TTIME=MPI_TIC() + STIME=MPI_TIC() + IF(ISDYNSTP.EQ.0)THEN + N=N+1 + ETIMESEC=DT*FLOAT(N) + ETIMEDAY=DT*FLOAT(N)/86400. + TIMESEC=(DT*FLOAT(N)+TCON*TBEGIN) + TIMEDAY=(DT*FLOAT(N)+TCON*TBEGIN)/86400. + ELSE + NLOOP=NLOOP+1 + IF(NLOOP.GT.ITRMADJ)THEN + ISEDDT=ISAVESEDDT ! *** PMC-ALLOW FOR SEDIMENT RAMPUP ALSO + IF(IDRYTBP.EQ.0)THEN + CALL CALSTEP + ELSE + CALL CALSTEPD + ENDIF + ELSE + DTDYN=DT + NINCRMT=1 + ENDIF + DELT=DTDYN + DELTD2=DTDYN/2. + DZDDELT=DZ/DTDYN + N=N+NINCRMT + ETIMESEC=DT*FLOAT(N) + ETIMEDAY=(DT*FLOAT(N))/86400. + TIMESEC=(DT*FLOAT(N)+TCON*TBEGIN) + TIMEDAY=(DT*FLOAT(N)+TCON*TBEGIN)/86400. + ENDIF +C +C PMC IF(ILOGC.EQ.NTSMMT)THEN + IF(ILOGC.EQ.NTSPTC.AND.MYRANK.EQ.0)THEN + CLOSE(8,STATUS='DELETE') + OPEN(8,FILE='EFDCLOG.OUT',STATUS='UNKNOWN') + IF(DEBUG)THEN + IF(ISDRY.GT.0)THEN + OPEN(1,FILE='DRYWET.LOG',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + ENDIF + IF(ISCFL.EQ.1)THEN + OPEN(1,FILE='CFL.OUT',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + ENDIF + ENDIF + ILOGC=0 + ENDIF +C + IF(ISDYNSTP.EQ.0)THEN + ILOGC=ILOGC+1 + ELSE + ILOGC=ILOGC+NINCRMT + ENDIF +C +C *** DSLLC BEGIN BLOCK + IF(N.LE.NLTS)THEN + SNLT=0. + ELSEIF(N.GT.NLTS.AND.N.LE.NTTS)THEN + NTMP1=N-NLTS + NTMP2=NTTS-NLTS+1 + SNLT=FLOAT(NTMP1)/FLOAT(NTMP2) + ELSE + SNLT=1. + ENDIF + + ! *** TURN OFF WIND SHELTERING FOR ICE CONDITIONS (TO BE REPLACED AFTER FULL ICE SUBMODEL ADDED) + IF(WINTER_END > WINTER_START)THEN + IF(TIMEDAY > WINTER_START)THEN + IF(WINDSTKA_SAVE(1)==0.)THEN + ! *** TOGGLE OFF THE WIND SHELTERING COEFFICIENTS + DO L=2,LA + WINDSTKA_SAVE(L)=WINDSTKA(L) + WINDSTKA(L)=0. + ENDDO + WINDSTKA_SAVE(1) = 1. + ENDIF + IF(TIMEDAY > WINTER_END)THEN + ! *** TOGGLE ON THE WIND SHELTERING COEFFICIENTS + DO L=2,LA + WINDSTKA(L) = WINDSTKA_SAVE(L) + ENDDO + WINDSTKA_SAVE(1) = 0. + WINTER_START = WINTER_START+365. + WINTER_END = WINTER_END+365. + ENDIF + ENDIF + ENDIF +C *** DSLLC END BLOCK +C + IF(N.LE.NTSVB)THEN + GP=GPO*(FLOAT(N)/FLOAT(NTSVB)) + ELSE + GP=GPO + ENDIF +C + MPI_WTIMES(2)=MPI_WTIMES(2)+MPI_TOC(STIME) +C +C----------------------------------------------------------------------C +C +C ** INITIALIZE TWO-TIME LEVEL BALANCES +C + STIME=MPI_TIC() +C + IF(IS2TIM.GE.1) THEN + IF(ISBAL.GE.1)THEN + CALL BAL2T1 + ENDIF + ENDIF +C + MPI_WTIMES(3)=MPI_WTIMES(3)+MPI_TOC(STIME) +C +C----------------------------------------------------------------------C +C +C ** REENTER HERE FOR TWO TIME LEVEL LOOP +C +C 500 CONTINUE +C +C**********************************************************************C +C +C ** CALCULATE VERTICAL VISCOSITY AND DIFFUSIVITY AT TIME LEVEL (N) +C + STIME=MPI_TIC() +C + IF(KC.GT.1)THEN + IF(ISQQ.EQ.1)THEN + IF(MYRANK.EQ.0)THEN + ENDIF + IF(ISTOPT(0).EQ.0)CALL CALAVBOLD_mpi (ISTL) + IF(ISTOPT(0).GE.1)CALL CALAVB_mpi (ISTL) + ENDIF + IF(MYRANK.EQ.0)THEN + ENDIF + IF(ISQQ.EQ.2) CALL CALAVB2 (ISTL) + ENDIF +C + IF(.FALSE.)THEN + call collect_in_zero_array(AVUI) + call collect_in_zero_array(AVVI) + call collect_in_zero_array(AV ) + call collect_in_zero_array(AB ) + call collect_in_zero_array(AQ ) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'AVUI = ', sum(abs(dble(AVUI ))) + PRINT*, n,'AVVI = ', sum(abs(dble(AVVI ))) + PRINT*, n,'AV = ', sum(abs(dble(AV ))) + PRINT*, n,'AB = ', sum(abs(dble(AB ))) + PRINT*, n,'AQ = ', sum(abs(dble(AQ ))) + ENDIF + ENDIF +C + MPI_WTIMES(4)=MPI_WTIMES(4)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE WAVE BOUNDARY LAYER AND WAVE REYNOLDS STRESS FORCINGS +C + STIME=MPI_TIC() +C + IF(ISWAVE.EQ.1) CALL WAVEBL + IF(ISWAVE.EQ.2) CALL WAVESXY + IF(ISWAVE.EQ.3.AND.NWSER > 0) CALL WINDWAVETUR !DHC NEXT CALL +C + MPI_WTIMES(5)=MPI_WTIMES(5)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** ADVANCE TIME VARIABLE SURFACE WIND STRESS AND UPDATE NEW WIND +C ** STRESSES *** DSLLC MOVED +C +C----------------------------------------------------------------------C +C + STIME=MPI_TIC() +C + CALL CALTSXY_mpi +C + IF(.FALSE.)THEN + call collect_in_zero(TSX ) + call collect_in_zero(TSY ) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'TSX = ', sum(abs(dble(TSX ))) + PRINT*, n,'TSY = ', sum(abs(dble(TSY ))) + ENDIF + ENDIF +C + MPI_WTIMES(6)=MPI_WTIMES(6)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE EXPLICIT MOMENTUM EQUATION TERMS +C + STIME=MPI_TIC() +C + IF(IS2TIM.EQ.1) CALL CALEXP2T_mpi + IF(IS2TIM.EQ.2) CALL CALIMP2T +C + IF(.FALSE.)THEN + call collect_in_zero(FCAXE) + call collect_in_zero(FCAYE) + call collect_in_zero(FXE ) + call collect_in_zero(FYE ) + call collect_in_zero_array(FX ) + call collect_in_zero_array(FY ) + call collect_in_zero_array(FBBX) + call collect_in_zero_array(FBBY) + call collect_in_zero_array(DU ) + call collect_in_zero_array(DV ) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'FCAXE = ', sum(abs(dble(FCAXE))) + PRINT*, n,'FCAYE = ', sum(abs(dble(FCAYE))) + PRINT*, n,'FXE = ', sum(abs(dble(FXE ))) + PRINT*, n,'FYE = ', sum(abs(dble(FYE ))) + PRINT*, n,'FX = ', sum(abs(dble(FX ))) + PRINT*, n,'FY = ', sum(abs(dble(FY ))) + PRINT*, n,'FBBX = ', sum(abs(dble(FBBX ))) + PRINT*, n,'FBBY = ', sum(abs(dble(FBBY ))) + PRINT*, n,'DU = ', sum(abs(dble(DU ))) + PRINT*, n,'DV = ', sum(abs(dble(DV ))) + ENDIF + ENDIF + MPI_WTIMES(7)=MPI_WTIMES(7)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** UPDATE TIME VARIABLE VOLUME SOURCES AND SINKS, CONCENTRATIONS, +C ** VEGETATION CHARACTERISTICS AND SURFACE ELEVATIONS +C + STIME=MPI_TIC() +C + CALL CALCSER_mpi (ISTL) + CALL CALVEGSER_mpi (ISTL) + CALL CALQVS_mpi (ISTL) + PSERT(0)=0. + IF(NPSER.GE.1) CALL CALPSER_mpi (ISTL) +C + MPI_WTIMES(8)=MPI_WTIMES(8)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** SOLVE EXTERNAL MODE EQUATIONS FOR P, UHDYE, AND VHDXE +C + STIME=MPI_TIC() +C + IF(ISCHAN.EQ.0.AND.ISDRY.EQ.0) CALL CALPUV2T + IF(ISCHAN.GE.1.OR.ISDRY.GE.1) CALL CALPUV2C_mpi +C + MPI_WTIMES(9)=MPI_WTIMES(9)+MPI_TOC(STIME) +C + IF(.FALSE.)THEN + call collect_in_zero(UHDYE) + call collect_in_zero(VHDXE) + call collect_in_zero(HU ) + call collect_in_zero(HV ) + call collect_in_zero(P ) + call collect_in_zero(TBX ) + call collect_in_zero(TBY ) + call collect_in_zero(FCAXE) + call collect_in_zero(FCAYE) + call collect_in_zero(FPGXE) + call collect_in_zero(FPGYE) + call collect_in_zero(FXE ) + call collect_in_zero(FYE ) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'UHDYE = ', sum(abs(dble(UHDYE))) + PRINT*, n,'VHDXE = ', sum(abs(dble(VHDXE))) + PRINT*, n,'HU = ', sum(abs(dble(HU ))) + PRINT*, n,'HV = ', sum(abs(dble(HV ))) + PRINT*, n,'P = ', sum(abs(dble(P ))) + PRINT*, n,'TBX = ', sum(abs(dble(TBX ))) + PRINT*, n,'TBY = ', sum(abs(dble(TBY ))) + PRINT*, n,'FCAXE = ', sum(abs(dble(FCAXE))) + PRINT*, n,'FCAYE = ', sum(abs(dble(FCAYE))) + PRINT*, n,'FPGXE = ', sum(abs(dble(FPGXE))) + PRINT*, n,'FPGYE = ', sum(abs(dble(FPGYE))) + PRINT*, n,'FXE = ', sum(abs(dble(FXE ))) + PRINT*, n,'FYE = ', sum(abs(dble(FYE ))) + ENDIF + ENDIF +C + STIME=MPI_TIC() + CALL MPI_MASKDRY + MPI_WTIMES(62)=MPI_WTIMES(62)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** WRITE DIAGNOSTICS +C +C----------------------------------------------------------------------C +C +C ** DTIME AND FLUSH ARE SUPPORTED ON SUN SYSTEMS, BUT MAY NOT BE +C ** SUPPORTED ON OTHER SYSTEMS. +C + STIME=MPI_TIC() +C + IF(ISLOG.GE.1.AND.MYRANK.EQ.0)THEN + WRITE(8,17)N,ITER,RSQ,CFMAX,AVMAX,ABMIN,ABMAX,ABMIN + ENDIF +C + 17 FORMAT(' N,ITER,RSQ,CFMAX,AVMAX,AVMIN,ABMAX,ABMIN', + & I7,I5,2E12.4,4(1X,F8.4)) +C + ERRMAX=MAX(ERRMAX,ERR) + ERRMIN=MIN(ERRMIN,ERR) + ITRMAX=MAX(ITRMAX,ITER) + IRRMIN=MIN(ITRMIN,ITER) +C + MPI_WTIMES(48)=MPI_WTIMES(48)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** ADVANCE INTERNAL VARIABLES +C +C----------------------------------------------------------------------C + STIME=MPI_TIC() + CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) + MPI_WTIMES(63)=MPI_WTIMES(63)+MPI_TOC(STIME) +C + STIME=MPI_TIC() +C + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHDY2(L,K)=UHDY1(L,K) + UHDY1(L,K)=UHDY(L,K) + VHDX2(L,K)=VHDX1(L,K) + VHDX1(L,K)=VHDX(L,K) + U2(L,K)=U1(L,K) + V2(L,K)=V1(L,K) + U1(L,K)=U(L,K) + V1(L,K)=V(L,K) + W2(L,K)=W1(L,K) + W1(L,K)=W(L,K) + ENDDO + ENDDO +C + MPI_WTIMES(10)=MPI_WTIMES(10)+MPI_TOC(STIME) +C + STIME=MPI_TIC() + CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) + MPI_WTIMES(61)=MPI_WTIMES(61)+MPI_TOC(STIME) + STIME=MPI_TIC() + call broadcast_boundary_array(UHDY2,IC) + call broadcast_boundary_array(UHDY1,IC) + MPI_WTIMES(51)=MPI_WTIMES(51)+MPI_TOC(STIME) + STIME=MPI_TIC() + call broadcast_boundary_array(VHDX2,IC) + call broadcast_boundary_array(VHDX1,IC) + MPI_WTIMES(52)=MPI_WTIMES(52)+MPI_TOC(STIME) + STIME=MPI_TIC() + call broadcast_boundary_array(U2,IC) + call broadcast_boundary_array(V2,IC) + MPI_WTIMES(53)=MPI_WTIMES(53)+MPI_TOC(STIME) + STIME=MPI_TIC() + call broadcast_boundary_array(U1,IC) + call broadcast_boundary_array(V1,IC) + MPI_WTIMES(54)=MPI_WTIMES(54)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** SOLVE INTERNAL SHEAR MODE EQUATIONS FOR U, UHDY, V, VHDX, AND W +C +C----------------------------------------------------------------------C +C + STIME=MPI_TIC() +C + IF(KC.GT.1)THEN + CALL CALUVW_mpi (ISTL,IS2TL) + ELSE +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHDY(L,1)=UHDYE(L) + U(L,1)=UHDYE(L)*HUI(L)*DYIU(L) + VHDX(L,1)=VHDXE(L) + V(L,1)=VHDXE(L)*HVI(L)*DXIV(L) + W(L,1)=0. + ENDDO + CALL CALUVW_mpi (ISTL,IS2TL) + ENDIF + call broadcast_boundary_array(U,ic) + call broadcast_boundary_array(V,ic) +C + MPI_WTIMES(11)=MPI_WTIMES(11)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE SALINITY, TEMPERATURE, DYE AND SEDIMENT CONCENTRATIONS +C ** AT TIME LEVEL (N+1) +C +C----------------------------------------------------------------------C +C + STIME=MPI_TIC() + CALL CALCONC_mpi (ISTL,IS2TL) + MPI_WTIMES(12)=MPI_WTIMES(12)+MPI_TOC(STIME) +C +C----------------------------------------------------------------------C +C +C + ! *** PMC BYPASS IF NOT SIMULATING SEDIMENTS + STIME=MPI_TIC() +C + IF(ISTRAN(6).GT.0.OR.ISTRAN(7).GT.0)THEN + S1TIME=MPI_TIC() + DO K=1,KB +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SEDBT(L,K)=0. + SNDBT(L,K)=0. + ENDDO + ENDDO + MPI_WTIMES(551)=MPI_WTIMES(551)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + DO NS=1,NSED + DO K=1,KB +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SEDBT(L,K)=SEDBT(L,K)+SEDB(L,K,NS) + ENDDO + ENDDO + ENDDO + MPI_WTIMES(552)=MPI_WTIMES(552)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + DO NS=1,NSND + DO K=1,KB +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SNDBT(L,K)=SNDBT(L,K)+SNDB(L,K,NS) + ENDDO + ENDDO + ENDDO + MPI_WTIMES(553)=MPI_WTIMES(553)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SEDT(L,K)=0. + SNDT(L,K)=0. + ENDDO + ENDDO + MPI_WTIMES(554)=MPI_WTIMES(554)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + DO NS=1,NSED + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SEDT(L,K)=SEDT(L,K)+SED(L,K,NS) + ENDDO + ENDDO + ENDDO + MPI_WTIMES(555)=MPI_WTIMES(555)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + DO NS=1,NSND + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + SNDT(L,K)=SNDT(L,K)+SND(L,K,NS) + ENDDO + ENDDO + ENDDO + MPI_WTIMES(556)=MPI_WTIMES(556)+MPI_TOC(S1TIME) + ENDIF +C + MPI_WTIMES(13)=MPI_WTIMES(13)+MPI_TOC(STIME) +C +C----------------------------------------------------------------------C +C +C ** CHECK RANGE OF SALINITY AND DYE CONCENTRATION +C + STIME=MPI_TIC() +C + IF(ISMMC.EQ.1)THEN +C + SALMAX=-100000. + SALMIN=100000. + DO K=1,KC + DO L=2,LA + IF(SAL(L,K).GT.SALMAX)THEN + SALMAX=SAL(L,K) + IMAX=IL(L) + JMAX=JL(L) + KMAX=K + ENDIF + IF(SAL(L,K).LT.SALMIN)THEN + SALMIN=SAL(L,K) + IMIN=IL(L) + JMIN=JL(L) + KMIN=K + ENDIF + ENDDO + ENDDO +C + IF(MYRANK.EQ.0) WRITE(6,6001)N + IF(MYRANK.EQ.0) WRITE(6,6002)SALMAX,IMAX,JMAX,KMAX + IF(MYRANK.EQ.0) WRITE(6,6003)SALMIN,IMIN,JMIN,KMIN +C + SALMAX=-100000. + SALMIN=100000. + DO K=1,KC + DO L=2,LA + IF(DYE(L,K).GT.SALMAX)THEN + SALMAX=DYE(L,K) + IMAX=IL(L) + JMAX=JL(L) + KMAX=K + ENDIF + IF(DYE(L,K).LT.SALMIN)THEN + SALMIN=DYE(L,K) + IMIN=IL(L) + JMIN=JL(L) + KMIN=K + ENDIF + ENDDO + ENDDO +C + IF(MYRANK.EQ.0) WRITE(6,6004)SALMAX,IMAX,JMAX,KMAX + IF(MYRANK.EQ.0) WRITE(6,6005)SALMIN,IMIN,JMIN,KMIN +C + IF(MYRANK.EQ.0) WRITE(8,6004)SALMAX,IMAX,JMAX,KMAX + IF(MYRANK.EQ.0) WRITE(8,6005)SALMIN,IMIN,JMIN,KMIN +C + SALMAX=-100000. + SALMIN=100000. + DO K=1,KC + DO L=2,LA + IF(SFL(L,K).GT.SALMAX)THEN + SALMAX=SFL(L,K) + IMAX=IL(L) + JMAX=JL(L) + KMAX=K + ENDIF + IF(SFL(L,K).LT.SALMIN)THEN + SALMIN=SFL(L,K) + IMIN=IL(L) + JMIN=JL(L) + KMIN=K + ENDIF + ENDDO + ENDDO +C + WRITE(6,6006)SALMAX,IMAX,JMAX,KMAX + WRITE(6,6007)SALMIN,IMIN,JMIN,KMIN +C + ENDIF +C +C + IF(ISMMC.EQ.2)THEN +C + SALMAX=-100000. + SALMIN=100000. + DO K=1,KC + DO L=2,LA + IF(TEM(L,K).GT.SALMAX)THEN + SALMAX=TEM(L,K) + IMAX=IL(L) + JMAX=JL(L) + KMAX=K + ENDIF + IF(TEM(L,K).LT.SALMIN)THEN + SALMIN=TEM(L,K) + IMIN=IL(L) + JMIN=JL(L) + KMIN=K + ENDIF + ENDDO + ENDDO +C + WRITE(6,6001)N + WRITE(6,6008)SALMAX,IMAX,JMAX,KMAX + WRITE(6,6009)SALMIN,IMIN,JMIN,KMIN +C + ENDIF +C + MPI_WTIMES(14)=MPI_WTIMES(14)+MPI_TOC(STIME) +C + 6001 FORMAT(' N=',I10) + 6002 FORMAT(' SALMAX=',F14.4,5X,'I,J,K=',(3I10)) + 6003 FORMAT(' SALMIN=',F14.4,5X,'I,J,K=',(3I10)) + 6004 FORMAT(' DYEMAX=',F14.4,5X,'I,J,K=',(3I10)) + 6005 FORMAT(' DYEMIN=',F14.4,5X,'I,J,K=',(3I10)) + 6006 FORMAT(' SFLMAX=',F14.4,5X,'I,J,K=',(3I10)) + 6007 FORMAT(' SFLMIN=',F14.4,5X,'I,J,K=',(3I10)) + 6008 FORMAT(' TEMMAX=',F14.4,5X,'I,J,K=',(3I10)) + 6009 FORMAT(' TEMMIN=',F14.4,5X,'I,J,K=',(3I10)) + + STIME=MPI_TIC() + ! *** DSLLC + IF(DEBUG.AND.MYRANK.EQ.-1)THEN + S1TIME=MPI_TIC() + BTEST=.FALSE. + LTEST=.FALSE. + DO L=2,LA + IF(ISNAN(HP(L)))THEN + BTEST=.TRUE. + IF(.NOT.LTEST)THEN + OPEN(1,FILE='ERROR.LOG',POSITION='APPEND', + & STATUS='UNKNOWN') + WRITE(1,*)' * DEBUG: ERROR IN DEPTH VARIABLES' + ENDIF + WRITE(1,910) TIMEDAY, L, IL(L), JL(L), + & HP(L),H1P(L) + HP(L)=H1P(L) + LTEST=.TRUE. + ENDIF + ENDDO + IF(LTEST)CLOSE(1,STATUS='KEEP') + MPI_WTIMES(571)=MPI_WTIMES(571)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + LTEST=.FALSE. + IF(KC.GT.1)THEN + DO L=2,LA + DO K=1,KC + IF(ISNAN(AV(L,K)))THEN + BTEST=.TRUE. + IF(.NOT.LTEST)THEN + OPEN(1,FILE='ERROR.LOG',POSITION='APPEND', + & STATUS='UNKNOWN') + WRITE(1,*)' * DEBUG: ERROR IN VERTICAL VISCOSITY' + ENDIF + WRITE(1,9101) TIMEDAY, L, IL(L), JL(L), K, 'AV ', + & AV(L,K) + LTEST=.TRUE. + ENDIF + ENDDO + ENDDO + ENDIF + IF(LTEST)CLOSE(1,STATUS='KEEP') + MPI_WTIMES(572)=MPI_WTIMES(572)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + LTEST=.FALSE. + IF(ISTRAN(1).GE.1)THEN + DO L=2,LA + DO K=1,KC + IF(ISNAN(SAL(L,K)))THEN + BTEST=.TRUE. + IF(.NOT.LTEST)THEN + OPEN(1,FILE='ERROR.LOG',POSITION='APPEND', + & STATUS='UNKNOWN') + WRITE(1,*)' * DEBUG: ERROR IN SALINITY VARIABLES' + ENDIF + WRITE(1,911) TIMEDAY, L, IL(L), JL(L), K, + & SAL(L,K),SAL1(L,K) + SAL(L,K)=SAL1(L,K) + LTEST=.TRUE. + ENDIF + ENDDO + ENDDO + ENDIF + IF(LTEST)CLOSE(1,STATUS='KEEP') + MPI_WTIMES(573)=MPI_WTIMES(573)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() + LTEST=.FALSE. + IF(ISTRAN(2).GE.1)THEN + DO L=2,LA + DO K=1,KC + IF(ISNAN(TEM(L,K)))THEN + BTEST=.TRUE. + IF(.NOT.LTEST)THEN + OPEN(1,FILE='ERROR.LOG',POSITION='APPEND', + & STATUS='UNKNOWN') + WRITE(1,*)' * DEBUG: ERROR IN TEMPERATURE VARIABLES' + ENDIF + WRITE(1,912) TIMEDAY, L, IL(L), JL(L), K, + & TEM(L,K),TEM1(L,K) + TEM(L,K)=TEM1(L,K) + LTEST=.TRUE. + ENDIF + ENDDO + ENDDO + ENDIF + IF(LTEST) then + CLOSE(1,STATUS='KEEP') + PRINT*, "ERROR IN VARIABLES, CHECK ERROR.LOG" + STOP + END IF + + MPI_WTIMES(574)=MPI_WTIMES(574)+MPI_TOC(S1TIME) + +!{ GEOSR 2012.8.30 jgcho + S1TIME=MPI_TIC() + LTEST=.FALSE. + IF(ISTRAN(3).GE.1)THEN + DO L=2,LA + DO K=1,KC + IF(ISNAN(DYE(L,K)))THEN + BTEST=.TRUE. + IF(.NOT.LTEST)THEN + OPEN(1,FILE='ERROR.LOG',POSITION='APPEND', + & STATUS='UNKNOWN') + WRITE(1,*)' * DEBUG: ERROR IN DYE VARIABLES' + ENDIF + WRITE(1,912) TIMEDAY, L, IL(L), JL(L), K, + & DYE(L,K),DYE1(L,K) + DYE(L,K)=DYE1(L,K) + LTEST=.TRUE. + ENDIF + ENDDO + ENDDO + ENDIF + IF(LTEST)CLOSE(1,STATUS='KEEP') + MPI_WTIMES(575)=MPI_WTIMES(575)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + LTEST=.FALSE. + IF(ISTRAN(6).GE.1)THEN + ERRTEST=.FALSE. + DO NS=1,NSED + DO K=1,KC + DO L=LMPI2,LMPILA + IF(ISNAN(SED(L,K,NS)))THEN + ERRTEST=.TRUE. + ENDIF + ENDDO + ENDDO + ENDDO + CALL MPI_ALLREDUCE(ERRTEST,MPI_LG,1,MPI_LOGICAL,MPI_LOR, + & MPI_COMM_WORLD,IERR) + ERRTEST=MPI_LG + IF(ERRTEST)THEN + DO NS=1,NSED + DO K=1,KC + DO L=2,LA + IF(ISNAN(SED(L,K,NS)))THEN + BTEST=.TRUE. + IF(.NOT.LTEST)THEN + OPEN(1,FILE='ERROR.LOG',POSITION='APPEND', + & STATUS='UNKNOWN') + WRITE(1,*)' * DEBUG: ERROR IN SED VARIABLES' + ENDIF + WRITE(1,916) TIMEDAY, L, IL(L), JL(L), K, NS, + & SED(L,K,NS),SED1(L,K,NS) + SED(L,K,NS)=SED1(L,K,NS) + LTEST=.TRUE. + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + IF(LTEST)CLOSE(1,STATUS='KEEP') + MPI_WTIMES(577)=MPI_WTIMES(577)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + LTEST=.FALSE. + IF(ISTRAN(7).GE.1)THEN + DO L=2,LA + DO K=1,KC + DO NS=1,NSND + IF(ISNAN(SND(L,K,NS)))THEN + BTEST=.TRUE. + IF(.NOT.LTEST)THEN + OPEN(1,FILE='ERROR.LOG',POSITION='APPEND', + & STATUS='UNKNOWN') + WRITE(1,*)' * DEBUG: ERROR IN SAND VARIABLES' + ENDIF + WRITE(1,917) TIMEDAY, L, IL(L), JL(L), K, NS, + & SND(L,K,NS),SND(L,K,NS) + SND(L,K,NS)=SND1(L,K,NS) + LTEST=.TRUE. + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + IF(LTEST)CLOSE(1,STATUS='KEEP') + MPI_WTIMES(577)=MPI_WTIMES(577)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + LTEST=.FALSE. + IF(ISTRAN(8).GE.1)THEN + ERRTEST=.FALSE. + DO NW=1,21 + DO K=1,KC + DO L=LMPI2,LMPILA + IF(ISNAN(WQV(L,K,NW)))THEN + ERRTEST=.TRUE. + ENDIF + ENDDO + ENDDO + ENDDO + CALL MPI_ALLREDUCE(ERRTEST,MPI_LG,1,MPI_LOGICAL,MPI_LOR, + & MPI_COMM_WORLD,IERR) + ERRTEST=MPI_LG + IF(ERRTEST)THEN + DO NW=1,21 + DO K=1,KC + DO L=2,LA + IF(ISNAN(WQV(L,K,NW)))THEN + BTEST=.TRUE. + OPEN(1,FILE='ERROR.LOG',POSITION='APPEND', + & STATUS='UNKNOWN') + WRITE(1,*)' * DEBUG: ERROR IN WATER QUALITY VARIABLES' + WRITE(1,918) TIMEDAY, L, IL(L), JL(L), K, NW, + & WQV(L,K,NW),WQVO(L,K,NW) + CLOSE(1,STATUS='KEEP') + WQV(L,K,NW)=WQVO(L,K,NW) + LTEST=.TRUE. + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + IF(LTEST)CLOSE(1,STATUS='KEEP') + MPI_WTIMES(579)=MPI_WTIMES(579)+MPI_TOC(S1TIME) + ENDIF + + 910 FORMAT('ERROR: TIME, L, I, J, HP = ', F10.5,3I6,2F10.4) + 9101 FORMAT('ERROR: TIME, L, I, J, K, ',A3,' = ', F10.5,4I6,2F10.4) + 911 FORMAT('ERROR: TIME, L, I, J, K, SAL = ', F10.5,4I6,2F10.4) + 912 FORMAT('ERROR: TIME, L, I, J, K, TEM = ', F10.5,4I6,2F10.4) + 916 FORMAT('ERROR: TIME, L, I, J, K, NS, SED = ',F10.5,5I6,2F10.4) + 917 FORMAT('ERROR: TIME, L, I, J, K, NX, SND = ',F10.5,5I6,2F10.4) + 918 FORMAT('ERROR: TIME, L, I, J, K, NW, WQV = ',F10.5,5I6,2F10.4) + + ! *** DUMP THE RESULTS (JUST PRIOR) TO EE FOR ANALYSIS + IF(DEBUG.AND.MYRANK.EQ.-1)THEN + S1TIME=MPI_TIC() + IF(BTEST)THEN + CALL SURFPLT + CALL VELPLTH_mpi + CALL EEXPOUT_mpi(-1) + CLOSE(7) + CLOSE(8) + CLOSE(9) + STOP 'ERROR: NANs have been computed!' + ENDIF + MPI_WTIMES(580)=MPI_WTIMES(580)+MPI_TOC(S1TIME) + ENDIF +C + MPI_WTIMES(15)=MPI_WTIMES(15)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE SHELL FISH LARVAE AND/OR WATER QUALITY CONSTITUENT +C ** CONCENTRATIONS AT TIME LEVEL (N+1) AFTER SETTING DOUBLE TIME +C ** STEP TRANSPORT FIELD +C +C----------------------------------------------------------------------C +C + STIME=MPI_TIC() +C + ITMP=0 + IF(ISTRAN(4).GE.1) ITMP=1 + IF(ISTRAN(8).GE.1) ITMP=1 + IF(ISWASP.GE.1)ITMP=1 ! 6/7/2005 a stoddard dsllc + IF(ISICM.GE.1) ITMP=1 +C + IF(ITMP.EQ.1)THEN +C +C ** CALCULATE CONSERVATION OF VOLUME FOR THE WATER QUALITY ADVECTION +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + HWQ(L)=HP(L) + WWQ(L,0)=0. + ENDDO +C + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + UHDYWQ(L,K)=UHDY2(L,K) + VHDXWQ(L,K)=VHDX2(L,K) + UWQ(L,K)=U2(L,K) + VWQ(L,K)=V2(L,K) + WWQ(L,K)=W2(L,K) + ENDDO + ENDDO +C +C ADD CHANNEL INTERACTIONS +C + + IF(MDCHH.GE.1)THEN + DO NMD=1,MDCHH + IF(MDCHTYP(NMD).EQ.1)THEN + HWQ(LMDCHH(NMD))=HWQ(LMDCHH(NMD)) + & +DT2*DXYIP(LMDCHH(NMD))*(QCHANU(NMD)) + HWQ(LMDCHU(NMD))=HWQ(LMDCHU(NMD)) + & -DT2*DXYIP(LMDCHU(NMD))*(QCHANU(NMD)) + ENDIF + IF(MDCHTYP(NMD).EQ.2)THEN + HWQ(LMDCHH(NMD))=HWQ(LMDCHH(NMD)) + & +DT2*DXYIP(LMDCHH(NMD))*(QCHANV(NMD)) + HWQ(LMDCHV(NMD))=HWQ(LMDCHV(NMD)) + & -DT2*DXYIP(LMDCHV(NMD))*(QCHANV(NMD)) + ENDIF + IF(MDCHTYP(NMD).EQ.3)THEN + HWQ(LMDCHH(NMD))=HWQ(LMDCHH(NMD)) + & +DT2*DXYIP(LMDCHH(NMD))*(QCHANU(NMD)) + & +DT2*DXYIP(LMDCHH(NMD))*(QCHANV(NMD)) + HWQ(LMDCHU(NMD))=HWQ(LMDCHU(NMD)) + & -DT2*DXYIP(LMDCHU(NMD))*(QCHANU(NMD)) + HWQ(LMDCHV(NMD))=HWQ(LMDCHV(NMD)) + & -DT2*DXYIP(LMDCHV(NMD))*(QCHANV(NMD)) + ENDIF + ENDDO + ENDIF +C +C END ADD CHANNEL INTERACTIONS +C + IF(ISTRAN(8).GE.1) CALL WQ3D_mpi(ISTL,IS2TL) +C + IF(ISTRAN(4).GE.1) CALL CALSFT_mpi(ISTL,IS2TL) +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + H2WQ(L)=HWQ(L) + ENDDO +C + ENDIF +C + MPI_WTIMES(16)=MPI_WTIMES(16)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** UPDATE BUOYANCY AND CALCULATE NEW BUOYANCY USING +C ** AN EQUATION OF STATE +C + STIME=MPI_TIC() +C + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + B1(L,K)=B(L,K) + ENDDO + ENDDO +C + IF(BSC.GT.1.E-6)THEN + CALL CALBUOY_mpi + ELSE + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + B(L,K)=0. + ENDDO + ENDDO + ENDIF +C + MPI_WTIMES(17)=MPI_WTIMES(17)+MPI_TOC(STIME) +C + STIME=MPI_TIC() + CALL broadcast_boundary_array(B1,ic) + CALL broadcast_boundary_array(B,ic) + MPI_WTIMES(55)=MPI_WTIMES(55)+MPI_TOC(STIME) +C +C +C ** CALL TWO-TIME LEVEL BALANCES +C + STIME=MPI_TIC() +C + IF(ISBAL.GE.1)THEN + CALL BAL2T4 + ENDIF +C + MPI_WTIMES(18)=MPI_WTIMES(18)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE U AT V AND V AT U AT TIME LEVEL (N+1) +C +C----------------------------------------------------------------------C +C + STIME=MPI_TIC() +C +!$OMP PARALLEL DO PRIVATE(LN,LS,LNW,LSE,LSW) + DO L=LMPI2,LMPILA + LN=LNC(L) + LS=LSC(L) + LNW=LNWC(L) + LSE=LSEC(L) + LSW=LSWC(L) + U1V(L)=UV(L) + V1U(L)=VU(L) + UV(L)=0.25*(HP(LS)*(U(LSE,1)+U(LS,1)) + & +HP(L)*(U(L+1,1)+U(L,1)))*HVI(L) + VU(L)=0.25*(HP(L-1)*(V(LNW,1)+V(L-1,1)) + & +HP(L)*(V(LN,1)+V(L,1)))*HUI(L) + ENDDO +C + MPI_WTIMES(19)=MPI_WTIMES(19)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE HORIZONTAL VISCOSITY AND MOMENTUM DIFFUSION FLUXES +C ** AT TIME LEVEL (N) +C + STIME=MPI_TIC() +C + IF(ISHDMF.GE.1) CALL CALHDMF_mpi +C + MPI_WTIMES(20)=MPI_WTIMES(20)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE BOTTOM STRESS AT LEVEL (N+1) +C + STIME=MPI_TIC() +C + CALL CALTBXY_mpi(ISTL,IS2TL) +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TBX(L)=(AVCON1*HUI(L)+STBX(L)*SQRT(VU(L)*VU(L) + & +U(L,1)*U(L,1)))*U(L,1) + TBY(L)=(AVCON1*HVI(L)+STBY(L)*SQRT(UV(L)*UV(L) + & +V(L,1)*V(L,1)))*V(L,1) + ENDDO + MPI_WTIMES(21)=MPI_WTIMES(21)+MPI_TOC(STIME) +C + STIME=MPI_TIC() + CALL broadcast_boundary(TBX,ic) + CALL broadcast_boundary(TBY,ic) + MPI_WTIMES(56)=MPI_WTIMES(56)+MPI_TOC(STIME) +C +C +C**********************************************************************C +C +C ** SET DEPTH DEVIATION FROM UNIFORM FLOW ON FLOW FACES +C + STIME=MPI_TIC() +C + IF(ISBSDFUF.GE.1)THEN + HDFUFM=1.E-12 +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + LS=LSC(L) + HDFUFX(L)=HDFUFM+G*SUB(L)*HU(L)*(BELV(L-1)-BELV(L))*DXIU(L) + HDFUFY(L)=HDFUFM+G*SVB(L)*HV(L)*(BELV(LS )-BELV(L))*DYIV(L) + ENDDO +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + HDFUFX(L)=TBX(L)/HDFUFX(L) + HDFUFY(L)=TBY(L)/HDFUFY(L) + ENDDO +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + HDFUFX(L)=MAX(HDFUFX(L),-1.0) + HDFUFY(L)=MAX(HDFUFY(L),-1.0) + ENDDO +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + HDFUFX(L)=MIN(HDFUFX(L),1.0) + HDFUFY(L)=MIN(HDFUFY(L),1.0) + ENDDO +C + ENDIF +C + MPI_WTIMES(22)=MPI_WTIMES(22)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** SET BOTTOM AND SURFACE TURBULENT INTENSITY SQUARED AT (N+1) +C +C----------------------------------------------------------------------C +C +C + IF(ISWAVE.EQ.0)THEN +C +C +C----------------------------------------------------------------------c +C + IF(ISCORTBC.EQ.0) THEN +C + STIME=MPI_TIC() + S1TIME=MPI_TIC() +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR3S(L)=TSY(LNC(L)) + TVAR3W(L)=TSX(L+1) + TVAR3E(L)=TBX(L+1 ) + TVAR3N(L)=TBY(LNC(L)) + ENDDO + MPI_WTIMES(891)=MPI_WTIMES(891)+MPI_TOC(S1TIME) +C + S1TIME=MPI_TIC() +!$OMP PARALLEL DO PRIVATE(TMP) + DO L=LMPI2,LMPILA +! { GEOSR (IBM request) + IF (ISNAN(TVAR3S(L))) TVAR3S(L)=0. + IF (ISNAN(TVAR3W(L))) TVAR3W(L)=0. + IF (ISNAN(TVAR3E(L))) TVAR3E(L)=0. + IF (ISNAN(TVAR3N(L))) TVAR3N(L)=0. + IF (ISNAN(TSY(L))) TSY(L)=0. + IF (ISNAN(TSX(L))) TSX(L)=0. + IF (ISNAN(TBY(L))) TBY(L)=0. + IF (ISNAN(TBX(L))) TBX(L)=0. +! } GEOSR (IBM request) + TMP = (RSSBCE(L)*TVAR3E(L)+RSSBCW(L)*TBX(L))**2 + & +(RSSBCN(L)*TVAR3N(L)+RSSBCS(L)*TBY(L))**2 + QQ(L,0 )=0.5*CTURB2*SQRT(TMP) + + TMP = (RSSBCE(L)*TVAR3W(L)+RSSBCW(L)*TSX(L))**2 + & +(RSSBCN(L)*TVAR3S(L)+RSSBCS(L)*TSY(L))**2 + QQ(L,KC)=0.5*CTURB2*SQRT(TMP) + + QQSQR(L,0)=SQRT(QQ(L,0)) ! *** DSLLC + ENDDO + MPI_WTIMES(892)=MPI_WTIMES(892)+MPI_TOC(S1TIME) + MPI_WTIMES(23)=MPI_WTIMES(23)+MPI_TOC(STIME) +C + ENDIF +C +C----------------------------------------------------------------------c +C + STIME=MPI_TIC() +C + IF(ISCORTBC.GE.1) THEN +C + IF(ISCORTBCD.GE.1)THEN + NTMPVAL=MOD(N,NTSPTC) + IF(NTMPVAL.EQ.0.AND.DEBUG)THEN + OPEN(1,FILE='ADJSTRESSE.OUT',ACCESS='APPEND') + ENDIF + ENDIF +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR3S(L)=TSY(LNC(L)) + TVAR3W(L)=TSX(L+1) + TVAR3E(L)=TBX(L+1 ) + TVAR3N(L)=TBY(LNC(L)) + ENDDO +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WCOREST(L)=1. + WCORWST(L)=1. + WCORNTH(L)=1. + WCORSTH(L)=1. + ENDDO +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(ISSBCP(L).EQ.0)THEN + IF(SUB(L+1).LT.0.5)WCOREST(L)=FSCORTBCV(L) + IF(SUB(L).LT.0.5)WCORWST(L)=FSCORTBCV(L) + IF(SVB(LNC(L)).LT.0.5)WCORNTH(L)=FSCORTBCV(L) + IF(SVB(L).LT.0.5)WCORSTH(L)=FSCORTBCV(L) + ENDIF + ENDDO +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WCOREW(L)=1./(WCOREST(L)+WCORWST(L)) + WCORNS(L)=1./(WCORNTH(L)+WCORSTH(L)) + ENDDO +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WCOREST(L)=WCOREST(L)*WCOREW(L) + WCORWST(L)=WCORWST(L)*WCOREW(L) + WCORNTH(L)=WCORNTH(L)*WCORNS(L) + WCORSTH(L)=WCORSTH(L)*WCORNS(L) + ENDDO +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA +! { GEOSR (IBM request) + IF (ISNAN(TVAR3S(L))) TVAR3S(L)=0. + IF (ISNAN(TVAR3W(L))) TVAR3W(L)=0. + IF (ISNAN(TVAR3E(L))) TVAR3E(L)=0. + IF (ISNAN(TVAR3N(L))) TVAR3N(L)=0. + IF (ISNAN(TSY(L))) TSY(L)=0. + IF (ISNAN(TSX(L))) TSX(L)=0. + IF (ISNAN(TBY(L))) TBY(L)=0. + IF (ISNAN(TBX(L))) TBX(L)=0. +! } GEOSR (IBM request) + QQ(L,0 )=CTURB2*SQRT( + & (RSSBCE(L)*WCOREST(L)*TVAR3E(L) + & +RSSBCW(L)*WCORWST(L)*TBX(L))**2 + & +(RSSBCN(L)*WCORNTH(L)*TVAR3N(L) + & +RSSBCS(L)*WCORSTH(L)*TBY(L))**2) + QQ(L,KC)=0.5*CTURB2*SQRT( + & (RSSBCE(L)*TVAR3W(L)+RSSBCW(L)*TSX(L))**2 + & +(RSSBCN(L)*TVAR3S(L)+RSSBCS(L)*TSY(L))**2) + QQSQR(L,0)=SQRT(QQ(L,0)) ! *** DSLLC + ENDDO +C + IF(ISCORTBCD.GE.1.AND.NTMPVAL.EQ.0)THEN +C +!$OMP PARALLEL DO PRIVATE(KCORNER) + DO L=LMPI2,LMPILA + LCORNER(L)=0 + KCORNER=0 + IF(WCORWST(L).GT.0.505)THEN + KCORNER=KCORNER+1 + LCORNWE(L)=L-1 + ENDIF + IF(WCOREST(L).GT.0.505)THEN + KCORNER=KCORNER+1 + LCORNWE(L)=L+1 + ENDIF + IF(WCORNTH(L).GT.0.505)THEN + KCORNER=KCORNER+1 + LCORNSN(L)=LNC(L) + ENDIF + IF(WCORSTH(L).GT.0.505)THEN + KCORNER=KCORNER+1 + LCORNSN(L)=LSC(L) + ENDIF + IF(KCORNER.EQ.2)LCORNER(L)=1 + ENDDO +C + NCORCELLS=0 +!$OMP PARALLEL DO REDUCTION(+:NCORCELLS) + DO L=LMPI2,LMPILA + NCORCELLS=NCORCELLS+LCORNER(L) + ENDDO + CALL MPI_ALLREDUCE(NCORCELLS,MPI_I4,1,MPI_INT,MPI_SUM, + & MPI_COMM_WORLD,IERR) + NCORCELLS=MPI_I4 +C + IF(DEBUG.AND.MYRANK.EQ.0)THEN + WRITE(1,3675)TIMEDAY,NCORCELLS + DO L=2,LA + IF(LMASKDRY(L))THEN + IF(LCORNER(L).EQ.1)THEN + LWE=LCORNWE(L) + LSN=LCORNSN(L) + TAUTMP=QQ(L,0)/CTURB2 + TAUTMPWE=QQ(LWE,0)/CTURB2 + TAUTMPSN=QQ(LSN,0)/CTURB2 + WRITE(1,3677)IL(L),JL(L),TAUTMP,TAUBSND(L), + & TAUBSED(L) + WRITE(1,3676)IL(LWE),JL(LWE),TAUTMPWE,TAUBSND(LWE), + & TAUBSED(LWE) + WRITE(1,3676)IL(LSN),JL(LSN),TAUTMPSN,TAUBSND(LSN), + & TAUBSED(LSN) + ENDIF + ENDIF + ENDDO + ENDIF +C + ENDIF + + IF(DEBUG)CLOSE(1) +C + ENDIF +C +C----------------------------------------------------------------------c +C + ENDIF +C + MPI_WTIMES(25)=MPI_WTIMES(25)+MPI_TOC(STIME) +C + 3678 FORMAT(2I6,4F13.3) +C3679 FORMAT(12x,4F13.3) +C3680 FORMAT(12x,6F13.5) +C3681 FORMAT(12X,5E13.4,F13.5) + 3677 FORMAT('CORNER',2I5,5E14.5) + 3676 FORMAT(6X,2I5,5E14.5) + 3675 FORMAT(F11.3,I6,' TIME IN DAYS AND NUMBER OF CORNERS') +C +C +C**********************************************************************C +C +C ** SET BOTTOM AND SURFACE TURBULENT INTENSITY SQUARED AT (N+1) +C +C----------------------------------------------------------------------C +C + STIME=MPI_TIC() +C + IF(ISWAVE.GE.1)THEN +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TVAR3S(L)=TSY(LNC(L)) + TVAR3W(L)=TSX(L+1) + TVAR3E(L)=TBX(L+1 ) + TVAR3N(L)=TBY(LNC(L)) + ENDDO +C +!$OMP PARALLEL DO PRIVATE(TAUBC2,TAUBC,UTMP,VTMP,CURANG) + DO L=LMPI2,LMPILA +! { GEOSR (IBM request) + IF (ISNAN(TVAR3S(L))) TVAR3S(L)=0. + IF (ISNAN(TVAR3W(L))) TVAR3W(L)=0. + IF (ISNAN(TVAR3E(L))) TVAR3E(L)=0. + IF (ISNAN(TVAR3N(L))) TVAR3N(L)=0. + IF (ISNAN(TSY(L))) TSY(L)=0. + IF (ISNAN(TSX(L))) TSX(L)=0. + IF (ISNAN(TBY(L))) TBY(L)=0. + IF (ISNAN(TBX(L))) TBX(L)=0. +! } GEOSR (IBM request) + TAUBC2 = (RSSBCE(L)*TVAR3E(L)+RSSBCW(L)*TBX(L))**2 + & +(RSSBCN(L)*TVAR3N(L)+RSSBCS(L)*TBY(L))**2 + TAUBC=0.5*SQRT(TAUBC2) + UTMP=0.5*STCUV(L)*(U(L+1,1)+U(L,1))+1.E-12 + VTMP=0.5*STCUV(L)*(V(LN,1)+V(L,1)) + CURANG=ATAN2(VTMP,UTMP) + TAUB2=TAUBC*TAUBC+0.5*(QQWV1(L)*QQWV1(L)) + & +FOURDPI*TAUBC*QQWV1(L)*COS(CURANG-WACCWE(L)) + TAUB2=MAX(TAUB2,0.) + QQ(L,0 )=CTURB2*SQRT(TAUB2) + QQ(L,KC)=0.5*CTURB2*SQRT((TVAR3W(L)+TSX(L))**2 + & +(TVAR3S(L)+TSY(L))**2) + QQSQR(L,0)=SQRT(QQ(L,0)) ! *** DSLLC + ENDDO +C + ENDIF +C + MPI_WTIMES(26)=MPI_WTIMES(26)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE TURBULENT INTENSITY SQUARED +C + STIME=MPI_TIC() +C + IF(KC.GT.1)THEN + IF(ISQQ.EQ.1)THEN + IF(ISTOPT(0).EQ.0)CALL CALQQ2TOLD_mpi (ISTL) + IF(ISTOPT(0).GE.1)CALL CALQQ2T_mpi (ISTL) + ENDIF + IF(ISQQ.EQ.2) CALL CALQQ2 (ISTL) + ENDIF +C + MPI_WTIMES(27)=MPI_WTIMES(27)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE MEAN MASS TRANSPORT FIELD +C + STIME=MPI_TIC() +C + IF(ISSSMMT.NE.2)THEN + IF(ISICM.GE.1)THEN + NTMP=MOD(N,2) + IF(ISTL.EQ.3.AND.NTMP.EQ.0) CALL CALMMT + ENDIF + ENDIF +C +C IF(ISSSMMT.NE.2) CALL CALMMT +C + MPI_WTIMES(28)=MPI_WTIMES(28)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** HYDRODYNAMIC CALCULATIONS FOR THIS TIME STEP ARE COMPLETED +C +C**********************************************************************C +C +C ** WRITE TO TIME SERIES FILES +C + STIME=MPI_TIC() +C + IF(ISDYNSTP.EQ.0)THEN + CTIM=DT*FLOAT(N)+TCON*TBEGIN + CTIM=CTIM/TCON + ELSE + CTIM=TIMESEC/TCON + ENDIF +C +CDYN IF(ISTMSR.GE.1)THEN +CDYN IF(N.GE.NBTMSR.AND.N.LE.NSTMSR)THEN +CDYN IF(NCTMSR.EQ.NWTMSR)THEN +CDYN CALL TMSR +CDYN ICALLTP=1 +CDYN NCTMSR=1 +CDYN ELSE +CDYN NCTMSR=NCTMSR+1 +CDYN ENDIF +CDYN ENDIF +CDYN ENDIF +C +C + IF(ISTMSR.GE.1)THEN +c IF(N.GE.NBTMSR.AND.N.LE.NSTMSR)THEN + IF(NCTMSR.GE.NWTMSR)THEN + CALL TMSR + NDIFF=NWTMSR-NCTMSR + ICALLTP=1 + NCTMSR=NINCRMT+NDIFF + ELSE + NCTMSR=NCTMSR+NINCRMT + ENDIF +c ENDIF + ENDIF +C +C**************************************************** +C ** WRITE TO DUMP FILES ******************C +C +C + IF(ISDUMP.GE.1)THEN + IF(CTIM.GE.TSDUMP.AND.CTIM.LE.TEDUMP)THEN +C IF(NCDUMP.EQ.NSDUMP)THEN + IF(NCDUMP.GE.NSDUMP)THEN + CALL DUMP + NDIFF=NSDUMP-NCDUMP + ICALLTP=1 +C NCDUMP=1 + NCDUMP=NINCRMT+NDIFF + ELSE +C NCDUMP=NCDUMP+1 + NCDUMP=NCDUMP+NINCRMT + ENDIF + ENDIF + ENDIF +C +C**********************************************************************C +C +C ** OUTPUT ZERO DIMENSION VOLUME BALANCE +C +C----------------------------------------------------------------------C +C + IF(ISDRY.GE.1.AND.ISDRY.LT.98)THEN + IF(ICALLTP.EQ.1.AND.DEBUG)THEN + OPEN(1,FILE='ZVOLBAL.OUT',POSITION='APPEND',STATUS='UNKNOWN') + DO LS=1,LORMAX + IF(VOLZERD.GE.VOLSEL(LS).AND.VOLZERD.LT.VOLSEL(LS+1))THEN + WTM=VOLSEL(LS+1)-VOLZERD + WTMP=VOLZERD-VOLSEL(LS) + DELVOL=VOLSEL(LS+1)-VOLSEL(LS) + WTM=WTM/DELVOL + WTMP=WTMP/DELVOL + SELZERD=WTM*BELSURF(LS)+WTMP*BELSURF(LS+1) + ASFZERD=WTM*ASURFEL(LS)+WTMP*ASURFEL(LS+1) + ENDIF + ENDDO + IF(ISDYNSTP.EQ.0)THEN + CTIM=DT*FLOAT(N)+TCON*TBEGIN + CTIM=CTIM/TCTMSR + ELSE + CTIM=TIMESEC/TCTMSR + ENDIF + WRITE(1,5304) CTIM,SELZERD,ASFZERD,VOLZERD,VETZERD + CLOSE(1) + ENDIF + ENDIF + ICALLTP=0 +C + 5304 FORMAT(2X,F10.4,2X,F10.5,3(2X,E12.4)) +C +C**********************************************************************C +C +C ** WRITE VERTICAL SCALAR FIELD PROFILES +C + IF(ISVSFP.EQ.1)THEN + IF(N.GE.NBVSFP.AND.N.LE.NSVSFP)THEN + CALL VSFP + ENDIF + ENDIF +C + MPI_WTIMES(29)=MPI_WTIMES(29)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE MEAN MASS TRANSPORT FIELD +C + STIME=MPI_TIC() +C + IF(ISSSMMT.NE.2)THEN + IF(ISICM.EQ.0) CALL CALMMT + ENDIF +C +C IF(ISSSMMT.NE.2) CALL CALMMT +C + MPI_WTIMES(30)=MPI_WTIMES(30)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** ADVANCE NEUTRALLY BUOYANT PARTICLE DRIFTER TRAJECTORIES +C + !IF(ISPD.EQ.1)THEN + ! IF(N.GE.NPDRT) CALL DRIFTER +C + STIME=MPI_TIC() +C +!{GEOSR, OIL, CWCHO, 101122 + IF(ISPD.GE.2.AND.IDTOX.LT.4440) THEN !DHC + IF (TIMEDAY.GE.LA_BEGTI.AND.TIMEDAY.LE.LA_ENDTI) THEN + CALL CPU_TIME(T1TMP) + CALL DRIFTERC + CALL CPU_TIME(T2TMP) + TLRPD=TLRPD+T2TMP-T1TMP + ENDIF + ENDIF + + + IF(IDTOX.GE.4440)THEN + IF (TIMEDAY.GE.REAL(NPTXLDS/86400.).AND. + & TIMEDAY.LE.REAL(NPTXLDE/86400.)) THEN + CALL DRIFTERC + ENDIF + ENDIF +!GEOSR} +C + MPI_WTIMES(31)=MPI_WTIMES(31)+MPI_TOC(STIME) +C +! IF(ISLRPD.GE.1)THEN +! CALL CPU_TIME(T1TMP) !DHC:13-04-09 +! IF(ISLRPD.LE.2)THEN +! IF(N.GE.NLRPDRT(1)) CALL LAGRES +! ENDIF +! IF(ISLRPD.GE.3)THEN +! IF(N.GE.NLRPDRT(1)) CALL GLMRES +! ENDIF +! TLRPD=TLRPD+T1TMP-SECOND() +! ENDIF +C +C**********************************************************************C +C +C ** CALCULATE VOLUME MASS, MOMENTUM AND ENERGY BALANCES +C +C IF(ISBAL.GE.1)THEN +C CALL CALBAL5 +C NTMP=MOD(N,2) +C IF(NTMP.EQ.0)THEN +C CALL CBALEV5 +C ELSE +C CALL CBALOD5 +C ENDIF +C ENDIF +C +C SEDIMENT BUDGET CALCULATION (DLK 10/15) +C +C IF(ISSBAL.GE.1)THEN +C CALL BUDGET5 +C ENDIF +C NTMP=MOD(N,2) +C IF(NTMP.EQ.0)THEN +C CALL BUDGEV5 +C ELSE +C CALL BUDGOD5 +C ENDIF +C +C ** CALL TWO-TIME LEVEL BALANCES +C + STIME=MPI_TIC() +C + IF(ISBAL.GE.1)THEN + CALL BAL2T5 + ENDIF +C + MPI_WTIMES(32)=MPI_WTIMES(32)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** PERFORM AN M2 TIDE HARMONIC ANALYSIS EVERY 2 M2 PERIODS +C + STIME=MPI_TIC() +C + IF(ISHTA.EQ.1) CALL CALHTA +C + MPI_WTIMES(33)=MPI_WTIMES(33)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** CALCULATE DISPERSION COEFFICIENTS +C +C IF(N.GE.NDISP)THEN + STIME=MPI_TIC() +C + IF(N.GE.NDISP.AND.NCTBC.EQ.1)THEN + IF(ISDISP.EQ.2) CALL CALDISP2 + IF(ISDISP.EQ.3) CALL CALDISP3 + ENDIF +C + MPI_WTIMES(34)=MPI_WTIMES(34)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** PERFORM LEAST SQUARES HARMONIC ANALYSIS AT SELECTED LOCATIONS +C + STIME=MPI_TIC() +C + IF(ISLSHA.EQ.1.AND.N.EQ.NCLSHA)THEN + CALL LSQHARM + NCLSHA=NCLSHA+(NTSPTC/24) + ENDIF +C + MPI_WTIMES(35)=MPI_WTIMES(35)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** PRINT INTERMEDIATE RESULTS +C +C----------------------------------------------------------------------C +C + STIME=MPI_TIC() +C + IF(NPRINT .EQ. NTSPP)THEN + NPRINT=1 + CALL OUTPUT1 + ELSE + NPRINT=NPRINT+1 + ENDIF +C + MPI_WTIMES(36)=MPI_WTIMES(36)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** WRITE TO TIME VARYING GRAPHICS FILES +C +C----------------------------------------------------------------------C +C +CDYN IF(N.EQ.NCPPH.AND.ISPPH.EQ.1)THEN +Cpmc IF(N.GE.NCPPH.AND.ISPPH.GE.1)THEN +C + STIME=MPI_TIC() +C + IF(TIMEDAY.GE.SNAPSHOTS(NSNAPSHOTS))THEN + CALL SURFPLT + ENDIF +C + MPI_WTIMES(37)=MPI_WTIMES(37)+MPI_TOC(STIME) +C +C +C----------------------------------------------------------------------C +C +CDYN IF(N.EQ.NCBPH.AND.ISBPH.EQ.1)THEN +C + STIME=MPI_TIC() +C + IF(N.GE.NCBPH.AND.ISBPH.GE.1)THEN + IF(ISBEXP.EQ.0)THEN + CALL BEDPLTH + NCBPH=NCBPH+(NTSPTC/NPBPH) + ENDIF + ENDIF +C + MPI_WTIMES(38)=MPI_WTIMES(38)+MPI_TOC(STIME) +C +C----------------------------------------------------------------------C +C +CDYN IF(N.EQ.NCVPH.AND.ISVPH.GE.1)THEN +C + STIME=MPI_TIC() +C + IPLTTMP=0 + IF(ISVPH.EQ.1.OR.ISVPH.EQ.2)IPLTTMP=1 + IF(TIMEDAY.GE.SNAPSHOTS(NSNAPSHOTS).AND.IPLTTMP.EQ.1)THEN + CALL VELPLTH_mpi + ENDIF +C + MPI_WTIMES(39)=MPI_WTIMES(39)+MPI_TOC(STIME) +C +C----------------------------------------------------------------------C +C +CDYN IF(N.EQ.NCVPV.AND.ISVPV.GE.1)THEN +C + STIME=MPI_TIC() +C + IF(N.GE.NCVPV.AND.ISVPV.GE.1)THEN + CALL VELPLTV + NCVPV=NCVPV+(NTSPTC/NPVPV) + ENDIF +C + MPI_WTIMES(40)=MPI_WTIMES(40)+MPI_TOC(STIME) +C +C----------------------------------------------------------------------C +C + STIME=MPI_TIC() +C + DO K=1,KC +!$OMP PARALLEL DO + DO L=LMPI1,LMPILC + TVAR1S(L,K)=TOX(L,K,1) + ENDDO + ENDDO +C + IPLTTMP=0 + IF(ISSPH(1).EQ.1.OR.ISSPH(1).EQ.2)IPLTTMP=1 + IF(N.GE.NCSPH(1).AND.IPLTTMP.EQ.1)THEN + IF(ISTRAN(1).GE.1) CALL SALPLTH (1,SAL) + NCSPH(1)=NCSPH(1)+(NTSPTC/NPSPH(1)) + ENDIF +C + IPLTTMP=0 + IF(ISSPH(2).EQ.1.OR.ISSPH(2).EQ.2)IPLTTMP=1 + IF(N.GE.NCSPH(2).AND.IPLTTMP.EQ.1)THEN + IF(ISTRAN(2).GE.1) CALL SALPLTH (2,TEM) + NCSPH(2)=NCSPH(2)+(NTSPTC/NPSPH(2)) + ENDIF +C + IPLTTMP=0 + IF(ISSPH(3).EQ.1.OR.ISSPH(3).EQ.2)IPLTTMP=1 + IF(N.GE.NCSPH(3).AND.IPLTTMP.EQ.1)THEN + IF(ISTRAN(3).GE.1) CALL SALPLTH (3,DYE) + NCSPH(3)=NCSPH(3)+(NTSPTC/NPSPH(3)) + ENDIF +C + IPLTTMP=0 + IF(ISSPH(4).EQ.1.OR.ISSPH(4).EQ.2)IPLTTMP=1 + IF(N.GE.NCSPH(4).AND.IPLTTMP.EQ.1)THEN + IF(ISTRAN(4).GE.1) CALL SALPLTH (4,SFL) + NCSPH(4)=NCSPH(4)+(NTSPTC/NPSPH(4)) + ENDIF +C + IPLTTMP=0 + IF(ISSPH(5).EQ.1.OR.ISSPH(5).EQ.2)IPLTTMP=1 + IF(N.GE.NCSPH(5).AND.IPLTTMP.EQ.1)THEN + IF(ISTRAN(5).GE.1) CALL SALPLTH (5,TVAR1S) + NCSPH(5)=NCSPH(5)+(NTSPTC/NPSPH(5)) + ENDIF +C + IPLTTMP=0 + IF(ISSPH(6).EQ.1.OR.ISSPH(6).EQ.2)IPLTTMP=1 + IF(N.GE.NCSPH(6).AND.IPLTTMP.EQ.1)THEN + IF(ISTRAN(6).GE.1) CALL SALPLTH (6,SEDT) + NCSPH(6)=NCSPH(6)+(NTSPTC/NPSPH(6)) + ENDIF +C + IPLTTMP=0 + IF(ISSPH(7).EQ.1.OR.ISSPH(7).EQ.2)IPLTTMP=1 + IF(N.GE.NCSPH(7).AND.IPLTTMP.EQ.1)THEN + IF(ISTRAN(7).GE.1) CALL SALPLTH (7,SNDT) + NCSPH(7)=NCSPH(7)+(NTSPTC/NPSPH(7)) + ENDIF +C + MPI_WTIMES(41)=MPI_WTIMES(41)+MPI_TOC(STIME) +C +C----------------------------------------------------------------------C +C + STIME=MPI_TIC() +C + DO ITMP=1,7 + IF(N.GE.NCSPV(ITMP).AND.ISSPV(ITMP).GE.1)THEN + CALL SALPLTV(ITMP) + NCSPV(ITMP)=NCSPV(ITMP)+(NTSPTC/NPSPV(ITMP)) + ENDIF + ENDDO +C + MPI_WTIMES(42)=MPI_WTIMES(42)+MPI_TOC(STIME) +C +C----------------------------------------------------------------------C +C +C ** WRITE EFDC EXPLORER FORMAT OUTPUT +C + STIME=MPI_TIC() +C + IF(ISSPH(8).EQ.1.OR.ISBEXP.EQ.1)THEN + IF(TIMEDAY.GE.SNAPSHOTS(NSNAPSHOTS))THEN + IF(IBIN_TYPE.EQ.1)THEN + IF(MYRANK.EQ.0) WRITE(88,*) 'EEXPOUT_mpi' + CALL EEXPOUT_mpi(0) + ELSEIF(IBIN_TYPE.EQ.0)THEN + IF(MYRANK.EQ.0) WRITE(88,*) 'EEXPOUT_opt_mpi' + CALL EEXPOUT_opt_mpi(0) + ENDIF + ENDIF + ENDIF + IF(TIMEDAY.GE.SNAPSHOTS(NSNAPSHOTS))THEN + NSNAPSHOTS=NSNAPSHOTS+1 + ENDIF +C + MPI_WTIMES(43)=MPI_WTIMES(43)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** WRITE TO TIME VARYING 3D HDF GRAPHICS FILES +C +C----------------------------------------------------------------------C +C + STIME=MPI_TIC() +C + IF(N.EQ.NC3DO.AND.IS3DO.EQ.1)THEN + CALL OUT3D + NC3DO=NC3DO+(NTSPTC/NP3DO) + ENDIF +C + MPI_WTIMES(44)=MPI_WTIMES(44)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** WRITE RESTART FILE EVERY ISRESTO M2 TIDAL CYCLES +C + STIME=MPI_TIC() +C + IF(ISRESTO.GE.1)THEN + IF((N-ISSREST).GT.NRESTO)THEN + if(myrank.eq.0) print*,'R1ESTOUT(0)' + CALL RESTOUT(0) + IF(ISTRAN(8).GE.1)THEN + IF(IWQRST.EQ.1) CALL WWQRST(0) + IF(IWQBEN.EQ.1 .AND. ISMRST.EQ.1) CALL WSMRST(0) + ENDIF + ISSREST=N + ENDIF + ENDIF +! { GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.5.23 + IF(ISRESTO.LT.-20)THEN + IF((N-ISSREST).GT.NTSPTC)THEN + if(myrank.eq.0) print*,'R1ESTOUT(-19)' + CALL RESTOUT(-19) + IF(ISTRAN(8).GE.1)THEN + IF(IWQRST.EQ.1) CALL WWQRST(1) + IF(IWQBEN.EQ.1 .AND. ISMRST.EQ.1) CALL WSMRST(1) + ENDIF + ISSREST=N + ENDIF + ENDIF +! } GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.5.23 + +! { GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 + IF(ISRESTO.LT.-20)THEN + ISHYD=-1*ISRESTO-20 + IF (N.EQ.1) THEN + IHYDCNT=1 + SNAPSHOTHYD=FLOAT(ISHYD*IHYDCNT)*60./86400.+TBEGIN + ENDIF + IF(TIMEDAY.GE.SNAPSHOTHYD) THEN +! WRITE(*,*)'WRITE================',N,TIMEDAY,TIMEDAY*1440. +! CALL RESTOUT(-21) + IHYDCNT=IHYDCNT+1 + SNAPSHOTHYD=FLOAT(ISHYD*IHYDCNT)*60./86400.+TBEGIN + ENDIF + ENDIF +! } GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 +C + MPI_WTIMES(45)=MPI_WTIMES(45)+MPI_TOC(STIME) +C +C**********************************************************************C +C +C ** RECORD TIME +C +C ** DTIME AND FLUSH ARE SUPPORTED ON SUN SYSTEMS, BUT MAY NOT BE +C ** SUPPORTED ON OTHER SYSTEMS. +C + STIME=MPI_TIC() + + IF(NTIMER.EQ.NTSPTC)THEN +C *** EE BEGIN BLOCK + IF(MYRANK.EQ.0) CALL TIMELOG(N,TIMEDAY) +C *** EE END BLOCK + NTIMER=1 + ELSE + NTIMER=NTIMER+1 + ENDIF +C +C**********************************************************************C +C + IF(N.EQ.1)THEN + OPEN(1,FILE='SHOW.INP',STATUS='OLD') + DO NSKIP=1,6; READ(1,*); ENDDO + READ(1,*)NSHTYPE,NSHOWR,ICSHOW,JCSHOW,ISHPRT + CLOSE(1) + ENDIF +C + L=LIJ(ICSHOW,JCSHOW) + IF(ISHOW.GT.0.AND.L.GE.LMPI2.AND.L.LE.LMPILA) CALL SHOWVAL +C + MPI_WTIMES(46)=MPI_WTIMES(46)+MPI_TOC(STIME) +C**********************************************************************C +C +C *** DJB +![ykchoi 10.04.26 for linux version + MPI_WTIMES(1)=MPI_WTIMES(1)+MPI_TOC(TTIME) + WT_RATIO=1 + IF(PRINT_SUM)THEN + IF(MOD(N,100).EQ.0)THEN + call collect_in_zero(TSX) + call collect_in_zero(TSY) + call collect_in_zero(TBX) + call collect_in_zero(TBY) + call collect_in_zero_array(AV) + call collect_in_zero_array(AB) + call collect_in_zero_array(AQ) + call collect_in_zero(HP) + call collect_in_zero(HU) + call collect_in_zero(HV) + call collect_in_zero(P) + call collect_in_zero(TEMB) + call collect_in_zero_array(U) + call collect_in_zero_array(V) + call collect_in_zero_array(W) + call collect_in_zero_array(TEM) + call collect_in_zero_array(SAL) + call collect_in_zero_array(SEDT) + do k=0,kcm + call collect_in_zero(QQ(:,k)) + call collect_in_zero(QQL(:,k)) + enddo + DO NW=1,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + DO NSP=1,NXSP + call collect_in_zero_array(WQVX(:,:,NSP)) + ENDDO + call collect_in_zero_array(QSUM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'TSX = ', sum(abs(dble(TSX))) + PRINT*, n,'TSY = ', sum(abs(dble(TSY))) + PRINT*, n,'TBX = ', sum(abs(dble(TBX))) + PRINT*, n,'TBY = ', sum(abs(dble(TBY))) + PRINT*, n,'AV = ', sum(abs(dble(AV))) + PRINT*, n,'AB = ', sum(abs(dble(AB))) + PRINT*, n,'AQ = ', sum(abs(dble(AQ))) + PRINT*, n,'HP = ', sum(abs(dble(HP))) + PRINT*, n,'HU = ', sum(abs(dble(HU))) + PRINT*, n,'HV = ', sum(abs(dble(HV))) + PRINT*, n,'P = ', sum(abs(dble(P))) + PRINT*, n,'U = ', sum(abs(dble(U))) + PRINT*, n,'V = ', sum(abs(dble(V))) + PRINT*, n,'W = ', sum(abs(dble(W))) + PRINT*, n,'TEM = ', sum(abs(dble(TEM))) + PRINT*, n,'SAL = ', sum(abs(dble(SAL))) + PRINT*, n,'TEMB = ', sum(abs(dble(TEMB))) + PRINT*, n,'SEDT = ', sum(abs(dble(SEDT))) + PRINT*, n,'QQ = ', sum(abs(dble(QQ))) + PRINT*, n,'QQL = ', sum(abs(dble(QQL))) + PRINT*, n,'WQV = ', sum(abs(dble(WQV))) + PRINT*, n,'WQVX = ', sum(abs(dble(WQVX))) + PRINT*, n,'QSUM = ', sum(abs(dble(QSUM))) + ENDIF + CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) + ENDIF + ENDIF + + IF(PRINT_SUM)THEN + IF(MOD(N,NTSPTC/WT_RATIO/24).EQ.0)THEN + call collect_in_zero(TSX) + call collect_in_zero(TSY) + call collect_in_zero(TBX) + call collect_in_zero(TBY) + call collect_in_zero_array(AV) + call collect_in_zero_array(AB) + call collect_in_zero_array(AQ) + call collect_in_zero(HP) + call collect_in_zero(HU) + call collect_in_zero(HV) + call collect_in_zero(P) + call collect_in_zero(TEMB) + call collect_in_zero_array(U) + call collect_in_zero_array(V) + call collect_in_zero_array(W) + call collect_in_zero_array(TEM) + call collect_in_zero_array(SAL) + call collect_in_zero_array(SEDT) + do k=0,kcm + call collect_in_zero(QQ(:,k)) + call collect_in_zero(QQL(:,k)) + enddo + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + DO NSP=1,NXSP + call collect_in_zero_array(WQVX(:,:,NSP)) + ENDDO + call collect_in_zero_array(QSUM) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'TSX = ', sum(abs(dble(TSX))) + PRINT*, n,'TSY = ', sum(abs(dble(TSY))) + PRINT*, n,'TBX = ', sum(abs(dble(TBX))) + PRINT*, n,'TBY = ', sum(abs(dble(TBY))) + PRINT*, n,'AV = ', sum(abs(dble(AV))) + PRINT*, n,'AB = ', sum(abs(dble(AB))) + PRINT*, n,'AQ = ', sum(abs(dble(AQ))) + PRINT*, n,'HP = ', sum(abs(dble(HP))) + PRINT*, n,'HU = ', sum(abs(dble(HU))) + PRINT*, n,'HV = ', sum(abs(dble(HV))) + PRINT*, n,'P = ', sum(abs(dble(P))) + PRINT*, n,'U = ', sum(abs(dble(U))) + PRINT*, n,'V = ', sum(abs(dble(V))) + PRINT*, n,'W = ', sum(abs(dble(W))) + PRINT*, n,'TEM = ', sum(abs(dble(TEM))) + PRINT*, n,'SAL = ', sum(abs(dble(SAL))) + PRINT*, n,'TEMB = ', sum(abs(dble(TEMB))) + PRINT*, n,'SEDT = ', sum(abs(dble(SEDT))) + PRINT*, n,'QQ = ', sum(abs(dble(QQ))) + PRINT*, n,'QQL = ', sum(abs(dble(QQL))) + PRINT*, n,'WQV = ', sum(abs(dble(WQV))) + PRINT*, n,'WQVX = ', sum(abs(dble(WQVX))) + PRINT*, n,'QSUM = ', sum(abs(dble(QSUM))) + ENDIF + ENDIF + ENDIF + + IF(MOD(N,NTSPTC/WT_RATIO).EQ.0)THEN + MPI_HOSTSPOTS ='NULL' + MPI_HOSTSPOTS( 1)='HDMT2T_TOTAL' + MPI_HOSTSPOTS( 4)='CALAVB' + MPI_HOSTSPOTS( 6)='CALTSXY' + MPI_HOSTSPOTS( 7)='CALEXP2T' + MPI_HOSTSPOTS( 8)='CALCSER' + MPI_HOSTSPOTS( 9)='CALPUV2C' + MPI_HOSTSPOTS(10)='ADVANCE' + MPI_HOSTSPOTS(11)='CALUVW' + MPI_HOSTSPOTS(12)='CALCONC' + MPI_HOSTSPOTS(13)='SEDIMENT' + MPI_HOSTSPOTS(15)='DSLLC_WRITE' + MPI_HOSTSPOTS(16)='WQ3D' + MPI_HOSTSPOTS(17)='CALBUOY' + MPI_HOSTSPOTS(19)='NLEVEL' + MPI_HOSTSPOTS(20)='CALHDMF' + MPI_HOSTSPOTS(21)='CALTBXY' + MPI_HOSTSPOTS(23)='QQSQR' + MPI_HOSTSPOTS(27)='CALQQ2T' + MPI_HOSTSPOTS(35)='LSQHARM' + MPI_HOSTSPOTS(37)='SURFPLT' + MPI_HOSTSPOTS(39)='VELPLTH' + MPI_HOSTSPOTS(41)='SALPTH' + MPI_HOSTSPOTS(43)='EEXPOUT' + IF(NPROCS.GE.2)THEN + MPI_HOSTSPOTS(51)='BCAST1' + MPI_HOSTSPOTS(52)='BCAST2' + MPI_HOSTSPOTS(53)='BCAST3' + MPI_HOSTSPOTS(54)='BCAST4' + MPI_HOSTSPOTS(55)='BCAST5' + MPI_HOSTSPOTS(56)='BCAST6' + MPI_HOSTSPOTS(61)='BARRIER1' + MPI_HOSTSPOTS(62)='BARRIER2' + MPI_HOSTSPOTS(63)='BARRIER3' + MPI_HOSTSPOTS(64)='BARRIER4' + MPI_HOSTSPOTS(65)='BARRIER5' + ENDIF + + IF(MYRANK.EQ.0)THEN + PRINT*,'HDMT2T' + DO II=1,65 + IF(TRIM(MPI_HOSTSPOTS(000+II)).NE.'NULL') + & WRITE(*,'(I5,2X,A20,F10.3)') II,MPI_HOSTSPOTS(000+II), + & (WT_RATIO*REAL(MPI_WTIMES(000+II))) + ENDDO + ENDIF + ENDIF + + GOTO 1001 +! IF(.NOT.KBHIT())GOTO 1001 +! I1=GETCH() +! WRITE(*,'(A)')'PROGRAM PAUSED BY USER' +! WRITE(*,'(A)')' EFDC_DS: TO EXIT PRESS THE SAME KEY' +! WRITE(*,'(A)')' EFDC_DS: TO CONTINUE RUN PRESS ANY OTHER KEY' +! I2=GETCH() +! IF(I1.NE.I2)GOTO 1001 +!ykchoi] +C + 1000 CONTINUE +C +C**********************************************************************C +C +C ** TIME LOOP COMPLETED +C + CALL CPU_TIME(T1TMP) + THDMT=THDMT+T1TMP-TTMP +C +C**********************************************************************C +C *** EE BEGIN BLOCK +C MOVED THE TIMING OUTPUT BLOCK TO THE MAIN AAEFDC TO ELIMINATE +C UNNECESSARY DUPLICATION +C *** EE END BLOCK +C**********************************************************************C +C +C2000 CONTINUE +C +C**********************************************************************C +C +C ** PRINT FINAL RESULTS +C + IF(MYRANK.EQ.0) CALL OUTPUT2 +C +C**********************************************************************C +C +C ** WRITE RESTART FILE +C +C IF(ISRESTO.EQ.-1.OR.ISRESTO.EQ.-11)THEN ! GEOSR : JGCHO 2011.6.15 + IF(ISRESTO.EQ.-1.OR.ISRESTO.EQ.-11.OR.ISRESTO.LT.-20)THEN ! GEOSR : JGCHO 2011.6.15 + if(myrank.eq.0) print*,'R2ESTOUT(0)' + CALL RESTOUT(0) + IF(ISTRAN(8).GE.1)THEN + IF(IWQRST.EQ.1) CALL WWQRST(0) + IF(IWQBEN.EQ.1 .AND. ISMRST.EQ.1) CALL WSMRST(0) + ENDIF + ENDIF + IF(ISRESTO.EQ.-2)THEN + CALL RESTMOD + ENDIF +! { GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.6.3 + IF(ISRESTO.LT.-20)THEN + if(myrank.eq.0) print*,'R2ESTOUT(-19)' + CALL RESTOUT(-19) + IF(ISTRAN(8).GE.1)THEN + IF(IWQRST.EQ.1) CALL WWQRST(1) + IF(IWQBEN.EQ.1 .AND. ISMRST.EQ.1) CALL WSMRST(1) + ENDIF + ENDIF +! } GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.6.3 +C +C**********************************************************************C +C +C ** COMPLETE LEAST SQUARES HARMONIC ANALYSIS +C + LSLSHA=1 + IF(ISLSHA.EQ.1) CALL LSQHARM +C +C**********************************************************************C +C +C ** OUTPUT COURANT NUMBER DIAGNOSTICS +C +C *** DSLLC BEGIN BLOCK + IF(MYRANK.EQ.0)THEN + IF(ISINWV.GT.0.AND.DEBUG)THEN + OPEN(1,FILE='CFLMAX.OUT') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='CFLMAX.OUT') +C + DO L=2,LA + WRITE(1,1991)IL(L),JL(L),(CFLUUU(L,K),K=1,KC) + WRITE(1,1992)(CFLVVV(L,K),K=1,KC) + WRITE(1,1992)(CFLWWW(L,K),K=1,KC) + WRITE(1,1992)(CFLCAC(L,K),K=1,KC) + ENDDO +C + CLOSE(1) + ENDIF + ENDIF +C *** DSLLC END BLOCK +C + 1991 FORMAT(2I5,12F8.3) + 1992 FORMAT(10X,12F8.3) + 1993 FORMAT(2I5,E13.5) +C +C**********************************************************************C +C +C ** OUTPUT COSMETIC VOLUME LOSSES FORM DRY CELLS +C + IF(MYRANK.EQ.0)THEN + IF(NDRYSTP.LT.0.AND.DEBUG) THEN +C + OPEN(1,FILE='DRYLOSS.OUT') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='DRYLOSS.OUT') +C + DO L=2,LA + WRITE(1,1993)IL(L),JL(L),VDWASTE(L) + ENDDO +C + CLOSE(1) +C + ENDIF + ENDIF +C +C**********************************************************************C +C +C ** OUTPUT FINAL FOOD CHAIN AVERAGING PERIOD +C + IF(ISTRAN(5).GE.1.AND.ISFDCH.GE.1)CALL FOODCHAIN(1) +C +C**********************************************************************C +C +C ** OUTPUT FINAL MASS AND VOLUME BALANCES +C + IF(IS2TIM.GE.1) THEN + IF(ISBAL.GE.1)THEN + CALL BAL2T5 + ENDIF + ENDIF +C +C**********************************************************************C +C + CLOSE(90) + CLOSE(98) + + RETURN + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/INITBIN3.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/INITBIN3.for index 76792632a..22fbb6510 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/INITBIN3.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/INITBIN3.for @@ -7,6 +7,7 @@ C PARAMETERS FOR POST-PROCESSOR IN HEADER SECTION OF BINARY C FILE WQDOCOMP.BIN FOR D.O. COMPONENT ANALYSIS. C USE GLOBAL + USE MPI REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XLON REAL,SAVE,ALLOCATABLE,DIMENSION(:)::YLAT LOGICAL FEXIST,IS1OPEN,IS2OPEN @@ -162,7 +163,7 @@ C C C IF WQDOCOMP.BIN ALREADY EXISTS, OPEN FOR APPENDING HERE. C - IF(ISCOMP .EQ. 2)THEN + IF(ISCOMP .EQ. 2.AND.MYRANK.EQ.0)THEN IO = 1 5 IO = IO+1 IF(IO .GT. 99)THEN @@ -187,7 +188,7 @@ C C C IF WQDOCOMP.BIN ALREADY EXISTS, DELETE IT HERE. C - IF(ISCOMP .EQ. 1)THEN + IF(ISCOMP .EQ. 1.AND.MYRANK.EQ.0)THEN TBEGAN = TBEGIN IO = 1 10 IO = IO+1 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/INPUT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/INPUT.for index e17f97af0..6b0eff187 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/INPUT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/INPUT.for @@ -24,6 +24,7 @@ C ADDED SED-TOX DEBUG FLAG ISDTXBUG C USE GLOBAL USE DRIFTER,ONLY:DRIFTERINP, AREA_CENTRD + USE MPI REAL*4 SEEPRATE(1000) CHARACTER*80 TEXT,TITLE @@ -31,6 +32,7 @@ C CHARACTER*3 NCARD CHARACTER CCMRM*1, ADUMMY*5 ! EJH LOGICAL PARSE_LOGICAL, status + LOGICAL lwd, le2 REAL,ALLOCATABLE,DIMENSION(:)::RMULADS REAL,ALLOCATABLE,DIMENSION(:)::ADDADS INTEGER IPMC @@ -46,31 +48,34 @@ C C C ** READ MAIN INPUT FILE EFDC.INP C - PRINT *,'READING THE MAIN EFDC CONTROL FILE: EFDC.INP' + IF(MYRANK.EQ.0) + & PRINT *,'READING THE MAIN EFDC CONTROL FILE: EFDC.INP' OPEN(1,FILE='EFDC.INP',STATUS='UNKNOWN') C C1** READ TITLE CARD NCARD='1' CALL SEEK('C1') READ(1,2) TITLE - WRITE(7,1002)NCARD - WRITE(7,2) TITLE + IF(MYRANK.EQ.0) WRITE(7,1002)NCARD + IF(MYRANK.EQ.0) WRITE(7,2) TITLE C C2** READ RESTART AND DIAGNOSTIC SWITCHES NCARD='2' CALL SEEK('C2') READ(1,*,IOSTAT=ISO) ISRESTI,ISRESTO,ISRESTR,ISPAR,ISLOG,ISDIVEX, & ISNEGH,ISMMC,ISBAL,IS2TIM,ISHOW,ITIMING,IBIN_TYPE + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISRESTI,ISRESTO,ISRESTR,ISPAR,ISLOG,ISDIVEX, & ISNEGH,ISMMC,ISBAL,IS2TIM,ISHOW,ITIMING,IBIN_TYPE + ENDIF IF(ISMMC.LT.0)THEN DEBUG=.TRUE. ISMMC=0 - PRINT *,'DEBUG ON' + IF(MYRANK.EQ.0) PRINT *,'DEBUG ON' ELSE DEBUG=.FALSE. - PRINT *,'DEBUG OFF' + IF(MYRANK.EQ.0) PRINT *,'DEBUG OFF' ENDIF IF(ISO.GT.0) GOTO 100 C @@ -80,9 +85,11 @@ C3** READ RELAXATION PARAMETERS READ(1,*,IOSTAT=ISO) RP,RSQM,ITERM,IRVEC,RPADJ, & RSQMADJ,ITRMADJ,ITERHPM,IDRYCK,ISDSOLV,FILT3TL IF(ITRMADJ.LT.1)ITRMADJ=1 + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) RP,RSQM,ITERM,IRVEC,RPADJ, & RSQMADJ,ITRMADJ,ITERHPM,IDRYCK,ISDSOLV,FILT3TL + ENDIF IF(ISO.GT.0) GOTO 100 IF(IRVEC.NE. 0.AND.IRVEC.NE. 9.AND. & IRVEC.NE.99.AND.IRVEC.NE.9999)STOP 'INVALID IRVEC' @@ -92,9 +99,11 @@ C4** READ LONGTERM MASS TRANSPORT INTEGRATION ONLY SWITCHES CALL SEEK('C4') READ(1,*,IOSTAT=ISO) ISLTMT,ISSSMMT,ISLTMTS,ISIA,RPIA,RSQMIA, & ITRMIA,ISAVEC + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISLTMT,ISSSMMT,ISLTMTS,ISIA,RPIA,RSQMIA, & ITRMIA,ISAVEC + ENDIF IF(ISO.GT.0) GOTO 100 C C5** READ MOMENTUM ADVECTION AND DIFFUSION SWITCHES AND MISC @@ -102,9 +111,11 @@ C5** READ MOMENTUM ADVECTION AND DIFFUSION SWITCHES AND MISC CALL SEEK('C5') READ(1,*,IOSTAT=ISO) ISCDMA,ISHDMF,ISDISP,ISWASP,ISDRY, & ISQQ,ISRLID,ISVEG,ISVEGL,ISITB,ISEVER,IINTPG + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISCDMA,ISHDMF,ISDISP,ISWASP,ISDRY, & ISQQ,ISRLID,ISVEG,ISVEGL,ISITB,ISEVER,IINTPG + ENDIF IF(ISO.GT.0) GOTO 100 IDRYTBP=0 IF(ISDRY.LT.0)THEN @@ -125,9 +136,11 @@ C READ(1,*,IOSTAT=ISO) ISTRAN(N),ISTOPT(N),ISCDCA(N),ISADAC(N), & ISFCT(N),ISPLIT(N),ISADAH(N),ISADAV(N),ISCI(N),ISCO(N) IF(ISCDCA(N).GE.4) ISCOSMIC=1 + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISTRAN(N),ISTOPT(N),ISCDCA(N),ISADAC(N), & ISFCT(N),ISPLIT(N),ISADAH(N),ISADAV(N),ISCI(N),ISCO(N) + ENDIF !{GeoSR, YSSONG, TOXIC, 101031, 101125 IF(IDTOX.GT.0.AND.IDTOX.LT.4440) ISTRAN(5)=1 ! TOXIC MODULE ON @@ -143,9 +156,11 @@ C7** READ TIME-RELATED INTEGER PARAMETERS & NTCVB,NTSMMT,NFLTMT,NDRYSTP ! READ(1,*,IOSTAT=ISO) NTC,NTSPTC,NLTC,NTTC,NTCPP,NTSTBC, ! & KSW,NTCVB,NTSMMT,NFLTMT,NDRYSTP + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) NTC,NTSPTC,NLTC,NTTC,NTCPP,NTSTBC,NTCNB, & NTCVB,NTSMMT,NFLTMT,NDRYSTP + ENDIF IF(ISO.GT.0) GOTO 100 C C8** READ TIME-RELATED REAL PARAMETERS @@ -157,15 +172,17 @@ C8** READ TIME-RELATED REAL PARAMETERS !{GEOSR, TOX, YSSONG, 101125, JGCHO 110125 IF(IDTOX.GE.0) THEN TBEGIN=TBEGIN1 - NTSPTC=TIDALP/USERDT + NTSPTC=INT(TIDALP/USERDT,KIND(NTSPTC)) !NTC=NTC1*86400/INT(TIDALP) NTC=NTC1/INT(TIDALP) ENDIF !} + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) TCON,TBEGIN,TIDALP,CF,ISCORV,ISDCCA, & ISCFL,ISCFLM,DTSSFAC + ENDIF IF(ISO.GT.0) GOTO 100 IF(DTSSFAC.GT.0.0)THEN ISDYNSTP=1 @@ -179,9 +196,11 @@ C9** READ SPACE RELATED AND SMOOTHING PARAMETERS CALL SEEK('C9') READ(1,*,IOSTAT=ISO) KC,IC,JC,LC,LVC,ISCLO,NDM,LDM,ISMASK, & ISPGNS,NSHMAX,NSBMAX,WSMH,WSMB + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) KC,IC,JC,LC,LVC,ISCLO,NDM,LDM,ISMASK, & ISPGNS,NSHMAX,NSBMAX,WSMH,WSMB + ENDIF IF(ISO.GT.0) GOTO 100 IS2LMC=0 IF(KC.LT.0) THEN @@ -207,8 +226,10 @@ C10* READ LAYER THICKNESS IN VERTICAL CALL SEEK('C10') DO K=1,KC READ(1,*,IOSTAT=ISO)KDUM,DZC(K) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)KDUM,DZC(K) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -217,9 +238,11 @@ C11* READ GRID, ROUGHNESS, MASKING AND DEPTH PARAMETERS CALL SEEK('C11') READ(1,*,IOSTAT=ISO) DX,DY,DXYCVT,IMDXDY,ZBRADJ,ZBRCVRT,HMIN, & HADADJ,HCVRT,HDRY,HWET,BELADJ,BELCVRT + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) DX,DY,DXYCVT,IMDXDY,ZBRADJ,ZBRCVRT,HMIN, & HADADJ,HCVRT,HDRY,HWET,BELADJ,BELCVRT + ENDIF IF(ISO.GT.0) GOTO 100 C C11A* READ TWO-LAYER MOMENTUM FLUX AND CURVATURE ACCELERATION @@ -228,9 +251,11 @@ C CORRECTION FACTORS CALL SEEK('C11A') READ(1,*,IOSTAT=ISO) ICK2COR,CK2UUM,CK2VVM,CK2UVM,CK2UUC, & CK2VVC,CK2UVC,CK2FCX,CK2FCY + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ICK2COR,CK2UUM,CK2VVM,CK2UVM,CK2UUC, & CK2VVC,CK2UVC,CK2FCX,CK2FCY + ENDIF IF(ISO.GT.0) GOTO 100 IF(ICK2COR.GE.1) THEN IS2LMC=ICK2COR @@ -240,8 +265,10 @@ C11B* READ CORNER CELL BOTTOM STRESS CORRECTION OPTIONS NCARD='11B' CALL SEEK('C11B') READ(1,*,IOSTAT=ISO)ISCORTBC,ISCORTBCD,FSCORTBC + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISCORTBC,ISCORTBCD,FSCORTBC + ENDIF IF(ISO.GT.0) GOTO 100 C C12* READ TURBULENT DIFFUSION PARAMETERS @@ -249,9 +276,11 @@ C12* READ TURBULENT DIFFUSION PARAMETERS CALL SEEK('C12') READ(1,*,IOSTAT=ISO) AHO,AHD,AVO,ABO,AVMX,ABMX,VISMUD,AVCON, & ZBRWALL,ISAVBMX,ISFAVB,ISINWV + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) AHO,AHD,AVO,ABO,AVMX,ABMX,VISMUD,AVCON,ZBRWALL, & ISAVBMX,ISFAVB,ISINWV + ENDIF IF(ISO.GT.0) GOTO 100 C C13* READ TURBULENCE CLOSURE PARAMETERS @@ -259,9 +288,11 @@ C13* READ TURBULENCE CLOSURE PARAMETERS CALL SEEK('C13') READ(1,*,IOSTAT=ISO) VKC,CTURB,CTURB2B,CTE1,CTE2,CTE3,QQMIN, & QQLMIN,DMLMIN + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) VKC,CTURB,CTURB2B,CTE1,CTE2,CTE3,QQMIN, & QQLMIN,DMLMIN + ENDIF IF(ISO.GT.0) GOTO 100 C C14* READ TIDAL & ATMOSPHERIC FORCING, GROUND WATER @@ -270,9 +301,11 @@ C AND SUBGRID CHANNEL PARAMETERS CALL SEEK('C14') READ(1,*,IOSTAT=ISO) MTIDE,NWSER,NASER,ISGWIT,ISCHAN,ISWAVE, & ITIDASM,ISPERC,ISBODYF,ISPNHYDS + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) MTIDE,NWSER,NASER,ISGWIT,ISCHAN,ISWAVE,ITIDASM, & ISPERC,ISBODYF,ISPNHYDS + ENDIF ISWCBL=0 ISWVSD=0 IF(ISO.GT.0) GOTO 100 @@ -290,8 +323,10 @@ C15* READ PERIODIC FORCING (TIDAL) CONSTITUENT SYMBOLS AND PERIODS CALL SEEK('C15') DO M=1,MTIDE READ(1,*,IOSTAT=ISO) SYMBOL(M),TCP(M) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) SYMBOL(M),TCP(M) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -301,10 +336,12 @@ C16* READ SURFACE ELEVATION OR PRESSURE BOUNDARY CONDITION PARAMETERS CALL SEEK('C16') READ(1,*,IOSTAT=ISO) NPBS,NPBW,NPBE,NPBN,NPFOR,NPFORT, & NPSER,PDGINIT + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) NPBS,NPBW,NPBE,NPBN,NPFOR,NPFORT,NPSER,PDGINIT + ENDIF IF(ISO.GT.0) GOTO 100 - IF(NPFORT.GE.1.AND.DEBUG)THEN + IF(NPFORT.GE.1.AND.DEBUG.AND.MYRANK.EQ.0)THEN OPEN(2,FILE='TIDALBC.OUT') CLOSE(2,STATUS='DELETE') OPEN(2,FILE='TIDALBC.OUT') @@ -318,29 +355,35 @@ C17* READ PERIODIC FORCING (TIDAL) SURFACE ELEVATION OR DO M=1,MTIDE IF(NPFORT.EQ.0)THEN READ(1,*,IOSTAT=ISO)NDUM,CDUM,PFAM(NP,M),PFPH(NP,M) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)NDUM,CDUM,PFAM(NP,M),PFPH(NP,M) + ENDIF IF(ISO.GT.0) GOTO 100 ELSE READ(1,*,IOSTAT=ISO)NDUM,CDUM,PFAM(NP,M),PFPH(NP,M) RAD=PI2*PFPH(NP,M)/TCP(M) CPFAM0(NP,M)=PFAM(NP,M)*COS(RAD) SPFAM0(NP,M)=PFAM(NP,M)*SIN(RAD) + IF(MYRANK.EQ.0)THEN WRITE(2,2068)NDUM,CDUM,PFAM(NP,M),PFPH(NP,M), & CPFAM0(NP,M),SPFAM0(NP,M) WRITE(7,1002)NCARD WRITE(7,*)NDUM,CDUM,PFAM(NP,M),PFPH(NP,M), & CPFAM0(NP,M),SPFAM0(NP,M) + ENDIF IF(ISO.GT.0) GOTO 100 READ(1,*,IOSTAT=ISO)NDUM,CDUM,PFAM(NP,M),PFPH(NP,M) RAD=PI2*PFPH(NP,M)/TCP(M) CPFAM1(NP,M)=PFAM(NP,M)*COS(RAD)-CPFAM0(NP,M) SPFAM1(NP,M)=PFAM(NP,M)*SIN(RAD)-SPFAM0(NP,M) + IF(MYRANK.EQ.0)THEN WRITE(2,2068)NDUM,CDUM,PFAM(NP,M),PFPH(NP,M), & CPFAM1(NP,M),SPFAM1(NP,M) WRITE(7,1002)NCARD WRITE(7,*)NDUM,CDUM,PFAM(NP,M),PFPH(NP,M), & CPFAM1(NP,M),SPFAM1(NP,M) + ENDIF CPFAM2(NP,M)=0.0 SPFAM2(NP,M)=0.0 ENDIF @@ -357,8 +400,10 @@ C ON SOUTH OPEN BOUNDARIES IF(NPFORT.EQ.0)THEN DO L=1,NPBS READ(1,*,IOSTAT=ISO)IPBS(L),JPBS(L),ISPBS(L),NPFORS,NPSERS(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IPBS(L),JPBS(L),ISPBS(L),NPFORS,NPSERS(L) + ENDIF IF(ISO.GT.0) GOTO 100 DO M=1,MTIDE IF(NPFORS.EQ.0) EXIT @@ -372,16 +417,20 @@ C ON SOUTH OPEN BOUNDARIES DO L=1,NPBS READ(1,*,IOSTAT=ISO) IPBS(L),JPBS(L),ISPBS(L),NPFORS, & NPSERS(L),TPCOORDS(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IPBS(L),JPBS(L),ISPBS(L),NPFORS,NPSERS(L), & TPCOORDS(L) + ENDIF IF(ISO.GT.0) GOTO 100 DO M=1,MTIDE PCBS(L,M)=CPFAM0(NPFORS,M)+TPCOORDS(L)*CPFAM1(NPFORS,M) & +TPCOORDS(L)*TPCOORDS(L)*CPFAM2(NPFORS,M) PSBS(L,M)=SPFAM0(NPFORS,M)+TPCOORDS(L)*SPFAM1(NPFORS,M) & +TPCOORDS(L)*TPCOORDS(L)*SPFAM2(NPFORS,M) + IF(MYRANK.EQ.0)THEN WRITE(2,2069)L,SYMBOL(M),PCBS(L,M),PSBS(L,M),IPBS(L),JPBS(L) + ENDIF PCBS(L,M)=G*PCBS(L,M) PSBS(L,M)=G*PSBS(L,M) ENDDO @@ -399,8 +448,10 @@ C ON WEST OPEN BOUNDARIES IF(NPFORT.EQ.0)THEN DO L=1,NPBW READ(1,*,IOSTAT=ISO)IPBW(L),JPBW(L),ISPBW(L),NPFORW,NPSERW(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IPBW(L),JPBW(L),ISPBW(L),NPFORW,NPSERW(L) + ENDIF IF(ISO.GT.0) GOTO 100 DO M=1,MTIDE IF(NPFORW.EQ.0) EXIT @@ -414,16 +465,20 @@ C ON WEST OPEN BOUNDARIES DO L=1,NPBW READ(1,*,IOSTAT=ISO) IPBW(L),JPBW(L),ISPBW(L),NPFORW, & NPSERW(L),TPCOORDW(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IPBW(L),JPBW(L),ISPBW(L),NPFORW,NPSERW(L), & TPCOORDW(L) + ENDIF IF(ISO.GT.0) GOTO 100 DO M=1,MTIDE PCBW(L,M)=CPFAM0(NPFORW,M)+TPCOORDW(L)*CPFAM1(NPFORW,M) & +TPCOORDW(L)*TPCOORDW(L)*CPFAM2(NPFORW,M) PSBW(L,M)=SPFAM0(NPFORW,M)+TPCOORDW(L)*SPFAM1(NPFORW,M) & +TPCOORDW(L)*TPCOORDW(L)*SPFAM2(NPFORW,M) + IF(MYRANK.EQ.0)THEN WRITE(2,2069)L,SYMBOL(M),PCBW(L,M),PSBW(L,M),IPBW(L),JPBW(L) + ENDIF PCBW(L,M)=G*PCBW(L,M) PSBW(L,M)=G*PSBW(L,M) ENDDO @@ -439,8 +494,10 @@ C ON EAST OPEN BOUNDARIES IF(NPFORT.EQ.0)THEN DO L=1,NPBE READ(1,*,IOSTAT=ISO)IPBE(L),JPBE(L),ISPBE(L),NPFORE,NPSERE(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IPBE(L),JPBE(L),ISPBE(L),NPFORE,NPSERE(L) + ENDIF IF(ISO.GT.0) GOTO 100 DO M=1,MTIDE IF(NPFORE.EQ.0) EXIT @@ -454,16 +511,20 @@ C ON EAST OPEN BOUNDARIES DO L=1,NPBE READ(1,*,IOSTAT=ISO) IPBE(L),JPBE(L),ISPBE(L),NPFORE, & NPSERE(L),TPCOORDE(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IPBE(L),JPBE(L),ISPBE(L),NPFORE,NPSERE(L), & TPCOORDE(L) + ENDIF IF(ISO.GT.0) GOTO 100 DO M=1,MTIDE PCBE(L,M)=CPFAM0(NPFORE,M)+TPCOORDE(L)*CPFAM1(NPFORE,M) & +TPCOORDE(L)*TPCOORDE(L)*CPFAM2(NPFORE,M) PSBE(L,M)=SPFAM0(NPFORE,M)+TPCOORDE(L)*SPFAM1(NPFORE,M) & +TPCOORDE(L)*TPCOORDE(L)*SPFAM2(NPFORE,M) + IF(MYRANK.EQ.0)THEN WRITE(2,2069)L,SYMBOL(M),PCBE(L,M),PSBE(L,M),IPBE(L),JPBE(L) + ENDIF PCBE(L,M)=G*PCBE(L,M) PSBE(L,M)=G*PSBE(L,M) ENDDO @@ -479,8 +540,10 @@ C ON NORTH OPEN BOUNDARIES IF(NPFORT.EQ.0)THEN DO L=1,NPBN READ(1,*,IOSTAT=ISO)IPBN(L),JPBN(L),ISPBN(L),NPFORN,NPSERN(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IPBN(L),JPBN(L),ISPBN(L),NPFORN,NPSERN(L) + ENDIF IF(ISO.GT.0) GOTO 100 DO M=1,MTIDE IF(NPFORN.EQ.0) EXIT @@ -494,16 +557,20 @@ C ON NORTH OPEN BOUNDARIES DO L=1,NPBN READ(1,*,IOSTAT=ISO) IPBN(L),JPBN(L),ISPBN(L),NPFORN, & NPSERN(L),TPCOORDN(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IPBN(L),JPBN(L),ISPBN(L),NPFORN,NPSERN(L), & TPCOORDN(L) + ENDIF IF(ISO.GT.0) GOTO 100 DO M=1,MTIDE PCBN(L,M)=CPFAM0(NPFORN,M)+TPCOORDN(L)*CPFAM1(NPFORN,M) & +TPCOORDN(L)*TPCOORDN(L)*CPFAM2(NPFORN,M) PSBN(L,M)=SPFAM0(NPFORN,M)+TPCOORDN(L)*SPFAM1(NPFORN,M) & +TPCOORDN(L)*TPCOORDN(L)*SPFAM2(NPFORN,M) + IF(MYRANK.EQ.0)THEN WRITE(2,2069)L,SYMBOL(M),PCBN(L,M),PSBN(L,M),IPBN(L),JPBN(L) + ENDIF PCBN(L,M)=G*PCBN(L,M) PSBN(L,M)=G*PSBN(L,M) ENDDO @@ -526,9 +593,11 @@ C22* READ NUM OF SEDIMENT AMD TOXICS AND NUM OF CONCENTRATION TIME SERIES ! NSED=0 2011.3.14 JGCHO ENDIF ! } 20110127 JGCHO + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) NTOX,NSED,NSND,NCSER(1),NCSER(2),NCSER(3), & NCSER(4),NTOXSER,NSEDSER,NSNDSER,ISSBAL + ENDIF IF(ISO.GT.0) GOTO 100 MTMP=4 DO N=1,NTOX @@ -564,9 +633,11 @@ C23* READ VELOCITY, VOL SOUR/SINK, FLOW CONTROL, & WITHDRAW/RETURN DATA CALL SEEK('C23') READ(1,*,IOSTAT=ISO) NVBS,NUBW,NUBE,NVBN,NQSIJ,NQJPIJ,NQSER,NQCTL, & NQCTLT,NQWR,NQWRSR,ISDIQ + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) NVBS,NUBW,NUBE,NVBN,NQSIJ,NQJPIJ,NQSER,NQCTL, & NQCTLT,NQWR,NQWRSR,ISDIQ + ENDIF IF(ISO.GT.0) GOTO 100 C IF(NQSIJ.GT.0)THEN @@ -577,10 +648,12 @@ C24* READ VOLUMN SOURCE/SINK LOCATIONS, MAGNITUDES, & VOL & CONC SERIES READ(1,*,IOSTAT=ISO)IQS(L),JQS(L),QSSE,NQSMUL(L),NQSMF(L), & NQSERQ(L),NCSERQ(L,1),NCSERQ(L,2),NCSERQ(L,3), & NCSERQ(L,4),NTOXSRQ,NSEDSRQ,NSNDSRQ,QFACTOR(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)IQS(L),JQS(L),QSSE,NQSMUL(L),NQSMF(L), & NQSERQ(L),NCSERQ(L,1),NCSERQ(L,2),NCSERQ(L,3), & NCSERQ(L,4),NTOXSRQ,NSEDSRQ,NSNDSRQ,QFACTOR(L) + ENDIF IF(ISO.GT.0) GOTO 100 DO K=1,KC QSS(K,L)=QSSE*DZC(K) @@ -606,8 +679,10 @@ C SAL,TEM,DYE,SFL,TOX(1 TO NOTX) MMAX=4+NTOX DO L=1,NQSIJ READ(1,*,IOSTAT=ISO) (CQSE(M),M=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CQSE(M),M=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 DO MS=1,MMAX DO K=1,KC @@ -624,8 +699,10 @@ C SED(1 TO NSED),SND(1 TO NSND) MMAX=MMAX+NSED+NSND DO L=1,NQSIJ READ(1,*,IOSTAT=ISO) (CQSE(M),M=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CQSE(M),M=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 DO MS=MMIN,MMAX DO K=1,KC @@ -643,10 +720,12 @@ C27* READ JET/PLUME SOURCE LOCATIONS AND PARAMETERS READ(1,*,IOSTAT=ISO) IDUM,ICALJP(L),IQJP(L),JQJP(L),KQJP(L), & NPORTJP(L),XJETL(L),YJETL(L),ZJET(L),PHJET(L),THJET(L), & DJET(L),CFRD(L),DJPER(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IDUM,ICALJP(L),IQJP(L),JQJP(L),KQJP(L), & NPORTJP(L),XJETL(L),YJETL(L),ZJET(L),PHJET(L),THJET(L), & DJET(L),CFRD(L),DJPER(L) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -657,10 +736,12 @@ C28* READ JET/PLUME SOURCE LOCATIONS AND PARAMETERS READ(1,*,IOSTAT=ISO) IDUM,NJEL(L),NJPMX(L),ISENT(L),ISTJP(L), & NUDJP(L),IOUTJP(L),NZPRJP(L),ISDJP(L),IUPCJP(L), & JUPCJP(L),KUPCJP(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IDUM,NJEL(L),NJPMX(L),ISENT(L),ISTJP(L), & NUDJP(L),IOUTJP(L),NZPRJP(L),ISDJP(L),IUPCJP(L), & JUPCJP(L),KUPCJP(L) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -671,10 +752,12 @@ C29* READ ADDITIONAL JET/PLUME PARAMETERS READ(1,*,IOSTAT=ISO) IDUM,QQCJP(L),NQSERJP(L),NQWRSERJP(L), & NCSERJP(L,1),NCSERJP(L,2),NCSERJP(L,3), & NCSERJP(L,4),NTXSRJP,NSDSRJP,NSNSRJP + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IDUM,QQCJP(L),NQSERJP(L),NQWRSERJP(L), & NCSERJP(L,1),NCSERJP(L,2),NCSERJP(L,3), & NCSERJP(L,4),NTXSRJP,NSDSRJP,NSNSRJP + ENDIF NUDJPC(L)=1 IF(ISO.GT.0) GOTO 100 DO N=1,NTOX @@ -709,8 +792,10 @@ C JET/PLUME SOURCES SAL,TEM,DYE,SFL,TOX(1 TO NOTX) MMAX=4+NTOX DO L=1,NQJPIJ READ(1,*,IOSTAT=ISO) (CQSE(M),M=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CQSE(M),M=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 IF(ICALJP(L).EQ.1)THEN DO MS=1,MMAX @@ -737,8 +822,10 @@ C JET/PLUME SOURCES SED(1 TO NSED),SND(1 TO NSND) MMAX=MMAX+NSED+NSND DO L=1,NQJPIJ READ(1,*,IOSTAT=ISO) (CQSE(M),M=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CQSE(M),M=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 IF(ICALJP(L).EQ.1)THEN DO MS=MMIN,MMAX @@ -766,10 +853,12 @@ C32* READ SURF ELEV OR PRESS DEPENDENT FLOW CONTROL STRUCTURE INFO READ(1,*,IOSTAT=ISO)IQCTLU(L),JQCTLU(L),IQCTLD(L),JQCTLD(L), & NQCTYP(L),NQCTLQ(L),NQCMUL(L),NQCMFU(L), & NQCMFD(L),BQCMFU(L),BQCMFD(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)IQCTLU(L),JQCTLU(L),IQCTLD(L),JQCTLD(L), & NQCTYP(L),NQCTLQ(L),NQCMUL(L),NQCMFU(L), & NQCMFD(L),BQCMFU(L),BQCMFD(L) + ENDIF IF(ISO.GT.0) GOTO 100 DO K=1,KC QCTLTO(K,L)=0. @@ -787,11 +876,13 @@ C33* READ FLOW WITHDRAWAL, HEAT OR MATERIAL ADDITION, FLOW RETURN DATA & IQWRD(L),JQWRD(L),KQWRD(L),QWR(L), & NQWRSERQ(L),NQWRMFU(L),NQWRMFD(L),BQWRMFU(L),BQWRMFD(L), & ANGWRMFD(L) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)IQWRU(L),JQWRU(L),KQWRU(L), & IQWRD(L),JQWRD(L),KQWRD(L),QWR(L), & NQWRSERQ(L),NQWRMFU(L),NQWRMFD(L),BQWRMFU(L),BQWRMFD(L), & ANGWRMFD(L) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -802,8 +893,10 @@ C SAL,TEM,DYE,SFL,TOX(1 TO NTOX) MMAX=4+NTOX DO L=1,NQWR READ(1,*,IOSTAT=ISO) (CQWR(L,MS),MS=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CQWR(L,MS),MS=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -815,8 +908,10 @@ C SED(1 TO NSED),SND(1 TO NSND) MMAX=MMAX+NSED+NSND DO L=1,NQWR READ(1,*,IOSTAT=ISO) (CQWR(L,MS),MS=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CQWR(L,MS),MS=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -827,9 +922,11 @@ C36* SEDIMENT INITIALIZATION AND WATER COLUMN/BED REPRESENTATION OPTIONS CALL SEEK('C36') READ(1,*,IOSTAT=ISO)ISEDINT,ISEDBINT,ISEDWC,ISMUD,ISNDWC,ISEDVW, & ISNDVW,KB,ISDTXBUG + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ISEDINT,ISEDBINT,ISEDWC,ISMUD,ISNDWC,ISEDVW, & ISNDVW,KB,ISDTXBUG + ENDIF IF(ISO.GT.0) GOTO 100 C C36A* SEDIMENT INITIALIZATION AND WATER COLUMN/BED REPRESENTATION OPTIONS @@ -837,8 +934,10 @@ C36A* SEDIMENT INITIALIZATION AND WATER COLUMN/BED REPRESENTATION OPTIONS CALL SEEK('C36A') COEFTSBL=4.0 READ(1,*,IOSTAT=ISO)ISBEDSTR,ISBSDFUF,COEFTSBL,VISMUDST + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ISBEDSTR,ISBSDFUF,COEFTSBL,VISMUDST + ENDIF IF(ISO.GT.0) GOTO 100 C C36B* SEDIMENT INITIALIZATION AND WATER COLUMN/BED REPRESENTATION OPTIONS @@ -846,9 +945,11 @@ C36B* SEDIMENT INITIALIZATION AND WATER COLUMN/BED REPRESENTATION OPTIONS CALL SEEK('C36B') READ(1,*,IOSTAT=ISO)ISEDAL,ISNDAL,IALTYP,IALSTUP, & ISEDEFF,HBEDAL,COEHEFF,COEHEFF2 + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ISEDAL,ISNDAL,IALTYP,IALSTUP, & HBEDAL,COEHEFF,COEHEFF2 + ENDIF IF(ISO.GT.0) GOTO 100 C C37* BED MECHANICAL PROPERTIES PARAMETER SET 1 @@ -856,9 +957,11 @@ C37* BED MECHANICAL PROPERTIES PARAMETER SET 1 CALL SEEK('C37') READ(1,*,IOSTAT=ISO)ISEDDT,IBMECH,IMORPH,HBEDMAX,BEDPORC, & SEDMDMX,SEDMDMN,SEDVDRD,SEDVDRM,SEDVRDT + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ISEDDT,IBMECH,IMORPH,HBEDMAX,BEDPORC, & SEDMDMX,SEDMDMN,SEDVDRD,SEDVDRM,SEDVRDT + ENDIF IF(ISO.GT.0) GOTO 100 ISEDDTC=0 IF(IBMECH.EQ.0) THEN @@ -885,8 +988,10 @@ C38* BED MECHANICAL PROPERTIES PARAMETER SET 2 CALL SEEK('C38') READ(1,*,IOSTAT=ISO)IBMECHK,BMECH1,BMECH2,BMECH3,BMECH4,BMECH5, & BMECH6 + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)IBMECHK,BMECH1,BMECH2,BMECH3,BMECH4,BMECH5,BMECH6 + ENDIF IF(ISO.GT.0) GOTO 100 ENDIF C @@ -898,9 +1003,11 @@ C39* READ COHESIVE SEDIMENT PARAMETER SET 1 REPEAT DATA LINE NSED TIMES DO N=1,NSED READ(1,*,IOSTAT=ISO)SEDO(N),SEDBO(N),SDEN(N),SSG(N), & WSEDO(N),SEDN(N),SEXP(N),TAUD(N),ISEDSCOR(N) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)SEDO(N),SEDBO(N),SDEN(N),SSG(N), & WSEDO(N),SEDN(N),SEXP(N),TAUD(N) + ENDIF IF(ISO.GT.0) GOTO 100 SEDDIA(N)=0. HADJ=SEDN(1) @@ -913,13 +1020,15 @@ C40* READ COHESIVE SEDIMENT PARAMETER SET 2 REPEAT DATA LINE NSED TIMES DO N=1,NSED READ(1,*,IOSTAT=ISO)IWRSP(N),IWRSPB(N),WRSPO(N),TAUR(N),TAUN(N), & TEXP(N),VDRRSPO(N),COSEDHID(N) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)IWRSP(N),IWRSPB(N),WRSPO(N),TAUR(N),TAUN(N),TEXP(N), & VDRRSPO(N),COSEDHID(N) + ENDIF IF(ISO.GT.0) GOTO 100 C IF(N.EQ.1.AND.IWRSP(N).EQ.999) THEN - PRINT *,'READING TAU_CRIT_COH.INP' + IF(MYRANK.EQ.0) PRINT *,'READING TAU_CRIT_COH.INP' OPEN(1001,FILE='TAU_CRIT_COH.INP',STATUS='OLD') DO L = 2, 4393 READ(1001,*,IOSTAT=ISO) (TAUCRCOH(L,K),K=1,10) @@ -931,8 +1040,8 @@ C ! *** PMC - Mass Erosion is not enabled in EFDC at this time, so ensure disabled IF(IWRSPB(N).GT.0)THEN - PRINT *,' *** WARNING: COHESIVE MASS/BULK EROSION IS NOT ENA - &BLED IN EFDC!' + IF(MYRANK.EQ.0) PRINT *,' *** WARNING: COHESIVE MASS/BULK + & EROSION IS NOT ENABLED IN EFDC!' IWRSPB(N)=0 ENDIF ENDDO @@ -950,9 +1059,11 @@ C41* READ NONCOHESIVE SEDIMENT PARAMETER SET 1 REPEAT DATA LINE NSND TIMES IF(WSEDO(N).LT.0.0)THEN WSEDO(N)=SETSTVEL(SEDDIA(N),SSG(N)) ENDIF + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)SEDO(N),SEDBO(N),SDEN(N),SSG(N),SEDDIA(N), & WSEDO(N),SEDN(N),SEXP(N),TAUD(N),ISEDSCOR(N) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -979,9 +1090,11 @@ C C C IF TAUR(N) IS NEGATIVE, COMPUTE USING VAN RIJN'S FORMULA C + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ISNDEQ(N),TAUR(N),TAUN(N),TCSHIELDS(N),SEDDIA(N), & SSG(N),DSTR,USTR + ENDIF IF(ISO.GT.0) GOTO 100 IWRSP(N)=0 WRSPO(N)=0.0 @@ -992,9 +1105,11 @@ C42A* READ NONCOHESIVE SEDIMENT BED LOAD PARAMETERS CALL SEEK('C42A') READ(1,*,IOSTAT=ISO)ISBDLDBC,SBDLDA,SBDLDB,SBDLDG1, & SBDLDG2,SBDLDG3,SBDLDG4,SBDLDP,ISBLFUC,BLBSNT + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ISBDLDBC,SBDLDA,SBDLDB,SBDLDG1,SBDLDG2,SBDLDG3, & SBDLDG4,SBDLDP,ISBLFUC,BLBSNT + ENDIF IF(ISO.GT.0) GOTO 100 ENDIF C @@ -1006,9 +1121,11 @@ C43* READ TOXIC CONTAMINANT INITIAL CONDITIONS AND PARAMETERS DO NT=1,NTOX READ(1,*,IOSTAT=ISO)NDUM,ITXINT(NT),ITXBDUT(NT),TOXINTW(NT), & TOXINTB(NT),RKTOXW(NT),TKTOXW(NT),RKTOXB(NT),TRTOXB(NT) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)NDUM,ITXINT(NT),ITXBDUT(NT),TOXINTW(NT), & TOXINTB(NT),RKTOXW(NT),TKTOXW(NT),RKTOXB(NT),TRTOXB(NT) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1021,10 +1138,12 @@ C44* READ TOXIC CONTAMINANT PARAMETERS READ(1,*,IOSTAT=ISO)NDUM,ISTOC(NT),VOLTOX(NT),RMOLTX(NT), & RKTOXP(NT),SKTOXP(NT),DIFTOX(NT), & DIFTOXS(NT),PDIFTOX (NT),DPDIFTOX(NT) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)NDUM,ISTOC(NT),VOLTOX(NT),RMOLTX(NT),RKTOXP(NT), & SKTOXP(NT),DIFTOX(NT), & DIFTOXS(NT),PDIFTOX (NT),DPDIFTOX(NT) + ENDIF IF(ISO.GT.0) GOTO 100 ISDIFBW(NT)=0 IF(DIFTOXS(NT).LT.0.0)THEN @@ -1044,10 +1163,12 @@ C45* READ TOXIC CONTAMINANT-SEDIMENT INTERACTION PARAMETERS READ(1,*,IOSTAT=ISO)NDUM1,NDUM2, & ITXPARW(N,NT),TOXPARW(N,NT),CONPARW(N,NT), & ITXPARB(N,NT),TOXPARB(N,NT),CONPARB(N,NT) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)NDUM1,NDUM2, & ITXPARW(N,NT),TOXPARW(N,NT),CONPARW(N,NT), & ITXPARB(N,NT),TOXPARB(N,NT),CONPARB(N,NT) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1057,10 +1178,12 @@ C45* READ TOXIC CONTAMINANT-SEDIMENT INTERACTION PARAMETERS READ(1,*,IOSTAT=ISO)NDUM1,NDUM2, & ITXPARW(N,NT),TOXPARW(N,NT),CONPARW(N,NT), & ITXPARB(N,NT),TOXPARB(N,NT),CONPARB(N,NT) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)NDUM1,NDUM2, & ITXPARW(N,NT),TOXPARW(N,NT),CONPARW(N,NT), & ITXPARB(N,NT),TOXPARB(N,NT),CONPARB(N,NT) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1073,9 +1196,11 @@ C45A* READ TOXIC CONTAMINANT ORGANIC CARBON PARAMETERS IF(IWRSP(1).LT.90.AND.NTOX.GT.0)THEN ! SEDZLJ edit READ(1,*,IOSTAT=ISO)ISTDOCW,ISTPOCW,ISTDOCB,ISTPOCB, & STDOCWC,STPOCWC,STDOCBC,STPOCBC + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ISTDOCW,ISTPOCW,ISTDOCB,ISTPOCB, & STDOCWC,STPOCWC,STDOCBC,STPOCBC + ENDIF IF(ISO.GT.0) GOTO 100 ENDIF C @@ -1087,18 +1212,22 @@ C45B* READ TOXIC CONTAMINANT-ORGANIC CARBON INTERACTION PARAMETERS READ(1,*,IOSTAT=ISO)NDUM1,NDUM2, & ITXPARWC(1,NT),TOXPARWC(1,NT),CONPARWC(1,NT), & ITXPARBC(1,NT),TOXPARBC(1,NT),CONPARBC(1,NT) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)NDUM1,NDUM2, & ITXPARWC(1,NT),TOXPARWC(1,NT),CONPARWC(1,NT), & ITXPARBC(1,NT),TOXPARBC(1,NT),CONPARBC(1,NT) + ENDIF IF(ISO.GT.0) GOTO 100 READ(1,*,IOSTAT=ISO)NDUM1,NDUM2, & ITXPARWC(2,NT),TOXPARWC(2,NT),CONPARWC(2,NT), & ITXPARBC(2,NT),TOXPARBC(2,NT),CONPARBC(2,NT) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)NDUM1,NDUM2, & ITXPARWC(2,NT),TOXPARWC(2,NT),CONPARWC(2,NT), & ITXPARBC(2,NT),TOXPARBC(2,NT),CONPARBC(2,NT) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1106,13 +1235,17 @@ C C45C* READ TOXIC CONTAMINANT-ORGANIC CARBON WATER COLUMN POC FRACTIONS NCARD='45C' CALL SEEK('C45C') + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD + ENDIF NTMP=NSED+NSND IF(IWRSP(1).LT.90)THEN ! *** SEDZLJ Edit DO NT=1,NTOX READ(1,*,IOSTAT=ISO)NDUM1,(FPOCWST(NS,NT),NS=1,NTMP) IF(ISO.GT.0) GOTO 100 + IF(MYRANK.EQ.0)THEN WRITE(7,*)NDUM1,(FPOCWST(NS,NT),NS=1,NTMP) + ENDIF ENDDO ENDIF C @@ -1142,13 +1275,17 @@ C C45D* READ TOXIC CONTAMINANT-ORGANIC CARBON SED BED POC FRACTIONS NCARD='45D' CALL SEEK('C45D') + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD + ENDIF NTMP=NSED+NSND IF(IWRSP(1).LT.90)THEN ! *** SEDZLJ Edit DO NT=1,NTOX READ(1,*,IOSTAT=ISO)NDUM1,(FPOCBST(NS,NT),NS=1,NTMP) IF(ISO.GT.0) GOTO 100 + IF(MYRANK.EQ.0)THEN WRITE(7,*)NDUM1,(FPOCBST(NS,NT),NS=1,NTMP) + ENDIF ENDDO ENDIF C @@ -1180,8 +1317,10 @@ C46* READ BUOYANCY, TEMPERATURE, DYE DATA AND CONCENTRATION BC DATA NCARD='46' CALL SEEK('C46') READ(1,*,IOSTAT=ISO)BSC,TEMO,HEQT,RKDYE,NCBS,NCBW,NCBE,NCBN + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)BSC,TEMO,HEQT,RKDYE,NCBS,NCBW,NCBE,NCBN + ENDIF IF(ISO.GT.0) GOTO 100 IF(BSC.EQ.2)THEN BSC=1. @@ -1204,10 +1343,12 @@ C47* READ LOCATIONS OF CONC BC'S ON SOUTH BOUNDARIES READ(1,*,IOSTAT=ISO) ICBS(L),JCBS(L),NTSCRS(L), & NCSERS(L,1),NCSERS(L,2),NCSERS(L,3),NCSERS(L,4), & NTOXSRC,NSEDSRC,NSNDSRC + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ICBS(L),JCBS(L),NTSCRS(L), & NCSERS(L,1),NCSERS(L,2),NCSERS(L,3),NCSERS(L,4), & NTOXSRC,NSEDSRC,NSNDSRC + ENDIF IF(ISO.GT.0) GOTO 100 DO N=1,NTOX M=MSVTOX(N) @@ -1230,8 +1371,10 @@ C SAL,TEM,DYE,SFL,TOX(1 TO NTOX) MMAX=4+NTOX DO L=1,NCBS READ(1,*,IOSTAT=ISO) (CBS(L,1,M),M=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBS(L,1,M),M=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1243,8 +1386,10 @@ C SED(1 TO NSED),SND(1,NSND) MMAX=MMAX+NSED+NSND DO L=1,NCBS READ(1,*,IOSTAT=ISO) (CBS(L,1,M),M=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBS(L,1,M),M=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1255,8 +1400,10 @@ C SAL,TEM,DYE,SFL,TOX(1 TO NTOX) MMAX=4+NTOX DO L=1,NCBS READ(1,*,IOSTAT=ISO) (CBS(L,2,M),M=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBS(L,2,M),M=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1268,8 +1415,10 @@ C SED(1 TO NSED),SND(1,NSND) MMAX=MMAX+NSED+NSND DO L=1,NCBS READ(1,*,IOSTAT=ISO) (CBS(L,2,M),M=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBS(L,2,M),M=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1282,10 +1431,12 @@ C52* READ LOCATIONS OF CONC BC'S ON WEST BOUNDARIES READ(1,*,IOSTAT=ISO) ICBW(L),JCBW(L),NTSCRW(L), & NCSERW(L,1),NCSERW(L,2),NCSERW(L,3),NCSERW(L,4), & NTOXSRC,NSEDSRC,NSNDSRC + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ICBW(L),JCBW(L),NTSCRW(L), & NCSERW(L,1),NCSERW(L,2),NCSERW(L,3),NCSERW(L,4), & NTOXSRC,NSEDSRC,NSNDSRC + ENDIF IF(ISO.GT.0) GOTO 100 DO N=1,NTOX M=MSVTOX(N) @@ -1308,8 +1459,10 @@ C SAL,TEM,DYE,SFL,TOX(1 TO NTOX) MMAX=4+NTOX DO L=1,NCBW READ(1,*,IOSTAT=ISO) (CBW(L,1,M),M=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBW(L,1,M),M=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1321,8 +1474,10 @@ C SED(1 TO NSED),SND(1,NSND) MMAX=MMAX+NSED+NSND DO L=1,NCBW READ(1,*,IOSTAT=ISO) (CBW(L,1,M),M=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBW(L,1,M),M=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1333,8 +1488,10 @@ C SAL,TEM,DYE,SFL,TOX(1 TO NTOX) MMAX=4+NTOX DO L=1,NCBW READ(1,*,IOSTAT=ISO) (CBW(L,2,M),M=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBW(L,2,M),M=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1346,8 +1503,10 @@ C SED(1 TO NSED),SND(1,NSND) MMAX=MMAX+NSED+NSND DO L=1,NCBW READ(1,*,IOSTAT=ISO) (CBW(L,2,M),M=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBW(L,2,M),M=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1360,10 +1519,12 @@ C57* READ LOCATIONS OF CONC BC'S ON EAST BOUNDARIES READ(1,*,IOSTAT=ISO) ICBE(L),JCBE(L),NTSCRE(L), & NCSERE(L,1),NCSERE(L,2),NCSERE(L,3),NCSERE(L,4), & NTOXSRC,NSEDSRC,NSNDSRC + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ICBE(L),JCBE(L),NTSCRE(L), & NCSERE(L,1),NCSERE(L,2),NCSERE(L,3),NCSERE(L,4), & NTOXSRC,NSEDSRC,NSNDSRC + ENDIF IF(ISO.GT.0) GOTO 100 DO N=1,NTOX M=MSVTOX(N) @@ -1386,8 +1547,10 @@ C SAL,TEM,DYE,SFL,TOX(1 TO NTOX) MMAX=4+NTOX DO L=1,NCBE READ(1,*,IOSTAT=ISO) (CBE(L,1,M),M=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBE(L,1,M),M=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1399,8 +1562,10 @@ C SED(1 TO NSED),SND(1,NSND) MMAX=MMAX+NSED+NSND DO L=1,NCBE READ(1,*,IOSTAT=ISO) (CBE(L,1,M),M=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBE(L,1,M),M=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1411,8 +1576,10 @@ C SAL,TEM,DYE,SFL,TOX(1 TO NTOX) MMAX=4+NTOX DO L=1,NCBE READ(1,*,IOSTAT=ISO) (CBE(L,2,M),M=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBE(L,2,M),M=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1424,8 +1591,10 @@ C SED(1 TO NSED),SND(1,NSND) MMAX=MMAX+NSED+NSND DO L=1,NCBE READ(1,*,IOSTAT=ISO) (CBE(L,2,M),M=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBE(L,2,M),M=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1438,10 +1607,12 @@ C62* READ LOCATIONS OF CONC BC'S ON NORTH BOUNDARIES READ(1,*,IOSTAT=ISO) ICBN(L),JCBN(L),NTSCRN(L), & NCSERN(L,1),NCSERN(L,2),NCSERN(L,3),NCSERN(L,4), & NTOXSRC,NSEDSRC,NSNDSRC + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ICBN(L),JCBN(L),NTSCRN(L), & NCSERN(L,1),NCSERN(L,2),NCSERN(L,3),NCSERN(L,4), & NTOXSRC,NSEDSRC,NSNDSRC + ENDIF IF(ISO.GT.0) GOTO 100 DO N=1,NTOX M=MSVTOX(N) @@ -1464,8 +1635,10 @@ C SAL,TEM,DYE,SFL,TOX(1 TO NTOX) MMAX=4+NTOX DO L=1,NCBN READ(1,*,IOSTAT=ISO) (CBN(L,1,M),M=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBN(L,1,M),M=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1477,8 +1650,10 @@ C SED(1 TO NSED),SND(1,NSND) MMAX=MMAX+NSED+NSND DO L=1,NCBN READ(1,*,IOSTAT=ISO) (CBN(L,1,M),M=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBN(L,1,M),M=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1489,8 +1664,10 @@ C SAL,TEM,DYE,SFL,TOX(1 TO NTOX) MMAX=4+NTOX DO L=1,NCBN READ(1,*,IOSTAT=ISO) (CBN(L,2,M),M=1,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBN(L,2,M),M=1,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1502,8 +1679,10 @@ C SED(1 TO NSED),SND(1,NSND) MMAX=MMAX+NSED+NSND DO L=1,NCBN READ(1,*,IOSTAT=ISO) (CBN(L,2,M),M=MMIN,MMAX) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) (CBN(L,2,M),M=MMIN,MMAX) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1512,8 +1691,10 @@ C66A* READ CONCENTRATION DATA ASSIMILATION PARAMETERS NCARD='66A' CALL SEEK('C66A') READ(1,*,IOSTAT=ISO) NLCDA,TSCDA,(ISCDA(K),K=1,7) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) NLCDA,TSCDA,(ISCDA(K),K=1,7) + ENDIF IF(ISO.GT.0) GOTO 100 C C66B* READ CONCENTRATION DATA ASSIMILATION LOCATIONS AND @@ -1521,12 +1702,16 @@ C SERIES IDENTIFIERS IF(NLCDA.GT.0)THEN NCARD='66B' CALL SEEK('C66B') + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD + ENDIF DO L=1,NLCDA READ(1,*,IOSTAT=ISO) ITPCDA(L),ICDA(L),JCDA(L), & ICCDA(L),JCCDA(L),(NCSERA(L,K),K=1,7) + IF(MYRANK.EQ.0)THEN WRITE(7,*) ITPCDA(L),ICDA(L),JCDA(L), & ICCDA(L),JCCDA(L),(NCSERA(L,K),K=1,7) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1536,9 +1721,11 @@ C67* READ NEUTRALLY BUOYANT PARTICLE DRIFTER DATA CALL SEEK('C67') READ(1,*,IOSTAT=ISO) ISPD,NPD,NPDRT,NWPD,ISLRPD,ILRPD1,ILRPD2, & JLRPD1, JLRPD2, MLRPDRT,IPLRPD + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISPD,NPD,NPDRT,NWPD,ISLRPD,ILRPD1,ILRPD2, & JLRPD1, JLRPD2, MLRPDRT,IPLRPD + ENDIF IF(ISO.GT.0) GOTO 100 C @@ -1548,8 +1735,10 @@ C68* READ NEUTRALLY BUOYANT PARTICLE INITIAL POSITIONS CALL SEEK('C68') DO NP=1,NPD READ(1,*,IOSTAT=ISO) RI(NP),RJ(NP),RK(NP) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) RI(NP),RJ(NP),RK(NP) + ENDIF ENDDO ENDIF C @@ -1557,8 +1746,10 @@ C69* CONSTANTS FOR LONGITUDE AND LATITUDE OF CELL CENTERS NCARD='69' CALL SEEK('C69') READ(1,*,IOSTAT=ISO) CDLON1,CDLON2,CDLON3,CDLAT1,CDLAT2,CDLAT3 + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) CDLON1,CDLON2,CDLON3,CDLAT1,CDLAT2,CDLAT3 + ENDIF IF(ISO.GT.0) GOTO 100 C C70* CONTROLS FOR WRITING ASCII OR BINARY DUMP FILES @@ -1566,9 +1757,11 @@ C70* CONTROLS FOR WRITING ASCII OR BINARY DUMP FILES CALL SEEK('C70') READ(1,*,IOSTAT=ISO)ISDUMP,ISADMP,NSDUMP,TSDUMP,TEDUMP,ISDMPP, & ISDMPU,ISDMPW,ISDMPT,IADJDMP + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ISDUMP,ISADMP,NSDUMP,TSDUMP,TEDUMP,ISDMPP, & ISDMPU,ISDMPW,ISDMPT,IADJDMP + ENDIF IF(ISO.GT.0) GOTO 100 JSDUMP=1 NCDUMP=1 @@ -1578,8 +1771,10 @@ C71* CONTROLS FOR HORIZONTAL PLANE SCALAR FIELD CONTOURING CALL SEEK('C71') DO N=1,7 READ(1,*,IOSTAT=ISO) ISSPH(N),NPSPH(N),ISRSPH(N),ISPHXY(N) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISSPH(N),NPSPH(N),ISRSPH(N),ISPHXY(N) + ENDIF ENDDO IF(ISO.GT.0) GOTO 100 ISSPH(8)=0 @@ -1598,9 +1793,11 @@ C71A* CONTROLS FOR HORIZONTAL PLANE SEDIMENT BED PROPERTIES CALL SEEK('C71A') READ(1,*,IOSTAT=ISO) ISBPH,ISBEXP,NPBPH,ISRBPH,ISBBDN,ISBLAY, & ISBPOR,ISBSED,ISBSND,ISBVDR,ISBARD + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISBPH,ISBEXP,NPBPH,ISRBPH,ISBBDN,ISBLAY, & ISBPOR,ISBSED,ISBSND,ISBVDR,ISBARD + ENDIF IF(ISO.GT.0) GOTO 100 IF(ISBEXP.GE.1) NPSPH(8)=MAX(NPSPH(8),NPBPH) JSBPH=1 @@ -1610,8 +1807,10 @@ C71B* CONTROLS FOR FOOD CHAIN MODEL OUTPUT NCARD='71B' CALL SEEK('C71B') READ(1,*,IOSTAT=ISO) ISFDCH,NFDCHZ,HBFDCH,TFCAVG + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISFDCH,NFDCHZ,HBFDCH,TFCAVG + ENDIF IF(ISO.GT.0) GOTO 100 C C72* CONTROLS FOR HORIZONTAL PLANE SURFACE ELEVATION OR PRESSURE @@ -1619,16 +1818,20 @@ C72* CONTROLS FOR HORIZONTAL PLANE SURFACE ELEVATION OR PRESSURE NCARD='72' CALL SEEK('C72') READ(1,*,IOSTAT=ISO) ISPPH,NPPPH,ISRPPH,IPPHXY + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISPPH,NPPPH,ISRPPH,IPPHXY + ENDIF IF(ISO.GT.0) GOTO 100 C C73* CONTROLS FOR HORIZONTAL PLANE VELOCITY PLOTTING NCARD='73' CALL SEEK('C73') READ(1,*,IOSTAT=ISO) ISVPH,NPVPH,ISRVPH,IVPHXY + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISVPH,NPVPH,ISRVPH,IVPHXY + ENDIF IF(ISO.GT.0) GOTO 100 C C74* CONTROLS FOR VERTICAL PLANE SCALAR FIELD CONTOURING @@ -1636,17 +1839,21 @@ C74* CONTROLS FOR VERTICAL PLANE SCALAR FIELD CONTOURING CALL SEEK('C74') READ(1,*,IOSTAT=ISO) ISECSPV,NPSPV(1),ISSPV(1),ISRSPV(1), & ISHPLTV(1) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISECSPV,NPSPV(1),ISSPV(1),ISRSPV(1), & ISHPLTV(1) + ENDIF SHPLTV(1)=FLOAT(ISHPLTV(1)) SBPLTV(1)=1.0-SHPLTV(1) DO N=2,7 READ(1,*,IOSTAT=ISO) IDUMMY,NPSPV(N),ISSPV(N),ISRSPV(N), & ISHPLTV(N) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) IDUMMY,NPSPV(N),ISSPV(N),ISRSPV(N), & ISHPLTV(N) + ENDIF SHPLTV(N)=FLOAT(ISHPLTV(N)) SBPLTV(N)=1.0-SHPLTV(N) ENDDO @@ -1658,8 +1865,10 @@ C75* MORE CONTROLS FOR VERTICAL PLANE SCALAR FIELD CONTOURING CALL SEEK('C75') DO IS=1,ISECSPV READ(1,*,IOSTAT=ISO) DUM,NIJSPV(IS),CCTITLE(10+IS) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) DUM,NIJSPV(IS),CCTITLE(10+IS) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1669,8 +1878,10 @@ C76* I,J LOCATIONS DEFINING VERTICAL PLANE FOR CONTOURING DO IS=1,ISECSPV DO NPP=1,NIJSPV(IS) READ(1,*,IOSTAT=ISO) DUM,ISPV(NPP,IS),JSPV(NPP,IS) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) DUM,ISPV(NPP,IS),JSPV(NPP,IS) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDDO @@ -1679,8 +1890,10 @@ C NCARD='77' CALL SEEK('C77') READ(1,*,IOSTAT=ISO) ISECVPV,NPVPV,ISVPV,ISRVPV + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISECVPV,NPVPV,ISVPV,ISRVPV + ENDIF IF(ISO.GT.0) GOTO 100 C IF(ISECVPV.GT.0)THEN @@ -1688,8 +1901,10 @@ C CALL SEEK('C78') DO IS=1,ISECVPV READ(1,*,IOSTAT=ISO) DUM,NIJVPV(IS),ANGVPV(IS),CVTITLE(10+IS) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) DUM,NIJVPV(IS),ANGVPV(IS),CVTITLE(10+IS) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1698,8 +1913,10 @@ C DO IS=1,ISECVPV DO NPP=1,NIJVPV(IS) READ(1,*,IOSTAT=ISO) DUM,IVPV(NPP,IS),JVPV(NPP,IS) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) DUM,IVPV(NPP,IS),JVPV(NPP,IS) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDDO @@ -1709,9 +1926,11 @@ C CALL SEEK('C80') READ(1,*,IOSTAT=ISO)IS3DO,ISR3DO,NP3DO,KPC,NWGG,I3DMIN,I3DMAX, & J3DMIN,J3DMAX,I3DRW,SELVMAX,BELVMIN + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)IS3DO,ISR3DO,NP3DO,KPC,NWGG,I3DMIN,I3DMAX, & J3DMIN,J3DMAX,I3DRW,SELVMAX,BELVMIN + ENDIF IF(ISO.GT.0) GOTO 100 NCALL3D=0 NRCAL3D=0 @@ -1719,47 +1938,67 @@ C NCARD='81' CALL SEEK('C81') READ(1,*,IOSTAT=ISO)CDUM,IS3DUUU,JS3DUUU,UUU3DMA,UUU3DMI + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)CDUM,IS3DUUU,JS3DUUU,UUU3DMA,UUU3DMI + ENDIF IF(ISO.GT.0) GOTO 100 READ(1,*,IOSTAT=ISO)CDUM,IS3DVVV,JS3DVVV,VVV3DMA,VVV3DMI + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)CDUM,IS3DVVV,JS3DVVV,VVV3DMA,VVV3DMI + ENDIF IF(ISO.GT.0) GOTO 100 READ(1,*,IOSTAT=ISO)CDUM,IS3DWWW,JS3DWWW,WWW3DMA,WWW3DMI + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)CDUM,IS3DWWW,JS3DWWW,WWW3DMA,WWW3DMI + ENDIF IF(ISO.GT.0) GOTO 100 READ(1,*,IOSTAT=ISO)CDUM,IS3DSAL,JS3DSAL,SAL3DMA,SAL3DMI + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)CDUM,IS3DSAL,JS3DSAL,SAL3DMA,SAL3DMI + ENDIF IF(ISO.GT.0) GOTO 100 READ(1,*,IOSTAT=ISO)CDUM,IS3DTEM,JS3DTEM,TEM3DMA,TEM3DMI + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)CDUM,IS3DTEM,JS3DTEM,TEM3DMA,TEM3DMI + ENDIF IF(ISO.GT.0) GOTO 100 READ(1,*,IOSTAT=ISO)CDUM,IS3DDYE,JS3DDYE,DYE3DMA,DYE3DMI + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)CDUM,IS3DDYE,JS3DDYE,DYE3DMA,DYE3DMI + ENDIF IF(ISO.GT.0) GOTO 100 READ(1,*,IOSTAT=ISO)CDUM,IS3DSED,JS3DSED,SED3DMA,SED3DMI + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)CDUM,IS3DSED,JS3DSED,SED3DMA,SED3DMI + ENDIF IF(ISO.GT.0) GOTO 100 READ(1,*,IOSTAT=ISO)CDUM,IS3DSND,JS3DSND,SND3DMA,SND3DMI + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)CDUM,IS3DSND,JS3DSND,SND3DMA,SND3DMI + ENDIF IF(ISO.GT.0) GOTO 100 READ(1,*,IOSTAT=ISO)CDUM,IS3DTOX,JS3DTOX,TOX3DMA,TOX3DMI + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)CDUM,IS3DTOX,JS3DTOX,TOX3DMA,TOX3DMI + ENDIF IF(ISO.GT.0) GOTO 100 C NCARD='82' CALL SEEK('C82') READ(1,*,IOSTAT=ISO) ISLSHA,MLLSHA,NTCLSHA,ISLSTR,ISHTA + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ISLSHA,MLLSHA,NTCLSHA,ISLSTR,ISHTA + ENDIF IF(ISO.GT.0) GOTO 100 C IF(MLLSHA.GT.0)THEN @@ -1768,9 +2007,11 @@ C DO M=1,MLLSHA READ(1,*,IOSTAT=ISO) ILLSHA(M),JLLSHA(M),LSHAP(M),LSHAB(M), & LSHAUE(M),LSHAU(M),CLSL(M) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*) ILLSHA(M),JLLSHA(M),LSHAP(M),LSHAB(M), & LSHAUE(M),LSHAU(M),CLSL(M) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1779,9 +2020,11 @@ C CALL SEEK('C84') READ(1,*,IOSTAT=ISO)ISTMSR,MLTMSR,NBTMSR,NSTMSR,NWTMSR,NTSSTSP, & TCTMSR + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ISTMSR,MLTMSR,NBTMSR,NSTMSR,NWTMSR,NTSSTSP, & TCTMSR + ENDIF IF(ISO.GT.0) GOTO 100 JSTMSR=1 @@ -1794,8 +2037,10 @@ C CALL SEEK('C85') DO ITSSS=1,NTSSTSP READ(1,*,IOSTAT=ISO)IDUM,MTSSTSP(ITSSS) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)IDUM,MTSSTSP(ITSSS) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO C @@ -1805,9 +2050,11 @@ C DO MTSSS=1,MTSSTSP(ITSSS) READ(1,*,IOSTAT=ISO)IDUM,IDUM,TSSTRT(MTSSS,ITSSS), & TSSTOP(MTSSS,ITSSS) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)IDUM,IDUM,TSSTRT(MTSSS,ITSSS), & TSSTOP(MTSSS,ITSSS) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDDO @@ -1820,10 +2067,12 @@ C READ(1,*,IOSTAT=ISO)ILTMSR(M),JLTMSR(M),NTSSSS(M),MTMSRP(M), & MTMSRC(M),MTMSRA(M),MTMSRUE(M),MTMSRUT(M),MTMSRU(M), & MTMSRQE(M),MTMSRQ(M),CLTMSR(M) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ILTMSR(M),JLTMSR(M),NTSSSS(M),MTMSRP(M), & MTMSRC(M),MTMSRA(M),MTMSRUE(M),MTMSRUT(M),MTMSRU(M), & MTMSRQE(M),MTMSRQ(M),CLTMSR(M) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1831,8 +2080,10 @@ C NCARD='88' CALL SEEK('C88') READ(1,*,IOSTAT=ISO)ISVSFP,MDVSFP,MLVSFP,TMVSFP,TAVSFP + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)ISVSFP,MDVSFP,MLVSFP,TMVSFP,TAVSFP + ENDIF IF(ISO.GT.0) GOTO 100 JSVSFP=1 C @@ -1841,8 +2092,10 @@ C CALL SEEK('C89') DO M=1,MDVSFP READ(1,*,IOSTAT=ISO)IDUM,DMVSFP(M) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)IDUM,DMVSFP(M) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1852,8 +2105,10 @@ C CALL SEEK('C90') DO M=1,MLVSFP READ(1,*,IOSTAT=ISO)IDUM,TIMVSFP(M),IVSFP(M),JVSFP(M) + IF(MYRANK.EQ.0)THEN WRITE(7,1002)NCARD WRITE(7,*)IDUM,TIMVSFP(M),IVSFP(M),JVSFP(M) + ENDIF IF(ISO.GT.0) GOTO 100 ENDDO ENDIF @@ -1892,8 +2147,10 @@ C C ** WRITE INPUT ERROR MESSAGES AND TERMINATE RUN C 100 WRITE(6,1001)NCARD + IF(MYRANK.EQ.0)THEN WRITE(8,1001)NCARD WRITE(7,1001)NCARD + ENDIF STOP 2000 CONTINUE @@ -1902,16 +2159,25 @@ C ** NOW REWIND UNIT 1 & READ IN AS CHARACTER TO WRITE TO UNIT 7 C REWIND (1) 21 READ(1,22,END=24) TEXT - WRITE (7,23) TEXT + IF(MYRANK.EQ.0)WRITE (7,23) TEXT GOTO 21 24 CONTINUE CLOSE(1) 22 FORMAT (A80) 23 FORMAT (1X,A80) C +!{ GEOSR, Check file WINDCOEFF.INP exist jgcho 2016.10.21 + inquire (file='WINDCOEFF.INP', exist = lwd) + if(.not.lwd) then ! Not exist + ISWIND=0 + goto 9883 + else + ISWIND=1 + endif +!} GEOSR, Check file WINDCOEFF.INP exist jgcho 2016.10.21 !{GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. IF(ISWIND.EQ.1)THEN - PRINT *,'READING WINDCOEFF.INP' + IF(MYRANK.EQ.0) PRINT *,'READING WINDCOEFF.INP' OPEN(1,FILE='WINDCOEFF.INP',STATUS='UNKNOWN') DO IS=1,16 @@ -1935,7 +2201,8 @@ C CALL INPUT_WINDCOEF !! INPUT FOR WINDCOEFF.INP BY GEOSR GOTO 9883 - 9886 PRINT *,'READ ERROR FOR FILE WINDCOEFF.INP_CSG-01' + 9886 CONTINUE + IF(MYRANK.EQ.0) PRINT *,'READ ERROR FOR FILE WINDCOEFF.INP_CSG-01' STOP 9883 CONTINUE @@ -1943,7 +2210,7 @@ C CALL INPUT_WINDCOEF !! INPUT FOR WINDCOEFF.INP BY GEOSR C C ** READ CELL TYPES FROM FILES CELL.INP C - PRINT *,'READING CELL.INP' + IF(MYRANK.EQ.0) PRINT *,'READING CELL.INP' OPEN(1,FILE='CELL.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES AND DETERMINE FILE FORMAT @@ -1972,13 +2239,13 @@ C JF=JT JLAST=JT+JACROSS-1 IF(JLAST.GT.JC) JLAST=JC - WRITE (7,8)JF,JLAST + IF(MYRANK.EQ.0)WRITE (7,8)JF,JLAST DO I=1,IC READ(1,6,IOSTAT=ISO) (IJCT(I,J),J=JF,JLAST) IF(ISO.GT.0) GOTO 800 - WRITE (7,16) (IJCT(I,J),J=JF,JLAST) + IF(MYRANK.EQ.0)WRITE (7,16) (IJCT(I,J),J=JF,JLAST) ENDDO - WRITE(7,15) + IF(MYRANK.EQ.0)WRITE(7,15) ENDDO ELSE C @@ -1988,24 +2255,26 @@ C IFIRST=IT ILAST=IT+IACROSS-1 IF(ILAST.GT.IC) ILAST=IC - WRITE (7,88)IFIRST,ILAST + IF(MYRANK.EQ.0)WRITE (7,88)IFIRST,ILAST DO J=JC,1,-1 READ(1,66,IOSTAT=ISO)ADUMMY,(IJCT(I,J),I=IFIRST,ILAST) IF(ISO.GT.0) GOTO 800 - WRITE (7,166)ADUMMY,(IJCT(I,J),I=IFIRST,ILAST) + IF(MYRANK.EQ.0) + & WRITE (7,166)ADUMMY,(IJCT(I,J),I=IFIRST,ILAST) ENDDO - WRITE(7,15) + IF(MYRANK.EQ.0)WRITE(7,15) ENDDO ELSE IFIRST=1 ILAST=IC - WRITE (7,88)IFIRST,ILAST + IF(MYRANK.EQ.0)WRITE (7,88)IFIRST,ILAST DO J=JC,1,-1 READ(1,66,IOSTAT=ISO)ADUMMY,(IJCT(I,J),I=IFIRST,ILAST) IF(ISO.GT.0) GOTO 800 - WRITE (7,166)ADUMMY,(IJCT(I,J),I=IFIRST,ILAST) + IF(MYRANK.EQ.0) + & WRITE (7,166)ADUMMY,(IJCT(I,J),I=IFIRST,ILAST) ENDDO - WRITE(7,15) + IF(MYRANK.EQ.0)WRITE(7,15) ENDIF ENDIF CLOSE(1) @@ -2014,7 +2283,7 @@ C C C----------------------------------------------------------------------C C - PRINT *,'READING CELLLT.INP' + IF(MYRANK.EQ.0) PRINT *,'READING CELLLT.INP' OPEN(1,FILE='CELLLT.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES AND DETERMINE FILE FORMAT @@ -2042,13 +2311,13 @@ C ** READ OLD FILE FORMAT JF=JT JLAST=JT+JACROSS-1 IF(JLAST.GT.JC) JLAST=JC - WRITE (7,8)JF,JLAST + IF(MYRANK.EQ.0)WRITE (7,8)JF,JLAST DO I=1,IC READ(1,6,IOSTAT=ISO) (IJCTLT(I,J),J=JF,JLAST) IF(ISO.GT.0) GOTO 800 - WRITE (7,16) (IJCTLT(I,J),J=JF,JLAST) + IF(MYRANK.EQ.0)WRITE (7,16) (IJCTLT(I,J),J=JF,JLAST) ENDDO - WRITE(7,15) + IF(MYRANK.EQ.0)WRITE(7,15) ENDDO ELSE @@ -2059,24 +2328,26 @@ C ** READ NEW FILE FORMAT IFIRST=IT ILAST=IT+IACROSS-1 IF(ILAST.GT.IC) ILAST=IC - WRITE (7,88)IFIRST,ILAST + IF(MYRANK.EQ.0)WRITE (7,88)IFIRST,ILAST DO J=JC,1,-1 READ(1,66,IOSTAT=ISO)ADUMMY,(IJCTLT(I,J),I=IFIRST,ILAST) IF(ISO.GT.0) GOTO 800 - WRITE (7,166)ADUMMY,(IJCTLT(I,J),I=IFIRST,ILAST) + IF(MYRANK.EQ.0) + & WRITE (7,166)ADUMMY,(IJCTLT(I,J),I=IFIRST,ILAST) ENDDO - WRITE(7,15) + IF(MYRANK.EQ.0)WRITE(7,15) ENDDO ELSE IFIRST=1 ILAST=IC - WRITE (7,88)IFIRST,ILAST + IF(MYRANK.EQ.0)WRITE (7,88)IFIRST,ILAST DO J=JC,1,-1 READ(1,66,IOSTAT=ISO)ADUMMY,(IJCTLT(I,J),I=IFIRST,ILAST) IF(ISO.GT.0) GOTO 800 - WRITE (7,166)ADUMMY,(IJCTLT(I,J),I=IFIRST,ILAST) + IF(MYRANK.EQ.0) + & WRITE (7,166)ADUMMY,(IJCTLT(I,J),I=IFIRST,ILAST) ENDDO - WRITE(7,15) + IF(MYRANK.EQ.0)WRITE(7,15) ENDIF ENDIF C @@ -2089,7 +2360,7 @@ C ** FILE MAPPGNS.INP TO SPECIFY A PERIODIC DOMAIN IN THE NORTH-SOUTH C ** DIRECTION C IF(ISPGNS.GE.1)THEN - PRINT *,'READING MAPPGNS.INP' + IF(MYRANK.EQ.0) PRINT *,'READING MAPPGNS.INP' OPEN(1,FILE='MAPPGNS.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -2153,12 +2424,12 @@ C 6 FORMAT (120I1) C 66 FORMAT (I3,2X,120I1) PMC 66 FORMAT (A5,120I1) - 9 FORMAT (/,' DEPTH ARRAY:',//) +C 9 FORMAT (/,' DEPTH ARRAY:',//) 16 FORMAT (1X,120I1) C 166 FORMAT (1X,I3,2X,120I1) PMC 166 FORMAT (1X,A5,120I1) - 7 FORMAT (30F4.1) - 17 FORMAT(1X,30F4.1) +C 7 FORMAT (30F4.1) +C 17 FORMAT(1X,30F4.1) C C ** READ CURVILINEAR-ORTHOGONAL OR VARIABLE CELL DATA FROM FILE C ** DXDY.INP @@ -2174,7 +2445,7 @@ C ** READ IN DX, DY, DEPTH AND BOTTOM ELEVATION AT CELL CENTERS OF C ** VARIABLE CELLS C IF(LVC.GT.0)THEN - PRINT *,'READING DXDY.INP' + IF(MYRANK.EQ.0) PRINT *,'READING DXDY.INP' OPEN(1,FILE='DXDY.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -2364,7 +2635,7 @@ C C ** OPEN FILE MODDXDY.INP TO MODIFY INPUT VALUES OF DX AND DY C IF(IMDXDY.GT.0)THEN - PRINT *,'READING MODDXDY.INP' + IF(MYRANK.EQ.0) PRINT *,'READING MODDXDY.INP' OPEN(1,FILE='MODDXDY.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND HEADER LINES @@ -2389,7 +2660,7 @@ C ** HOST CELLS C MDCHH=0 IF(ISCHAN.GT.0)THEN - PRINT *,'READING MODCHAN.INP' + IF(MYRANK.EQ.0) PRINT *,'READING MODCHAN.INP' OPEN(1,FILE='MODCHAN.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -2455,7 +2726,7 @@ C ** BY INFILTRATION AND EVAPOTRANSPIRATION C ISGWIE=0 IF(ISGWIT.EQ.1)THEN - PRINT *,'READING GWATER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING GWATER.INP' OPEN(1,FILE='GWATER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -2473,12 +2744,12 @@ C ENDIF CLOSE(1) ENDIF - 339 FORMAT(2I5,6F14.5) +C 339 FORMAT(2I5,6F14.5) C C ** OPEN FILE FBODY.INP TO READ IN SPATIALLY VARYING BODY FORCES C IF(ISBODYF.GE.1)THEN - PRINT *,'READING FBODY.INP' + IF(MYRANK.EQ.0) PRINT *,'READING FBODY.INP' OPEN(1,FILE='FBODY.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -2510,7 +2781,7 @@ C ** OR RECIRCULATION BOUNDARY CONDITIONS C NSBDLDBC=0 IF(ISBDLDBC.GE.1)THEN - PRINT *,'READING SEDBLBC.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SEDBLBC.INP' OPEN(1,FILE='SEDBLBC.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -2554,7 +2825,7 @@ C ** AMBIENT GROUNDWATER FLOW ENDDO CLOSE(1) ENDIF - PRINT *,'READING GWMAP.INP' + IF(MYRANK.EQ.0) PRINT *,'READING GWMAP.INP' OPEN(1,FILE='GWMAP.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -2584,7 +2855,7 @@ C ** DETERMINING GRAIN STRESS C IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN IF(ISBEDSTR.EQ.3)THEN - PRINT *,'READING SEDROUGH.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SEDROUGH.INP' OPEN(1,FILE='SEDROUGH.INP') DO IS=1,2 READ(1,*) @@ -2609,7 +2880,7 @@ C ENDDO IF(IVAL.EQ.1)THEN IF(ISTDOCW.EQ.1)THEN - PRINT *,'READING DOCW.INP' + IF(MYRANK.EQ.0) PRINT *,'READING DOCW.INP' OPEN(1,FILE='DOCW.INP',STATUS='UNKNOWN') DO IS=1,8 READ(1,*) @@ -2638,7 +2909,7 @@ C ENDDO IF(IVAL.EQ.1)THEN IF(ISTPOCW.EQ.1)THEN - PRINT *,'READING POCW.INP' + IF(MYRANK.EQ.0) PRINT *,'READING POCW.INP' OPEN(1,FILE='POCW.INP',STATUS='UNKNOWN') DO IS=1,8 READ(1,*) @@ -2668,7 +2939,7 @@ C ENDDO IF(IVAL.EQ.1)THEN IF(ISTPOCW.EQ.3)THEN - PRINT *,'READING FPOCW.INP' + IF(MYRANK.EQ.0) PRINT *,'READING FPOCW.INP' OPEN(1,FILE='FPOCW.INP',STATUS='UNKNOWN') DO NS=1,NSED+NSND DO IS=1,8 @@ -2700,7 +2971,7 @@ C ENDDO IF(IVAL.EQ.1)THEN IF(ISTDOCB.EQ.1)THEN - PRINT *,'READING DOCB.INP' + IF(MYRANK.EQ.0) PRINT *,'READING DOCB.INP' OPEN(1,FILE='DOCB.INP',STATUS='UNKNOWN') DO IS=1,8 READ(1,*) @@ -2777,7 +3048,7 @@ C ENDDO IF(IVAL.EQ.1)THEN IF(ISTPOCB.EQ.1)THEN - PRINT *,'READING POCB.INP' + IF(MYRANK.EQ.0) PRINT *,'READING POCB.INP' OPEN(1,FILE='POCB.INP',STATUS='UNKNOWN') DO IS=1,8 READ(1,*) @@ -2855,7 +3126,7 @@ C ENDDO IF(IVAL.EQ.1)THEN IF(ISTPOCB.EQ.3)THEN - PRINT *,'READING FPOCB.INP' + IF(MYRANK.EQ.0) PRINT *,'READING FPOCB.INP' OPEN(1,FILE='FPOCB.INP',STATUS='UNKNOWN') DO NS=1,NSED+NSND DO IS=1,8 @@ -2933,7 +3204,7 @@ C ** PARTICULATE ORGANIC CARBON IN BED AND PSEUDO-POC IN BED C IF(ISTPOCB.EQ.4)THEN C - PRINT *,'READING FOCB.INP' + IF(MYRANK.EQ.0) PRINT *,'READING FOCB.INP' OPEN(1,FILE='FOCB.INP',STATUS='UNKNOWN') DO IS=1,8 READ(1,*) @@ -2956,7 +3227,7 @@ C ENDDO CLOSE(1) C - PRINT *,'READING PSEUDO_FOCB.INP' + IF(MYRANK.EQ.0) PRINT *,'READING PSEUDO_FOCB.INP' OPEN(1,FILE='PSEUDO_FOCB.INP',STATUS='UNKNOWN') DO IS=1,8 READ(1,*) @@ -2989,7 +3260,7 @@ C & (ISRESTI.GE.1.AND.ISCI(1).EQ.0).OR. & (ISTOPT(1).GT.1)))THEN ! *** PMC SINGLE LINE - FORCE IC IF(ISTOPT(1).GE.1)THEN - PRINT *,'READING SALT.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SALT.INP' OPEN(1,FILE='SALT.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3025,7 +3296,7 @@ C & (ISRESTI.GE.1.AND.ISCI(2).EQ.0).OR. & (ISTOPT(2).GT.9)))THEN ! *** PMC SINGLE LINE - FORCE IC IF(ISTOPT(2).GE.1.OR.INITTEMP.GT.0)THEN - PRINT *,'READING TEMP.INP' + IF(MYRANK.EQ.0) PRINT *,'READING TEMP.INP' OPEN(1,FILE='TEMP.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3060,7 +3331,7 @@ C & (ISRESTI.GE.1.AND.ISCI(3).EQ.0).OR. & (ISTOPT(3).GT.1)))THEN ! *** PMC SINGLE LINE - FORCE IC IF(ISTOPT(3).GE.1)THEN - PRINT *,'READING DYE.INP' + IF(MYRANK.EQ.0) PRINT *,'READING DYE.INP' OPEN(1,FILE='DYE.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3093,7 +3364,7 @@ C ENDDO IF(ISRESTI.EQ.0.AND.ISTRAN(4).GE.1)THEN IF(ISTOPT(4).GE.1)THEN - PRINT *,'READING SFL.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SFL.INP' OPEN(1,FILE='SFL.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3155,7 +3426,7 @@ C IF(ISRESTI.GE.1.AND.ISCI(5).EQ.0) IISTMP=0 IF(IISTMP.EQ.0.AND.ISTRAN(5).GE.1)THEN IF(ISLTMT.EQ.0)THEN - PRINT *,'READING TOXW.INP' + IF(MYRANK.EQ.0) PRINT *,'READING TOXW.INP' OPEN(1,FILE='TOXW.INP',STATUS='UNKNOWN') IF(ITXINT(1).EQ.1.OR.ITXINT(1).EQ.3)THEN DO NT=1,NTOX @@ -3188,7 +3459,7 @@ C IF(ISRESTI.GE.1.AND.ISCI(5).EQ.0) IISTMP=0 IF(IISTMP.EQ.0.AND.ISTRAN(5).GE.1)THEN IF(ISLTMT.EQ.0.)THEN - PRINT *,'READING TOXB.INP' + IF(MYRANK.EQ.0) PRINT *,'READING TOXB.INP' OPEN(1,FILE='TOXB.INP',STATUS='UNKNOWN') IF(ITXINT(1).EQ.2.OR.ITXINT(1).EQ.3)THEN DO NT=1,NTOX @@ -3259,7 +3530,7 @@ C IF(ISRESTI.GE.1.AND.ISCI(6).EQ.0) IISTMP=0 IF(IISTMP.EQ.0.AND.ISTRAN(6).GE.1)THEN IF(ITXINTT.GE.1)THEN - PRINT *,'READING SEDW.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SEDW.INP' OPEN(1,FILE='SEDW.INP',STATUS='UNKNOWN') DO NS=1,NSED C @@ -3293,7 +3564,7 @@ C IF(ISRESTI.GE.1.AND.ISCI(6).EQ.0) IISTMP=0 IF(IISTMP.EQ.0.AND.ISTRAN(6).GE.1.AND.IWRSP(1)/=98)THEN !avoids loop if SEDZLJ is active IF(ITXINTT.GE.1)THEN - PRINT *,'READING SEDB.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SEDB.INP' OPEN(1,FILE='SEDB.INP',STATUS='UNKNOWN') DO NS=1,NSED C @@ -3369,7 +3640,7 @@ C IF(ISRESTI.GE.1.AND.ISCI(7).EQ.0) IISTMP=0 IF(IISTMP.EQ.0.AND.ISTRAN(7).GE.1)THEN IF(ITXINTT.GE.1)THEN - PRINT *,'READING SNDW.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SNDW.INP' OPEN(1,FILE='SNDW.INP',STATUS='UNKNOWN') DO NX=1,NSND C @@ -3403,7 +3674,7 @@ C IF(ISRESTI.GE.1.AND.ISCI(7).EQ.0) IISTMP=0 IF(IISTMP.EQ.0.AND.ISTRAN(7).GE.1)THEN IF(ITXINTT.GE.1)THEN - PRINT *,'READING SNDB.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SNDB.INP' OPEN(1,FILE='SNDB.INP',STATUS='UNKNOWN') DO NX=1,NSND C @@ -3447,7 +3718,7 @@ C C ** BED LAYER THICKNESS C IF(IISTMP.EQ.0.AND.IBMECH.GE.1)THEN - PRINT *,'READING BEDLAY.INP' + IF(MYRANK.EQ.0) PRINT *,'READING BEDLAY.INP' OPEN(1,FILE='BEDLAY.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3481,7 +3752,7 @@ C C ** BED LAYER BULK DENSITY C IF(IISTMP.EQ.0.AND.IBMECH.GE.1)THEN - PRINT *,'READING BEDBDN.INP' + IF(MYRANK.EQ.0) PRINT *,'READING BEDBDN.INP' OPEN(1,FILE='BEDBDN.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3515,7 +3786,7 @@ C C ** BED LAYER DRY DENSITY, POROSITY OR VOID RATIO C IF(IISTMP.EQ.0.AND.IBMECH.GE.1)THEN - PRINT *,'READING BEDDDN.INP' + IF(MYRANK.EQ.0) PRINT *,'READING BEDDDN.INP' OPEN(1,FILE='BEDDDN.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3549,7 +3820,7 @@ C C ** CONSOLIDATION MAP C IF(IBMECH.EQ.9)THEN - PRINT *,'READING CONSOLMAP.INP' + IF(MYRANK.EQ.0) PRINT *,'READING CONSOLMAP.INP' OPEN(1,FILE='CONSOLMAP.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3572,14 +3843,14 @@ C CLOSE(1) ENDIF ENDIF - 19 FORMAT (/,' INITIAL BUOYANCY ARRAY:',//) - 907 FORMAT(12F6.2) +C 19 FORMAT (/,' INITIAL BUOYANCY ARRAY:',//) +C 907 FORMAT(12F6.2) C C ** READ IN OPEN BOUNDARY SURFACE ELEVATION TIME SERIES FROM THE C ** FILE PSER.INP C IF(NPSER.GE.1)THEN - PRINT *,'READING PSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING PSER.INP' OPEN(1,FILE='PSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3600,13 +3871,13 @@ C ENDDO CLOSE(1) ENDIF - 6776 FORMAT(A20) +C6776 FORMAT(A20) C C ** READ IN VOLUMETRIC SOURCE OR RIVER INFLOW TIME SERIES FROM THE C ** FILE QSER.INP C IF(NQSER.GE.1)THEN - PRINT *,'READING QSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING QSER.INP' OPEN(1,FILE='QSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3647,13 +3918,13 @@ C ENDDO CLOSE(1) ENDIF - 2222 FORMAT(2I5,F12.7,F12.4) +C2222 FORMAT(2I5,F12.7,F12.4) C C ** READ IN FLOW WITHDRAWL-RETURN FLOW AND CONCENTRATION RISE C ** TIME SERIES FROM THE FILE QWRS.INP C IF(NQWRSR.GE.1)THEN - PRINT *,'READING QWRS.INP' + IF(MYRANK.EQ.0) PRINT *,'READING QWRS.INP' OPEN(1,FILE='QWRS.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3697,7 +3968,7 @@ C ** READ IN GROUNDWATER INFLOW/OUTFLOW AND CONCENTRATION TIME C ** SERIES FROM THE FILE GWSER.INP C IF(ISGWIT.EQ.2)THEN - PRINT *,'READING GWSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING GWSER.INP' OPEN(1,FILE='GWSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3737,7 +4008,7 @@ C ** FROM THE FILE SSER.INP C 8888 FORMAT(3I5,2F10.2) IF(NCSER(1).GE.1)THEN - PRINT *,'READING SSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SSER.INP' OPEN(1,FILE='SSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3755,9 +4026,11 @@ C IF(ISO.GT.0) GOTO 870 DO M=1,MCSER(NS,NC) READ(1,*,IOSTAT=ISO)TCSER(M,NS,NC),CSERTMP + IF(MYRANK.EQ.0)THEN IF(M.EQ.1)WRITE(8,8888)NC,NS,M,TCSER(M,NS,NC),CSERTMP IF(M.EQ.MCSER(NS,NC))WRITE(8,8888)NC,NS,M, & TCSER(M,NS,NC),CSERTMP + ENDIF IF(ISO.GT.0) GOTO 870 TCSER(M,NS,NC)=TCSER(M,NS,NC)+TACSER(NS,NC) DO K=1,KC @@ -3782,7 +4055,7 @@ C ** READ IN OPEN BOUNDARY OR VOLUMETRIC SOURCE TEMPERATURE TIME C ** SERIES FROM THE FILE TSER.INP C IF(NCSER(2).GE.1)THEN - PRINT *,'READING TSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING TSER.INP' OPEN(1,FILE='TSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3800,9 +4073,11 @@ C IF(ISO.GT.0) GOTO 880 DO M=1,MCSER(NS,NC) READ(1,*,IOSTAT=ISO)TCSER(M,NS,NC),CSERTMP + IF(MYRANK.EQ.0)THEN IF(M.EQ.1)WRITE(8,8888)NC,NS,M,TCSER(M,NS,NC),CSERTMP IF(M.EQ.MCSER(NS,NC))WRITE(8,8888)NC,NS,M, & TCSER(M,NS,NC),CSERTMP + ENDIF IF(ISO.GT.0) GOTO 880 TCSER(M,NS,NC)=TCSER(M,NS,NC)+TACSER(NS,NC) DO K=1,KC @@ -3827,7 +4102,7 @@ C ** READ IN OPEN BOUNDARY OR VOLUMETRIC SOURCE DYE CONCENTRATION C ** TIME SERIES FROM THE FILE DSER.INP C IF(NCSER(3).GE.1)THEN - PRINT *,'READING DSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING DSER.INP' OPEN(1,FILE='DSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3871,7 +4146,7 @@ C IF(NSED.GT.0)THEN NFSED=MSVSED(1) IF(NCSER(NFSED).GE.1)THEN - PRINT *,'READING SDSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SDSER.INP' OPEN(1,FILE='SDSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -3948,7 +4223,7 @@ C IF(NSND.GT.0)THEN NFSND=MSVSND(1) IF(NCSER(NFSND).GE.1)THEN - PRINT *,'READING SNSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SNSER.INP' OPEN(1,FILE='SNSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -4020,7 +4295,7 @@ C C C ** CHECK SEDIMENT SERIES C - 2001 FORMAT(3I5,2F12.5) +C2001 FORMAT(3I5,2F12.5) !{GeoSR, YSSONG, TOXIC, 101030 @@ -4030,7 +4305,7 @@ C ENDDO IF (ISTRAN(5).GE.1 .and. IDTOX.GT.0) THEN - PRINT *,'READING TOXINFO.INP' + IF(MYRANK.EQ.0) PRINT *,'READING TOXINFO.INP' CALL READTOX ENDIF ! GeoSR} @@ -4042,7 +4317,7 @@ C IF(NTOX.GT.0)THEN NFTOX=MSVTOX(1) IF(NCSER(NFTOX).GE.1)THEN - PRINT *,'READING TXSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING TXSER.INP' OPEN(1,FILE='TXSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -4111,7 +4386,7 @@ C ** READ IN OPEN BOUNDARY OR VOLUMETRIC SOURCE SHELL FISH LARVAE C ** TIME SERIES FROM THE FILE SFSER.INP C IF(NCSER(4).GE.1)THEN - PRINT *,'READING SFSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SFSER.INP' OPEN(1,FILE='SFSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -4159,9 +4434,9 @@ C ELSE C ENTER QCTL(M,K,NS) VS HDIFCTL(M,NS) TABLE WITH DELH TO GIVE C IF(NQCTL.GE.1 .AND. NQCTYP1.LT.3)THEN ! GEOSR JGCHO 2011.10.28 .AND. NQCTYP1.LT.3)THEN - PRINT *,'READING QCTL.INP' + IF(MYRANK.EQ.0) PRINT *,'READING QCTL.INP' OPEN(1,FILE='QCTL.INP',STATUS='UNKNOWN') - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN OPEN(99,FILE='QCTLCK.INP',STATUS='UNKNOWN') CLOSE(99,STATUS='DELETE') OPEN(99,FILE='QCTLCK.INP',STATUS='UNKNOWN') @@ -4175,7 +4450,7 @@ C DO NS=1,NQCTLT READ(1,*, IOSTAT=ISO)ISTYP,MQCTL(NS),HCTLUA(NS),HCTLUM(NS), & HCTLDA(NS),HCTLDM(NS),RMULADJ,ADDADJ,AQCTL(NS) - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN WRITE(99,991)NS WRITE(99,992)ISTYP,MQCTL(NS),HCTLUA(NS),HCTLUM(NS), & HCTLDA(NS),HCTLDM(NS),RMULADJ,ADDADJ,AQCTL(NS) @@ -4226,7 +4501,7 @@ C ENDDO ENDDO ENDIF - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN IF(ISTYP.LE.1)THEN DO M=1,MQCTL(NS) WRITE(99,993)M,HDIFCTL(M,NS),(QCTL(M,1,K,NS),K=1,KC) @@ -4249,12 +4524,12 @@ C C { EDITED BY GEOSR 2010.5.7 C ** READ GATE CONTROL FILE : GATECTL.INP IF (NQCTL.GE.1 .AND. NQCTYP1.GE.3) THEN - PRINT *,'READING GATECTL.INP' + IF(MYRANK.EQ.0) PRINT *,'READING GATECTL.INP' CALL GATECTLREAD !!!!!!!!!!!!!!!!!!!!!!!!!! { READ GATESER.INP JGCHO 2011.10.27 - PRINT *,'READING GATESER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING GATESER.INP' OPEN(1,FILE='GATESER.INP',STATUS='UNKNOWN') - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN OPEN(99,FILE='GATESERK.OUT',STATUS='UNKNOWN') CLOSE(99,STATUS='DELETE') OPEN(99,FILE='GATESERK.OUT',STATUS='UNKNOWN') @@ -4265,7 +4540,7 @@ C ** SKIP OVER TITLE AND AND HEADER LINES ENDDO DO NS=1,NQCTLT READ(1,*, IOSTAT=ISO)ISTYP,MQCTL(NS),GCCSER(NS) - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN WRITE(99,991)NS WRITE(99,992)ISTYP,MQCTL(NS),GCCSER(NS) ENDIF @@ -4279,7 +4554,7 @@ C ** SKIP OVER TITLE AND AND HEADER LINES IF(ISO.GT.0) GOTO 920 ENDDO ! ENDIF - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN IF(ISTYP.LE.1)THEN DO M=1,MQCTL(NS) WRITE(99,995)M,GCSER(M,NS),IAG(M,NS),NGATE(M,NS) @@ -4339,7 +4614,7 @@ C CCNHTT(L)=0. ENDDO IF(NASER.GT.0)THEN - PRINT *,'READING ASER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING ASER.INP' OPEN(1,FILE='ASER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -4360,10 +4635,10 @@ C READ(1,22)TEXT USESHADE=PARSE_LOGICAL(TEXT) - PRINT *,' NUMBER OF ATMOSPHERE SERIES=',NASER - PRINT *,' COMPUTESOLRAD=',COMPUTESOLRAD - PRINT *,' DS_LONG=',DS_LONG - PRINT *,' DS_LAT=',DS_LAT + IF(MYRANK.EQ.0) PRINT *,' NUMBER OF ATMOSPHERE SERIES=',NASER + IF(MYRANK.EQ.0) PRINT *,' COMPUTESOLRAD=',COMPUTESOLRAD + IF(MYRANK.EQ.0) PRINT *,' DS_LONG=',DS_LONG + IF(MYRANK.EQ.0) PRINT *,' DS_LAT=',DS_LAT DO IS=1,3 READ(1,*) @@ -4410,7 +4685,7 @@ C ENDDO ENDIF IF(NASER.GT.1)THEN - PRINT *,'READING ATMMAP.INP' + IF(MYRANK.EQ.0) PRINT *,'READING ATMMAP.INP' OPEN(1,FILE='ATMMAP.INP',STATUS='UNKNOWN') DO IS=1,4 READ(1,*) @@ -4440,7 +4715,7 @@ C TSY(L)=0. ENDDO IF(NWSER.GT.0)THEN - PRINT *,'READING WSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING WSER.INP' OPEN(1,FILE='WSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -4463,11 +4738,11 @@ C WINTER_END=0. ENDIF - PRINT *,' NUMBER OF WIND SERIES=',NWSER - PRINT *,' ANEMOMETER HEIGHT (m)=',WINDH + IF(MYRANK.EQ.0) PRINT *,' NUMBER OF WIND SERIES=',NWSER + IF(MYRANK.EQ.0) PRINT *,' ANEMOMETER HEIGHT (m)=',WINDH IF (WINTER_START.LT.WINTER_END) THEN - PRINT *,' SURFACE WIND STRESSES TURNED OFF FROM ',WINTER_START - & ," TO ",WINTER_END + IF(MYRANK.EQ.0) PRINT *,' SURFACE WIND STRESSES TURNED OF + & F FROM ',WINTER_START," TO ",WINTER_END ENDIF DO IS=1,2 @@ -4516,7 +4791,7 @@ C ENDDO ENDIF IF(NWSER.GT.1)THEN - PRINT *,'READING WNDMAP.INP' + IF(MYRANK.EQ.0) PRINT *,'READING WNDMAP.INP' OPEN(1,FILE='WNDMAP.INP',STATUS='UNKNOWN') DO IS=1,4 READ(1,*) @@ -4534,7 +4809,7 @@ C ** READ IN SHELL FISH LARAVE BEHAVIOR DATA C ** FROM THE FILE SFBSER.INP C IF(ISTRAN(4).GE.1)THEN - PRINT *,'READING SFBSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING SFBSER.INP' OPEN(1,FILE='SFBSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -4556,7 +4831,7 @@ C C ** READ VEGETATION DATA FROM VEGE.INP AND VEGSER.INP C IF(ISVEG.GE.1)THEN - PRINT *,'READING VEGE.INP' + IF(MYRANK.EQ.0) PRINT *,'READING VEGE.INP' OPEN(1,FILE='VEGE.INP',STATUS='UNKNOWN') DO NS=1,12 READ(1,*) @@ -4584,7 +4859,7 @@ C STOP 3122 CONTINUE IF(NVEGSER.GE.1)THEN - PRINT *,'READING VEGSER.INP' + IF(MYRANK.EQ.0) PRINT *,'READING VEGSER.INP' OPEN(1,FILE='VEGSER.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -4632,142 +4907,143 @@ C goto 3000 endif - PRINT *,'READING THE extra EFDC CONTROL FILE: EFDC2.INP' - OPEN(1,FILE='EFDC2.INP',STATUS='UNKNOWN') -C + IF(MYRANK.EQ.0) PRINT *,'READING THE extra EFDC + & CONTROL FILE: EFDC2.INP' + OPEN(1,FILE='EFDC2.INP',STATUS='UNKNOWN') +C C1** READ TITLE CARD - NCARD='1' - CALL SEEK('C1') + NCARD='1' + CALL SEEK('C1') READ(1,*,IOSTAT=ISO) ISICE - WRITE(7,4002)NCARD - WRITE(7,*) ISICE - IF(ISO.GT.0) GOTO 400 - - CLOSE(1) + IF(MYRANK.EQ.0) WRITE(7,4002)NCARD + IF(MYRANK.EQ.0) WRITE(7,*) ISICE + IF(ISO.GT.0) GOTO 400 + + CLOSE(1) goto 3000 - 400 WRITE(6,4001)NCARD - WRITE(8,4001)NCARD - WRITE(7,4001)NCARD - 4001 FORMAT(/,'READ ERROR FROM FILE EFDC2.INP ON CARD ',A3/) - 4002 FORMAT(/,'INPUT ECHO NCARD = ',A/) - STOP + 400 WRITE(6,4001)NCARD + IF(MYRANK.EQ.0) WRITE(8,4001)NCARD + IF(MYRANK.EQ.0) WRITE(7,4001)NCARD + 4001 FORMAT(/,'READ ERROR FROM FILE EFDC2.INP ON CARD ',A3/) + 4002 FORMAT(/,'INPUT ECHO NCARD = ',A/) + STOP !} GEOSR, Check file EFDC2.INP read jgcho 2016.10.21 - + GOTO 3000 C C ** WRITE READ ERROR FOR OTHER INPUT FILES AND TERMINATE RUN C 800 WRITE(6,801) - WRITE(8,801) + IF(MYRANK.EQ.0) WRITE(8,801) 801 FORMAT(' READ ERROR FOR FILE CELL.INP ') STOP - 820 WRITE(6,821) - WRITE(8,821) +C 820 WRITE(6,821) + IF(MYRANK.EQ.0) WRITE(8,821) 821 FORMAT(' READ ERROR FOR FILE DEPTH.INP ') STOP 830 WRITE(6,831) - WRITE(8,831) + IF(MYRANK.EQ.0) WRITE(8,831) 831 FORMAT(' READ ERROR FOR FILE DXDY.INP ') STOP 840 WRITE(6,841) - WRITE(8,841) + IF(MYRANK.EQ.0) WRITE(8,841) 841 FORMAT(' READ ERROR FOR FILE SALT.INP ') STOP 842 WRITE(6,843) - WRITE(8,843) + IF(MYRANK.EQ.0) WRITE(8,843) 843 FORMAT(' READ ERROR FOR FILE TEMP.INP ') STOP 844 WRITE(6,845) - WRITE(8,845) + IF(MYRANK.EQ.0) WRITE(8,845) 845 FORMAT(' READ ERROR FOR FILE DYE.INP ') STOP 846 WRITE(6,847) - WRITE(8,847) + IF(MYRANK.EQ.0) WRITE(8,847) 847 FORMAT(' READ ERROR FOR FILE SFL.INP ') STOP 848 WRITE(6,849) - WRITE(8,849) + IF(MYRANK.EQ.0) WRITE(8,849) 849 FORMAT(' READ ERROR FOR FILE TOXW.INP ') STOP 852 WRITE(6,853) - WRITE(8,853) + IF(MYRANK.EQ.0) WRITE(8,853) 853 FORMAT(' READ ERROR FOR FILE TOXB.INP ') STOP 850 WRITE(6,851) - WRITE(8,851) + IF(MYRANK.EQ.0) WRITE(8,851) 851 FORMAT(' READ ERROR FOR FILE PSER.INP ') STOP 854 WRITE(6,855) - WRITE(8,855) + IF(MYRANK.EQ.0) WRITE(8,855) 855 FORMAT(' READ ERROR FOR FILE SEDW.INP ') STOP 856 WRITE(6,857) - WRITE(8,857) + IF(MYRANK.EQ.0) WRITE(8,857) 857 FORMAT(' READ ERROR FOR FILE SEDB.INP ') STOP 858 WRITE(6,859) - WRITE(8,859) + IF(MYRANK.EQ.0) WRITE(8,859) 859 FORMAT(' READ ERROR FOR FILE SNDW.INP ') STOP 862 WRITE(6,863) - WRITE(8,863) + IF(MYRANK.EQ.0) WRITE(8,863) 863 FORMAT(' READ ERROR FOR FILE SNDB.INP ') STOP 860 WRITE(6,861) - WRITE(8,861) + IF(MYRANK.EQ.0) WRITE(8,861) 861 FORMAT(' READ ERROR FOR FILE QSER.INP ') STOP 865 WRITE(6,866) - WRITE(8,866) + IF(MYRANK.EQ.0) WRITE(8,866) 866 FORMAT(' READ ERROR FOR FILE QWRS.INP ') STOP 870 WRITE(6,871) - WRITE(8,871) + IF(MYRANK.EQ.0) WRITE(8,871) 871 FORMAT(' READ ERROR FOR FILE SSER.INP ') STOP 880 WRITE(6,881) - WRITE(8,881) + IF(MYRANK.EQ.0) WRITE(8,881) 881 FORMAT(' READ ERROR FOR FILE TSER.INP ') STOP 890 WRITE(6,891) - WRITE(8,891) + IF(MYRANK.EQ.0) WRITE(8,891) 891 FORMAT(' READ ERROR FOR FILE DSER.INP ') STOP 900 WRITE(6,901) - WRITE(8,901) + IF(MYRANK.EQ.0) WRITE(8,901) 901 FORMAT(' READ ERROR FOR FILE SDSER.INP ') STOP 902 WRITE(6,903) - WRITE(8,903) + IF(MYRANK.EQ.0) WRITE(8,903) 903 FORMAT(' READ ERROR FOR FILE SNSER.INP ') STOP 904 WRITE(6,905) - WRITE(8,905) + IF(MYRANK.EQ.0) WRITE(8,905) 905 FORMAT(' READ ERROR FOR FILE TXSER.INP ') STOP 910 WRITE(6,911) - WRITE(8,911) + IF(MYRANK.EQ.0) WRITE(8,911) 911 FORMAT(' READ ERROR FOR FILE SFSER.INP ') STOP 920 WRITE(6,921) - WRITE(8,921) + IF(MYRANK.EQ.0) WRITE(8,921) 921 FORMAT('READ ERROR FOR FILE QCTL.INP OR GATESER.INP') STOP 940 WRITE(6,941) - WRITE(8,941) + IF(MYRANK.EQ.0) WRITE(8,941) 941 FORMAT(' READ ERROR FOR FILE ASER.INP ') STOP 950 WRITE(6,951) - WRITE(8,951) + IF(MYRANK.EQ.0) WRITE(8,951) 951 FORMAT(' READ ERROR FOR FILE MAPPGNS.INP ') STOP 960 WRITE(6,961) - WRITE(8,961) + IF(MYRANK.EQ.0) WRITE(8,961) 961 FORMAT(' READ ERROR FOR FILE SFBSER.INP ') STOP - 970 WRITE(6,971) - WRITE(8,971) +C 970 WRITE(6,971) + IF(MYRANK.EQ.0) WRITE(8,971) 971 FORMAT(' READ ERROR FOR FILE TIDASM.INP ') STOP 3000 CONTINUE @@ -4776,9 +5052,10 @@ C ! *** DSLLC UTIL FUNCTION PARSE_REAL(INLINE) + USE MPI, ONLY: MYRANK CHARACTER*(*) INLINE - CHARACTER*15 CVAL,TMPVAL + CHARACTER*15 CVAL ILEN=LEN_TRIM(INLINE) PARSE_REAL=0. @@ -4800,7 +5077,8 @@ C ENDIF ENDDO - 999 print *, ' error parsing real' + 999 CONTINUE + IF(MYRANK.EQ.0) print *, ' error parsing real' RETURN END @@ -4809,6 +5087,7 @@ C CHARACTER*(*) INLINE CHARACTER*12 CVAL LOGICAL PARSE_LOGICAL + PARSE_LOGICAL=.FALSE. ILEN=LEN_TRIM(INLINE) DO IC=1,ILEN @@ -4831,6 +5110,6 @@ C ENDIF ENDDO PARSE_LOGICAL=.FALSE. - 900 FORMAT(L1) - 999 RETURN +C 900 FORMAT(L1) +C 999 RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/JPEFDC.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/JPEFDC.for index 9f20be74d..02061f645 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/JPEFDC.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/JPEFDC.for @@ -9,6 +9,7 @@ C ** FOR MORE INFO EMAIL HAM@VISI.NET C CHANGE RECORD C USE GLOBAL + USE MPI PARAMETER (NJELM=2,NATDM=1) CHARACTER*11 FNJPGEO,FNJPVEL,FNJPCON,FNJPTOX,FNJPTPF,FNJPLOG, & FNNRFLD,FNNRFLB @@ -79,6 +80,18 @@ C REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::UJPAVG REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::VJPAVG REAL,SAVE,ALLOCATABLE,DIMENSION(:,:)::WJPAVG + REAL WJ0,VJ0,UJ0 + REAL TMPVAL + REAL DYEJET + REAL SFLJET + REAL QSERTAVG + WJ0=0.0 + VJ0=0.0 + UJ0=0.0 + TMPVAL=0.0 + SFLJET=0.0 + DYEJET=0.0 + QSERTAVG=0.0 IF(.NOT.ALLOCATED(DRHONS))THEN PRINT *,'JET/PLUME COMPUTATIONS STARTED. NQJPIJ=',NQJPIJ @@ -256,9 +269,11 @@ C FNNUM(23)= '23' FNNUM(24)= '24' FNNUM(25)= '25' + IF(MYRANK.EQ.0)THEN OPEN(88,FILE='JPBUG.DIA',POSITION='APPEND') CLOSE(88,STATUS='DELETE') ENDIF + ENDIF C C ** LOOP OVER ALL JET/PLUME LOCATIONS C @@ -269,7 +284,7 @@ C VJPAVG(K,NJP)=0.0 WJPAVG(K,NJP)=0.0 ENDDO - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN FNJPLOG='JPLOG' // FNNUM(NJP) // '.OUT' IF(N.EQ.1) OPEN(10,FILE=FNJPLOG,STATUS='UNKNOWN') IF(N.EQ.1) CLOSE(10,STATUS='DELETE') @@ -480,7 +495,7 @@ C & +U(L,K)*(BELV(L)-BELV(L-1))*DXIU(L) & +V(LN,K)*(BELV(LN)-BELV(L))*DYIV(LN) & +V(L,K)*(BELV(L)-BELV(LS))*DYIV(L)) - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN OPEN(88,FILE='JPBUG.DIA',POSITION='APPEND') WRITE(88,889)NZ,K,L,LN,LS,SALAD(NZ,1),TEMAD(NZ,1), & TOXAD(NZ,1,1) @@ -512,7 +527,7 @@ C C C ** OPEN OUTPUT FILES C - IF(LOUTJET)THEN + IF(LOUTJET.AND.MYRANK.EQ.0)THEN FNJPGEO='JPGEO' // FNNUM(NJP) // '.OUT' FNJPVEL='JPVEL' // FNNUM(NJP) // '.OUT' FNJPCON='JPCON' // FNNUM(NJP) // '.OUT' @@ -556,7 +571,7 @@ C ENDIF ENDIF - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN IF(N.EQ.1) THEN OPEN(11,FILE='JPMOMENT.OUT') CLOSE(11,STATUS='DELETE') @@ -1009,7 +1024,7 @@ C IF(ISENT(NJP).EQ.0) DRMAJ=MAX(DRMAJSA,DRMAJFA) IF(DRMAJSA.GT.DRMAJFA) ISHEAR=1 IF(DRMAJFA.GT.DRMAJSA) IFORCE=1 - 110 FORMAT(2I6,5E14.5) +C 110 FORMAT(2I6,5E14.5) C C ++ ADVANCE MASS C @@ -1210,11 +1225,13 @@ C IF(NI.GT.NIMAX)THEN KFLAG=1 + IF(MYRANK.EQ.0)THEN IF(DEBUG)WRITE(10,620)NJP,NJE,NI,ITMP,DRMAJSA,DRMAJSO, & DRMAJFA,DRMAJFO WRITE(6,601)NJE,NI IF(DEBUG)WRITE(10,601)NJE,NI WRITE(8,601)NJE,NI + ENDIF GOTO 2000 ENDIF C @@ -1223,10 +1240,12 @@ C IF(ISTOP.EQ.1)THEN ZJGTOP=ZJG(NE) IF(ZJGTOP.GT.ZSUR)THEN + IF(MYRANK.EQ.0)THEN WRITE(6,6050)NJP,NJE,NI,ZJGTOP,ZSUR IF(DEBUG)WRITE(10,605)NJP,NJE,NI,ZJGTOP,ZSUR IF(DEBUG)WRITE(10,899)NJP,TIME,(QJPENT(K,NJP),K=1,KC) WRITE(8,605)NJP,NJE,NI,ZJGTOP,ZSUR + ENDIF GOTO 2000 ENDIF ENDIF @@ -1236,10 +1255,12 @@ C IF(ISTOP.EQ.1)THEN ZJGBOT=ZJG(NE) IF(ZJGBOT.LT.ZBOT)THEN + IF(MYRANK.EQ.0)THEN WRITE(6,6060)NJP,NJE,NI,ZJGBOT,ZBOT IF(DEBUG)WRITE(10,606)NJP,NJE,NI,ZJGBOT,ZBOT IF(DEBUG)WRITE(10,899)NJP,TIME,(QJPENT(K,NJP),K=1,KC) WRITE(8,606)NJP,NJE,NI,ZJGBOT,ZBOT + ENDIF GOTO 2000 ENDIF ENDIF @@ -1249,10 +1270,12 @@ C IF(ISTOP.EQ.2)THEN ZJGTOP=ZJG(NE)+RADJ(NE)*COS(0.0175*PHJ(NE)) IF(ZJGTOP.GT.ZSUR)THEN + IF(MYRANK.EQ.0)THEN WRITE(6,6020)NJP,NJE,NI,ZJGTOP,ZSUR IF(DEBUG)WRITE(10,602)NJP,NJE,NI,ZJGTOP,ZSUR IF(DEBUG)WRITE(10,899)NJP,TIME,(QJPENT(K,NJP),K=1,KC) WRITE(8,602)NJP,NJE,NI,ZJGTOP,ZSUR + ENDIF GOTO 2000 ENDIF ENDIF @@ -1262,10 +1285,12 @@ C IF(ISTOP.EQ.2)THEN ZJGBOT=ZJG(NE)-RADJ(NE)*COS(0.0175*PHJ(NE)) IF(ZJGBOT.LT.ZBOT)THEN + IF(MYRANK.EQ.0)THEN WRITE(6,6030)NJP,NJE,NI,ZJGBOT,ZBOT IF(DEBUG)WRITE(10,603)NJP,NJE,NI,ZJGBOT,ZBOT IF(DEBUG)WRITE(10,899)NJP,TIME,(QJPENT(K,NJP),K=1,KC) WRITE(8,603)NJP,NJE,NI,ZJGBOT,ZBOT + ENDIF GOTO 2000 ENDIF ENDIF @@ -1277,10 +1302,12 @@ C IF(RHOJ(NE).GE.RHOJ(NM))THEN DRHOT=(RHOA-RHOJ(NE))/RHOA IF(DRHOT.LT.0.)THEN + IF(MYRANK.EQ.0)THEN WRITE(6,6040)NJP,NJE,NI,ZJG(NE) IF(DEBUG)WRITE(10,604)NJP,NJE,NI,ZJG(NE) IF(DEBUG)WRITE(10,899)NJP,TIME,(QJPENT(K,NJP),K=1,KC) WRITE(8,604)NJP,NJE,NI,ZJG(NE) + ENDIF GOTO 2000 ENDIF ENDIF @@ -1290,10 +1317,12 @@ C IF(RHOJ(NE).LT.RHOJ(NM))THEN DRHOT=(RHOA-RHOJ(NE))/RHOA IF(DRHOT.GT.0.)THEN + IF(MYRANK.EQ.0)THEN WRITE(6,6040)NJP,NJE,NI,ZJG(NE) IF(DEBUG)WRITE(10,604)NJP,NJE,NI,ZJG(NE) IF(DEBUG)WRITE(10,899)NJP,TIME,(QJPENT(K,NJP),K=1,KC) WRITE(8,604)NJP,NJE,NI,ZJG(NE) + ENDIF GOTO 2000 ENDIF ENDIF @@ -1477,7 +1506,7 @@ C DO K=1,KC QJPENTT(NJP)=QJPENTT(NJP)+QJPENT(K,NJP) ENDDO - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN WRITE(8,898)NJP,TIME,(QJPENT(K,NJP),K=1,KC),QJPENTT(NJP) WRITE(10,898)NJP,TIME,(QJPENT(K,NJP),K=1,KC),QJPENTT(NJP) ENDIF @@ -1577,7 +1606,8 @@ C C C ** WRITE OUT SAVED RESULTS IN COMPACT ASCII FORMAT C - IF(LOUTJET.AND.(IOUTJP(NJP).EQ.2.OR.IOUTJP(NJP).EQ.3))THEN + IF(LOUTJET.AND.(IOUTJP(NJP).EQ.2.OR.IOUTJP(NJP).EQ.3) + & .AND.MYRANK.EQ.0)THEN IF(N.EQ.1) OPEN(1,FILE=FNNRFLD,STATUS='UNKNOWN') IF(N.EQ.1) CLOSE(1,STATUS='DELETE') OPEN(1,FILE=FNNRFLD,STATUS='UNKNOWN',POSITION='APPEND') @@ -1620,7 +1650,7 @@ C C C ** WRITE OUT SAVED RESULTS IN BINARY FORMAT C - IF(IOUTJP(NJP).EQ.4)THEN + IF(IOUTJP(NJP).EQ.4.AND.MYRANK.EQ.0)THEN IF(N.EQ.1) OPEN(1,FILE=FNNRFLB,FORM='UNFORMATTED') IF(N.EQ.1) CLOSE(1,STATUS='DELETE') OPEN(1,FILE=FNNRFLB,POSITION='APPEND',FORM='UNFORMATTED') @@ -1669,7 +1699,8 @@ C 9000 CONTINUE KEFFJP(NJP)=KQJP(NJP) 9001 CONTINUE - WRITE(8 ,899)NJP,TIME,(QJPENT(K,NJP),K=1,KC) + IF(MYRANK.EQ.0) WRITE(8 ,899)NJP,TIME,(QJPENT(K,NJP),K=1,KC) + IF(MYRANK.EQ.0)THEN IF(DEBUG)WRITE(10,899)NJP,TIME,(QJPENT(K,NJP),K=1,KC) IF(DEBUG)THEN WRITE(10,135)NJP,TIME,KFLAG,KEFFJP(NJP),KQJP(NJP), @@ -1684,6 +1715,7 @@ C & QJTOT C ENDIF CLOSE(10) ENDIF + ENDIF C C ** CALCULATION MOMENT INTERFACE QUANTITIES C @@ -1716,7 +1748,7 @@ C 1111 FORMAT(I5,10E14.5) 899 FORMAT(' JPENT ',I5,F12.6,12E12.4) 898 FORMAT(' FINAL JPENT ',I5,F12.6,12E12.4) - 100 FORMAT(120X) +C 100 FORMAT(120X) 101 FORMAT(2I6,15E12.4) 104 FORMAT(15E12.4) 111 FORMAT(' NJ NE TIME XJ YJ ', @@ -1732,7 +1764,7 @@ C 134 FORMAT(' BEGIN JET/PLUME NJP,TIME = ',I6,F12.5) 135 FORMAT(' END JET/PLUME NJP,TIME,KFLAG,KEFFJP,KQJP,QVJET,QVJTOT', & ' = ',I6,F13.5,3I4,2E12.4) - 600 FORMAT(' ELEMENT, # INTERATIONS = ',2I6) +C 600 FORMAT(' ELEMENT, # INTERATIONS = ',2I6) 601 FORMAT(' MAXIMUM ITERATIONS EXCEEDED NE,NI = ',2I6,' !!!!!!!!') 602 FORMAT(' JET/PLUME BNDRY PEN SURF NJ,NE,NI,Z,ZS = ',3I6,2F10.2) 6020 FORMAT(' JP BDRY PEN SURF NJ,NE,NI,Z,ZS= ',3I5,2F8.2) @@ -1744,7 +1776,7 @@ C 6050 FORMAT(' JP CTLN PEN SURF NJ,NE,NI,Z,ZS= ',3I5,2F8.2) 606 FORMAT(' JET/PLUME CTRLN PEN BOTT NJ,NE,NI,Z,ZB = ',3I6,2F10.2) 6060 FORMAT(' JP CTLN PEN BOTT NJ,NE,NI,Z,ZS= ',3I5,2F8.2) - 888 FORMAT(A80,/) +C 888 FORMAT(A80,/) 620 FORMAT('NJ,NE,NI,IT,DS,DSO,DF,DFO = ',4I6,6E13.4) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/LSQHARM.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/LSQHARM.for index 6e87d2c53..31ac5ac03 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/LSQHARM.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/LSQHARM.for @@ -4,6 +4,7 @@ C CHANGE RECORD C ** SUBROUTINE LSQHARM PERFORMS A LEAST SQUARES HARMONIC ANALYSIS C USE GLOBAL + USE MPI CHARACTER*80 TITLE,TITNT,TITRT REAL,SAVE,ALLOCATABLE,DIMENSION(:)::AMATMP @@ -179,9 +180,11 @@ C C *** COMPLETE ANALYSIS C 200 CONTINUE + IF(MYRANK.EQ.0)THEN OPEN(97,FILE='LSHA.OUT',STATUS='UNKNOWN') CLOSE(97,STATUS='DELETE') OPEN(97,FILE='LSHA.OUT',STATUS='UNKNOWN') + ENDIF IF(ISLSTR.EQ.1) GOTO 500 C C *** COMPUTE SOLUTION WITH NO TREND REMOVAL @@ -209,12 +212,14 @@ C C *** PERFORM SVD ON GLSHA C CALL SVDCMP (GLSHA,MG,MG,MGM,MGM,WLSHA,VVLSHA) + IF(MYRANK.EQ.0)THEN WRITE(97,10)TITNT WRITE(97,11) DO M=1,MG WRITE(97,12)WLSHA(M) ENDDO WRITE(97,13) + ENDIF C C *** SOLVE BY BACK SUBSTITUTION AND OUTPUT RESULTS C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/LUDCMP.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/LUDCMP.for index 82ceafb4c..e01990819 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/LUDCMP.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/LUDCMP.for @@ -5,6 +5,8 @@ C PARAMETER (TINY=1.0E-20) DIMENSION A(NP,NP),INDX(N) REAL,ALLOCATABLE,DIMENSION(:)::VV + INTEGER IMAX + IMAX=0 ALLOCATE(VV(N)) C D=1. @@ -13,7 +15,11 @@ C DO 11 J=1,N IF(ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J)) 11 CONTINUE - IF(AAMAX.EQ.0.) PAUSE 'SINGULAR MATRIX.' + IF(AAMAX.EQ.0.) THEN + PRINT *, 'SINGULAR MATRIX.' + PRINT *, "Application suspended. Hit ENTER to continue" + READ(*,*) + ENDIF VV(I)=1./AAMAX 12 CONTINUE DO 19 J=1,N diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/MPI.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/MPI.f90 new file mode 100644 index 000000000..e52986f71 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/MPI.f90 @@ -0,0 +1,717 @@ + MODULE MPI + + USE GLOBAL + USE OMP_LIB + INCLUDE 'mpif.h' + + REAL*8 :: STIME,TTIME,MPI_WTIMES(4000) + REAL*8 :: S1TIME,S2TIME,S3TIME,S4TIME,S5TIME + CHARACTER*30 :: MPI_HOSTSPOTS(4000),WT_CHAR + CHARACTER*3 :: WT_NUM + PARAMETER (MAXNTH=64) + INTEGER RECVCOUNTS(0:1000),DISPLS(0:1000) + INTEGER ITHE,LOMPS,LOMPE,LOMPS1,LOMPE1,NCOLLECT + INTEGER IERR,MYRANK,NPROCS,OMP_OPT + INTEGER IOMPS(MAXNTH),IOMPE(MAXNTH),IOMPS1(MAXNTH),IOMPE1(MAXNTH) + INTEGER NTH,OMPNUM,LSTART,LEND + INTEGER INEWTYPE,NEWTYPE(1000),INEWTYPE1(0:1000),INEWTYPE2(0:1000),INEWTYPE3(0:1000) + INTEGER NDRYCELL,OMPTHPUV,OMPTHCONG + INTEGER IREQ(1000),IREQ1,IREQ2,NUMBER, LCHUNK + INTEGER STATUS1(MPI_STATUS_SIZE),STATUS2(MPI_STATUS_SIZE) + INTEGER LMPI1,LMPI2,LMPILA,LMPILC + INTEGER WT_VAL,WT_COUNT,WT_RATIO + INTEGER,ALLOCATABLE :: MPI_IMASKDRY(:) + CHARACTER MPI_DEBUG_C + INTEGER MPI_DEBUG + INTEGER MPI_I4 + REAL MPI_R4 + REAL*8 MPI_R8 + LOGICAL MPI_LG + LOGICAL IS_PSER(10000),IS_CSER(10000,1000),IS_QSER(10000),IS_QCTL(10000) + + CONTAINS + +!########################################################################################################### + + SUBROUTINE MPI_INITIALIZE + + USE OMP_LIB + INCLUDE 'mpif.h' + MYRANK=0 + CALL MPI_INIT(IERR) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,NPROCS,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,MYRANK,IERR) + + IF (NPROCS > 1) THEN + PRINT*, 'EFDC library does not support running with multiple MPI processes' + STOP + END IF + +!$OMP PARALLEL + OMPNUM=OMP_GET_MAX_THREADS() + !CALL OMP_SET_NUM_THREADS(OMPNUM) +!$OMP END PARALLEL + + CALL GETARG(2,MPI_DEBUG_C) + READ(MPI_DEBUG_C,'(I1.1)') MPI_DEBUG + IF(MYRANK.EQ.0) PRINT*, 'MPI_DEBUG = ', MPI_DEBUG + + ENDSUBROUTINE MPI_INITIALIZE + +!########################################################################################################### + + SUBROUTINE MPI_DECOMPOSITION + + USE OMP_LIB + INCLUDE 'mpif.h' + + IF(MYRANK==0) WRITE(*,*) '#########################' + IF(MYRANK==0) WRITE(*,*) 'MPI NODDS =',NPROCS + IF(MYRANK==0) WRITE(*,*) 'OMP THREADS =',OMPNUM + IF(MYRANK==0) WRITE(*,*) '#########################' + + NTH = OMPNUM * NPROCS + LCHUNK=NINT(FLOAT(LC-1)/FLOAT(NTH)) + + DO N=1,NTH + IOMPS(N)=(N-1)*LCHUNK+2 + IOMPE(N)=IOMPS(N)+LCHUNK -1 + ENDDO + IOMPE(NTH)=LC + IOMPS1=IOMPS ; IOMPE1=IOMPE + IOMPS1(1)=1 ; IOMPE1(NTH)=LA + + LMPI1 = IOMPS1(OMPNUM*MYRANK+1) + LMPI2 = IOMPS(OMPNUM*MYRANK+1) + LMPILC = IOMPE(OMPNUM*MYRANK+OMPNUM) + LMPILA = IOMPE1(OMPNUM*MYRANK+OMPNUM) + + IF(MYRANK==0) THEN + PRINT*, '####################################################' + DO N=0,NPROCS-1 + PRINT*, 'RANK NUMBER : ', N , IOMPS(OMPNUM*N+1), IOMPE(OMPNUM*N+OMPNUM) + ENDDO + PRINT*, '####################################################' + + PRINT*, '####################################################' + DO N=0,NPROCS-1 + PRINT*, 'RANK NUMBER : ', N , IOMPS1(OMPNUM*N+1), IOMPE1(OMPNUM*N+OMPNUM) + ENDDO + PRINT*, '####################################################' + ENDIF + + DO N=0,NPROCS-1 + RECVCOUNTS(N)=IOMPE(OMPNUM*(N+1))-IOMPS(OMPNUM*N+1)+1 + ENDDO + + DISPLS(0)=2 + DO N=1,NPROCS-1 + DISPLS(N)=DISPLS(N-1)+RECVCOUNTS(N-1) + ENDDO + + CALL MPI_TYPE_VECTOR(KCM,IC,LCM,MPI_REAL,INEWTYPE,IERR) + CALL MPI_TYPE_COMMIT(INEWTYPE,IERR) + + DO N=0,NPROCS-1 + CALL MPI_TYPE_VECTOR(KCM,RECVCOUNTS(N),LCM,MPI_REAL,INEWTYPE1(N),IERR) + CALL MPI_TYPE_COMMIT(INEWTYPE1(N),IERR) + ENDDO + + DO N=0,NPROCS-1 + CALL MPI_TYPE_VECTOR(KBM,RECVCOUNTS(N),LCM,MPI_REAL,INEWTYPE2(N),IERR) + CALL MPI_TYPE_COMMIT(INEWTYPE2(N),IERR) + ENDDO + + DO N=0,NPROCS-1 + CALL MPI_TYPE_VECTOR(KCM+1,RECVCOUNTS(N),LCM,MPI_REAL,INEWTYPE3(N),IERR) + CALL MPI_TYPE_COMMIT(INEWTYPE3(N),IERR) + ENDDO + + ENDSUBROUTINE MPI_DECOMPOSITION + +!########################################################################################################### + + SUBROUTINE BROADCAST_BOUNDARY(ARRAY_1D,NUMBER) + + INCLUDE 'mpif.h' + REAL ARRAY_1D(LCM) + + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,NPROCS,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,MYRANK,IERR) + + IF(NPROCS.GE.2)THEN + DO NP=1,NPROCS-1,2 + IF(MYRANK==NP-1)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_REAL,NP,87,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_REAL,NP,82,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ELSEIF(MYRANK==NP)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_REAL,NP-1,82,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_REAL,NP-1,87,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + ENDDO + ENDIF + IF(NPROCS.GE.3)THEN + DO NP=2,NPROCS-1,2 + IF(MYRANK==NP-1)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_REAL,NP,87,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_REAL,NP,82,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ELSEIF(MYRANK==NP)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_REAL,NP-1,82,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_REAL,NP-1,87,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + ENDDO + ENDIF + + END SUBROUTINE + +!########################################################################################################### + + SUBROUTINE BROADCAST_BOUNDARY_LBM(ARRAY_1D,NUMBER) + + INCLUDE 'mpif.h' + REAL ARRAY_1D(0:LCM) + + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,NPROCS,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,MYRANK,IERR) + + IF(NPROCS.GE.2)THEN + DO NP=1,NPROCS-1,2 + IF(MYRANK==NP-1)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_REAL,NP,87,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_REAL,NP,82,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ELSEIF(MYRANK==NP)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_REAL,NP-1,82,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_REAL,NP-1,87,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + ENDDO + ENDIF + IF(NPROCS.GE.3)THEN + DO NP=2,NPROCS-1,2 + IF(MYRANK==NP-1)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_REAL,NP,87,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_REAL,NP,82,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ELSEIF(MYRANK==NP)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_REAL,NP-1,82,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_REAL,NP-1,87,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + ENDDO + ENDIF + + END SUBROUTINE + +!########################################################################################################### + + SUBROUTINE BROADCAST_BOUNDARY_R8(ARRAY_1D,NUMBER) + + INCLUDE 'mpif.h' + REAL*8 ARRAY_1D(LCM) + + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,NPROCS,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,MYRANK,IERR) + + IF(NPROCS.GE.2)THEN + DO NP=1,NPROCS-1,2 + IF(MYRANK==NP-1)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_DOUBLE,NP,87,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_DOUBLE,NP,82,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ELSEIF(MYRANK==NP)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_DOUBLE,NP-1,82,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_DOUBLE,NP-1,87,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + ENDDO + ENDIF + IF(NPROCS.GE.3)THEN + DO NP=2,NPROCS-1,2 + IF(MYRANK==NP-1)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_DOUBLE,NP,87,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_DOUBLE,NP,82,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ELSEIF(MYRANK==NP)THEN + CALL MPI_ISEND( ARRAY_1D(IOMPS(OMPNUM*NP+1)) ,NUMBER,MPI_DOUBLE,NP-1,82,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_1D(IOMPS(OMPNUM*NP+1)-NUMBER),NUMBER,MPI_DOUBLE,NP-1,87,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + ENDDO + ENDIF + + END SUBROUTINE + +!########################################################################################################### + + SUBROUTINE BROADCAST_BOUNDARY_ARRAY(ARRAY_2D,NUMBER) + + INCLUDE 'mpif.h' + REAL ARRAY_2D(LCM,KCM) + + IF(NPROCS.GT.1)THEN + DO NP=1,NPROCS-1 + IF(MYRANK==NP-1)THEN + CALL MPI_ISEND( ARRAY_2D(IOMPS(OMPNUM*NP+1)-NUMBER,1),1,INEWTYPE,NP,87,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_2D(IOMPS(OMPNUM*NP+1),1) ,1,INEWTYPE,NP,82,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ELSEIF(MYRANK==NP)THEN + CALL MPI_ISEND( ARRAY_2D(IOMPS(OMPNUM*NP+1),1) ,1,INEWTYPE,NP-1,82,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_2D(IOMPS(OMPNUM*NP+1)-NUMBER,1),1,INEWTYPE,NP-1,87,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + ENDDO + ENDIF + END SUBROUTINE + +!########################################################################################################### + + SUBROUTINE BROADCAST_BOUNDARY_ARRAY_ZEROKCM(ARRAY_2D,NUMBER) + + INCLUDE 'mpif.h' + REAL ARRAY_2D(LCM,0:KCM) + + IF(NPROCS.GT.1)THEN + DO NP=1,NPROCS-1 + IF(MYRANK==NP-1)THEN + CALL MPI_ISEND( ARRAY_2D(IOMPS(OMPNUM*NP+1)-NUMBER,0),1,INEWTYPE3,NP,87,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_2D(IOMPS(OMPNUM*NP+1),0) ,1,INEWTYPE3,NP,82,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ELSEIF(MYRANK==NP)THEN + CALL MPI_ISEND( ARRAY_2D(IOMPS(OMPNUM*NP+1),0) ,1,INEWTYPE3,NP-1,82,MPI_COMM_WORLD,IREQ1,IERR) + CALL MPI_IRECV( ARRAY_2D(IOMPS(OMPNUM*NP+1)-NUMBER,0),1,INEWTYPE3,NP-1,87,MPI_COMM_WORLD,IREQ2,IERR) + CALL MPI_WAIT(IREQ1,STATUS1,IERR) + CALL MPI_WAIT(IREQ2,STATUS2,IERR) + ENDIF + ENDDO + ENDIF + END SUBROUTINE + +!########################################################################################################### + + SUBROUTINE COLLECT_IN_ZERO(ARRAY_1D) + + INCLUDE 'mpif.h' + REAL ARRAY_1D(LCM) + + IF(NPROCS.GE.2)THEN + DO NP=1,NPROCS-1 + IF(MYRANK==NP) THEN + CALL MPI_ISEND( ARRAY_1D(DISPLS(NP)),RECVCOUNTS(NP),MPI_REAL,0,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ELSEIF(MYRANK==0) THEN + CALL MPI_IRECV( ARRAY_1D(DISPLS(NP)),RECVCOUNTS(NP),MPI_REAL,NP,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ENDIF + ENDDO + ENDIF + END SUBROUTINE + +!########################################################################################################### + + SUBROUTINE COLLECT_IN_ZERO_R8(ARRAY_1D) + + INCLUDE 'mpif.h' + REAL*8 ARRAY_1D(LCM) + + IF(NPROCS.GE.2)THEN + DO NP=1,NPROCS-1 + IF(MYRANK==NP) THEN + CALL MPI_ISEND( ARRAY_1D(DISPLS(NP)),RECVCOUNTS(NP),MPI_DOUBLE,0,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ELSEIF(MYRANK==0) THEN + CALL MPI_IRECV( ARRAY_1D(DISPLS(NP)),RECVCOUNTS(NP),MPI_DOUBLE,NP,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ENDIF + ENDDO + ENDIF + END SUBROUTINE + + +!########################################################################################################### + + SUBROUTINE COLLECT_IN_ZERO_INT(ARRAY_1D) + + INCLUDE 'mpif.h' + INTEGER ARRAY_1D(LCM) + + IF(NPROCS.GE.2)THEN + DO NP=1,NPROCS-1 + IF(MYRANK==NP) THEN + CALL MPI_ISEND( ARRAY_1D(DISPLS(NP)),RECVCOUNTS(NP),MPI_INTEGER,0,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ELSEIF(MYRANK==0) THEN + CALL MPI_IRECV( ARRAY_1D(DISPLS(NP)),RECVCOUNTS(NP),MPI_INTEGER,NP,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ENDIF + ENDDO + ENDIF + END SUBROUTINE + +!########################################################################################################### + + SUBROUTINE COLLECT_IN_ZERO_LBM(ARRAY_1D) + + INCLUDE 'mpif.h' + REAL ARRAY_1D(0:LCM) + + IF(NPROCS.GE.2)THEN + DO NP=1,NPROCS-1 + IF(MYRANK==NP) THEN + CALL MPI_ISEND( ARRAY_1D(DISPLS(NP)),RECVCOUNTS(NP),MPI_REAL,0,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ELSEIF(MYRANK==0) THEN + CALL MPI_IRECV( ARRAY_1D(DISPLS(NP)),RECVCOUNTS(NP),MPI_REAL,NP,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ENDIF + ENDDO + ENDIF + END SUBROUTINE + +!########################################################################################################### + + SUBROUTINE COLLECT_IN_ZERO_ARRAY(ARRAY_2D) + + INCLUDE 'mpif.h' + REAL ARRAY_2D(LCM,KCM) + + IF(NPROCS.GE.2)THEN + DO NP=1,NPROCS-1 + IF(MYRANK==NP) THEN + CALL MPI_ISEND( ARRAY_2D(DISPLS(NP),1),1,INEWTYPE1(NP),0,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ELSEIF(MYRANK==0) THEN + CALL MPI_IRECV( ARRAY_2D(DISPLS(NP),1),1,INEWTYPE1(NP),NP,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ENDIF + ENDDO + ENDIF + END SUBROUTINE + +!########################################################################################################### + + SUBROUTINE COLLECT_IN_ZERO_ARRAY_KBM(ARRAY_2D) + + INCLUDE 'mpif.h' + REAL ARRAY_2D(LCM,KBM) + + IF(NPROCS.GE.2)THEN + DO NP=1,NPROCS-1 + IF(MYRANK==NP) THEN + CALL MPI_ISEND( ARRAY_2D(DISPLS(NP),1),1,INEWTYPE2(NP),0,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ELSEIF(MYRANK==0) THEN + CALL MPI_IRECV( ARRAY_2D(DISPLS(NP),1),1,INEWTYPE2(NP),NP,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ENDIF + ENDDO + ENDIF + END SUBROUTINE + +!########################################################################################################### + + SUBROUTINE COLLECT_IN_ZERO_ARRAY_0KCM(ARRAY_2D) + + INCLUDE 'mpif.h' + REAL ARRAY_2D(LCM,0:KCM) + + IF(NPROCS.GE.2)THEN + DO NP=1,NPROCS-1 + IF(MYRANK==NP) THEN + CALL MPI_ISEND( ARRAY_2D(DISPLS(NP),0),1,INEWTYPE2(NP),0,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ELSEIF(MYRANK==0) THEN + CALL MPI_IRECV( ARRAY_2D(DISPLS(NP),0),1,INEWTYPE2(NP),NP,87,MPI_COMM_WORLD,IREQ(NP),IERR) + CALL MPI_WAIT(IREQ(NP),STATUS1,IERR) + ENDIF + ENDDO + ENDIF + END SUBROUTINE + +!########################################################################################################### + + REAL*8 FUNCTION MPI_TIC() + + INCLUDE 'mpif.h' + + MPI_TIC=MPI_WTIME() + + END FUNCTION + +!########################################################################################################### + + REAL*8 FUNCTION MPI_TOC(TMPTIME) + + INCLUDE 'mpif.h' + REAL*8 TMPTIME + + MPI_TOC=MPI_WTIME()-TMPTIME + + END FUNCTION + +!########################################################################################################### + + SUBROUTINE MPI_WTIME_PRINT(WT_CHAR,WT_RATIO,WT_VAL,WT_COUNT) + + CHARACTER(LEN=*) WT_CHAR + INTEGER WT_VAL, WT_COUNT, WT_RATIO + + PRINT*,TRIM(WT_CHAR) + DO II=1,WT_COUNT + WRITE(WT_NUM,'(I3.3)') II + MPI_HOSTSPOTS(WT_VAL+ii)=' '//TRIM(WT_CHAR)//'_LOOP_'//WT_NUM + IF(REAL(MPI_WTIMES(WT_VAL+II)).GE.0.002)THEN + WRITE(*,'(I5,A20,F10.3)') WT_VAL+II, MPI_HOSTSPOTS(WT_VAL+II), & + WT_RATIO*REAL(MPI_WTIMES(WT_VAL+II)) + ENDIF + ENDDO + WRITE(*,'(A20,F10.3)') ' '//TRIM(WT_CHAR)//'_TOTAL', & + WT_RATIO*REAL(SUM(MPI_WTIMES((WT_VAL+1):(WT_VAL+WT_COUNT)))) + + END SUBROUTINE + +!########################################################################################################### + + LOGICAL FUNCTION ISDOMAIN(LDOMAIN) + + INTEGER LDOMAIN + + IF(LDOMAIN.GE.LMPI1.AND.LDOMAIN.LE.LMPILA)THEN + ISDOMAIN=.TRUE. + ELSE + ISDOMAIN=.FALSE. + ENDIF + + END FUNCTION + +!########################################################################################################### + + SUBROUTINE ISINPUTS(IS_PSER,IS_CSER,IS_QSER,IS_QCTL) + + LOGICAL IS_PSER(10000),IS_CSER(10000,1000),IS_QSER(10000),IS_QCTL(10000) + + IS_PSER=.TRUE. !.FALSE. + IS_CSER=.TRUE. !.FALSE. + IS_QSER=.TRUE. !.FALSE. + IS_QCTL=.TRUE. !.FALSE. + + IF(.FALSE.)THEN ! NOT USED + IF(NPSER.GT.0)THEN +!! CARD C18 + DO II=1,NPBS + IF(ISDOMAIN(LIJ(IPBS(II),JPBS(II)))) IS_PSER(NPSERS(II))=.TRUE. + ENDDO +!! CARD C19 + DO II=1,NPBW + IF(ISDOMAIN(LIJ(IPBW(II),JPBW(II)))) IS_PSER(NPSERW(II))=.TRUE. + ENDDO +!! CARD C20 + DO II=1,NPBE + IF(ISDOMAIN(LIJ(IPBE(II),JPBE(II)))) IS_PSER(NPSERE(II))=.TRUE. + ENDDO +!! CARD C21 + DO II=1,NPBN + IF(ISDOMAIN(LIJ(IPBN(II),JPBN(II)))) IS_PSER(NPSERN(II))=.TRUE. + ENDDO + ENDIF + +!! CARD C24 + IF(NQSIJ.GT.0)THEN + DO II=1,NQSIJ + IF(ISDOMAIN(LIJ(IQS(II),JQS(II))))THEN + IS_QSER(NQSERQ(II))=.TRUE. + DO JJ=1,4 + IS_CSER(NCSERQ(II,JJ),JJ)=.TRUE. + ENDDO + DO N=1,NTOX + JJ=MSVTOX(N) + IS_CSER(NCSERQ(II,JJ),JJ)=.TRUE. + ENDDO + DO N=1,NSED + JJ=MSVSED(N) + IS_CSER(NCSERQ(II,JJ),JJ)=.TRUE. + ENDDO + DO N=1,NSND + JJ=MSVSND(N) + IS_CSER(NCSERQ(II,JJ),JJ)=.TRUE. + ENDDO + DO NW=1,NWQV + JJ=4+NTOX+NSED+NSND+NW + IS_CSER(:,JJ)=.TRUE. + ENDDO + DO NSP=1,NXSP + JJ=4+NTOX+NSED+NSND+NWQV+NSP + IS_CSER(:,JJ)=.TRUE. + ENDDO + ENDIF + ENDDO + ENDIF + +!! CARD C32 + IF(NQCTL.GT.0)THEN + DO II=1,NQCTL + IF(ISDOMAIN(LIJ(IQCTLU(II),JQCTLU(II))))THEN + IS_QCTL(NQCTLQ(II))=.TRUE. + ENDIF + ENDDO + ENDIF + +!! CARD C47 + IF(NCBS.GT.0)THEN + DO II=1,NCBS + IF(ISDOMAIN(LIJ(ICBS(II),JCBS(II))))THEN + DO JJ=1,4 + IS_CSER(NCSERS(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NTOX + JJ=MSVTOX(N) + IS_CSER(NCSERS(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NSED + JJ=MSVSED(N) + IS_CSER(NCSERS(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NSND + JJ=MSVSND(N) + IS_CSER(NCSERS(II,2),JJ)=.TRUE. + ENDDO + DO NW=1,NWQV + JJ=4+NTOX+NSED+NSND+NW + IS_CSER(NCSERS(II,JJ),JJ)=.TRUE. + ENDDO + DO NSP=1,NXSP + JJ=4+NTOX+NSED+NSND+NWQV+NSP + IS_CSER(NCSERS(II,JJ),JJ)=.TRUE. + ENDDO + ENDIF + ENDDO + ENDIF + +!! CARD C52 + IF(NCBW.GT.0)THEN + DO II=1,NCBW + IF(ISDOMAIN(LIJ(ICBW(II),JCBW(II))))THEN + DO JJ=1,4 + IS_CSER(NCSERW(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NTOX + JJ=MSVTOX(N) + IS_CSER(NCSERW(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NSED + JJ=MSVSED(N) + IS_CSER(NCSERW(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NSND + JJ=MSVSND(N) + IS_CSER(NCSERW(II,2),JJ)=.TRUE. + ENDDO + DO NW=1,NWQV + JJ=4+NTOX+NSED+NSND+NW + IS_CSER(NCSERW(II,JJ),JJ)=.TRUE. + ENDDO + DO NSP=1,NXSP + JJ=4+NTOX+NSED+NSND+NW+NWQV+NSP + IS_CSER(NCSERW(II,JJ),JJ)=.TRUE. + ENDDO + ENDIF + ENDDO + ENDIF + +!! CARD C57 + IF(NCBE.GT.0)THEN + DO II=1,NCBE + IF(ISDOMAIN(LIJ(ICBE(II),JCBE(II))))THEN + DO JJ=1,4 + IS_CSER(NCSERE(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NTOX + JJ=MSVTOX(N) + IS_CSER(NCSERE(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NSED + JJ=MSVSED(N) + IS_CSER(NCSERE(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NSND + JJ=MSVSND(N) + IS_CSER(NCSERE(II,2),JJ)=.TRUE. + ENDDO + DO NW=1,NWQV + JJ=4+NTOX+NSED+NSND+NW + IS_CSER(NCSERE(II,JJ),JJ)=.TRUE. + ENDDO + DO NSP=1,NXSP + JJ=4+NTOX+NSED+NSND+NW+NWQV+NSP + IS_CSER(NCSERE(II,JJ),JJ)=.TRUE. + ENDDO + ENDIF + ENDDO + ENDIF + +!! CARD C62 + IF(NCBN.GT.0)THEN + DO II=1,NCBN + IF(ISDOMAIN(LIJ(ICBN(II),JCBN(II))))THEN + DO JJ=1,4 + IS_CSER(NCSERN(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NTOX + JJ=MSVTOX(N) + IS_CSER(NCSERN(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NSED + JJ=MSVSED(N) + IS_CSER(NCSERN(II,2),JJ)=.TRUE. + ENDDO + DO N=1,NSND + JJ=MSVSND(N) + IS_CSER(NCSERN(II,2),JJ)=.TRUE. + ENDDO + DO NW=1,NWQV + JJ=4+NTOX+NSED+NSND+NW + IS_CSER(NCSERN(II,JJ),JJ)=.TRUE. + ENDDO + DO NSP=1,NXSP + JJ=4+NTOX+NSED+NSND+NW+NWQV+NSP + IS_CSER(NCSERN(II,JJ),JJ)=.TRUE. + ENDDO + ENDIF + ENDDO + ENDIF + ENDIF + + ENDSUBROUTINE + +!########################################################################################################### + + SUBROUTINE MPI_MASKDRY + + MPI_IMASKDRY=0 + DO L=1,LA + IF(IMASKDRY(L).EQ.1) MPI_IMASKDRY(L)=1. + ENDDO + + ENDSUBROUTINE + + +END MODULE diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Makefile b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Makefile index 2ab92ac73..e08f4eed9 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Makefile +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Makefile @@ -5,8 +5,8 @@ # #----- Fortran Compiler Settings --------------------------------------------- -# gfortran compiler -MAKE_FF=gfortran +# mpi gfortran compiler +MAKE_FF=mpifort # we want to use linux32 command to simulate 32bit on a 64bit machine MACH = $(shell arch) @@ -28,7 +28,8 @@ endif MAKE_FDEBUG = -g -fbounds-check -Wall -fbacktrace -finit-real=nan -ffpe-trap=invalid,zero,overflow # debug MAKE_FOPTIMIZE = -O # optimize -MAKE_FFLAGS_SPECIFIC = -fPIC -ffixed-line-length-none -ffree-line-length-none # gfortran +# Add '-fallow-argument-mismatch' to suppress errors on type mismatch in mpi library calls +MAKE_FFLAGS_SPECIFIC = -fPIC -ffixed-line-length-none -ffree-line-length-none -fallow-argument-mismatch # gfortran MAKE_FFLAGS = \ $(MAKE_FFLAGS_SPECIFIC) $(MFLAG_ARCH) @@ -36,13 +37,12 @@ MAKE_FFLAGS = \ #FFLAGS = -ffixed-line-length-none -ffree-line-length-none -fPIC -POBJECTS = CGATEFLX.po RWQC1.po - OBJECTS = \ +CGATEFLX.o RWQC1.o \ ACON.o CALEXP.o CALTSXY.o READWIMS1.o WQSKE4.o GATECTLREAD.o SCANEFDC.o \ VELPLTH.o DRIFTER.o SURFPLT.o WINDWAVE.o s_sedzlj.o EEXPOUT.o RESTOUT.o \ WQ3D.o s_shear.o CALHEAT.o CALPUVTT.o VARZEROReal.o \ -BAL2T5.o READOIL.o CALEXP2T0.o \ +BAL2T5.o READOIL.o \ AINIT.o CALEXP2T.o CALUVW.o DUMP.o READWIMS2.o SCANGATECTL.o SVBKSB.o WQZERO.o \ BAL2T1.o CALFQC.o CALVEGSER.o RELAX2T.o SCANGSER.o SVDCMP.o WQZERO2.o \ BAL2T2.o CALHDMF.o CALWQC.o RESTIN1.o SCANGWSR.o TIMELOG.o WQZERO3.o \ @@ -76,7 +76,13 @@ CALDIFF.o CALTOX.o CSNDSET.o RCAHQ.o SALTSMTH.o SOLVSMBE.o CALDISP2.o CALTOXB.o CSNDZEQ.o SCANASER.o SCANGTAB.o SSEDTOX.o WQSKE1.o \ CALDISP3.o CALTRAN.o DEPPLT.o SCANDSER.o SUBCHAN.o WQSKE2.o \ VARALLOC1.o VARALLOC2.o VARALLOC3.o VARALLOC4.o VARALLOC5.o VARALLOC6.o VARALLOC7.o VARALLOC8.o\ -CALEBI.o CALTRANQ.o READTOX.o WQSKE3.o pbm_cut.o Sub_spore.o WQSTOKES01.o +CALEBI.o CALTRANQ.o READTOX.o WQSKE3.o pbm_cut.o Sub_spore.o WQSTOKES01.o \ +CALAVB_mpi.o CALAVBOLD_mpi.o CALBUOY_mpi.o CALCONC_mpi.o CALCSER_mpi.o CALDIFF_mpi.o CALEBI_mpi.o \ +CALEXP2T_mpi.o CALFQC_mpi.o CALHDMF_mpi.o CALHEAT_mpi.o CALMMT_mpi.o CALPNHS_mpi.o CALPSER_mpi.o \ +CALPUV2C_mpi.o CALQQ2T_mpi.o CALQQ2TOLD_mpi.o CALQVS_mpi.o CALSFT_mpi.o CALTBXY_mpi.o CALTRAN_mpi.o \ +CALTSXY_mpi.o CALUVW_mpi.o CALVEGSER_mpi.o CALWQC_mpi.o CONGRAD_mpi.o \ +EEXPOUT_mpi.o HDMT2T_mpi.o RWQATM_mpi.o SALPLTH_mpi.o SALTSMTH_mpi.o SETBCS_mpi.o \ +VELPLTH_mpi.o WQ3D_mpi.o WQSKE3_mpi.o COMPAT_OBJS = \ drand.o @@ -94,9 +100,9 @@ openmp: MAKE_FFLAGS += $(F_OPENMP) openmp: MAKE_SO += $(F_OPENMP) openmp: libEfdcOrig.a -libEfdcOrig.a: $(POBJECTS) $(OBJECTS) $(COMPAT_OBJS) +libEfdcOrig.a: global.mod mpi.mod $(OBJECTS) $(COMPAT_OBJS) rm -f $@ - ar cq $@ $(POBJECTS) $(OBJECTS) $(COMPAT_OBJS) + ar cq $@ $(OBJECTS) $(COMPAT_OBJS) install: @@ -128,6 +134,7 @@ clobber: $(MAKE_FF) $(MAKE_FFLAGS) -c $< -o $@ global.mod: Var_Global_Mod.o +mpi.mod: global.mod MPI.o drifter.mod: DRIFTER.o windwave.mod: WINDWAVE.o @@ -141,7 +148,7 @@ CALHEAT.o: global.mod GATECTLREAD.o: global.mod CALPUVTT.o: global.mod READOIL.o: global.mod -CGATEFLX.po: global.mod +CGATEFLX.o: global.mod RESTOUT.o: global.mod VARZEROReal.o: global.mod s_sedzlj.o: global.mod @@ -357,3 +364,40 @@ s_bedload.o: global.mod s_main.o: global.mod s_morph.o: global.mod s_sedic.o: global.mod + + +CALAVB_mpi.o: global.mod mpi.mod +CALAVBOLD_mpi.o: global.mod mpi.mod +CALBUOY_mpi.o: global.mod mpi.mod +CALCONC_mpi.o: global.mod mpi.mod +CALCSER_mpi.o: global.mod mpi.mod +CALDIFF_mpi.o: global.mod mpi.mod +CALEBI_mpi.o: global.mod mpi.mod +CALEXP2T_mpi.o: global.mod mpi.mod +CALFQC_mpi.o: global.mod mpi.mod +CALHDMF_mpi.o: global.mod mpi.mod +CALHEAT_mpi.o: global.mod mpi.mod +CALMMT_mpi.o: global.mod mpi.mod +CALPNHS_mpi.o: global.mod mpi.mod +CALPSER_mpi.o: global.mod mpi.mod +CALPUV2C_mpi.o: global.mod mpi.mod +CALQQ2T_mpi.o: global.mod mpi.mod +CALQQ2TOLD_mpi.o: global.mod mpi.mod +CALQVS_mpi.o: global.mod mpi.mod +CALSFT_mpi.o: global.mod mpi.mod +CALTBXY_mpi.o: global.mod mpi.mod +CALTRAN_mpi.o: global.mod mpi.mod +CALTSXY_mpi.o: global.mod mpi.mod +CALUVW_mpi.o: global.mod mpi.mod +CALVEGSER_mpi.o: global.mod mpi.mod +CALWQC_mpi.o: global.mod mpi.mod +CONGRAD_mpi.o: global.mod mpi.mod +EEXPOUT_mpi.o: global.mod mpi.mod +HDMT2T_mpi.o: global.mod mpi.mod +RWQATM_mpi.o: global.mod mpi.mod +SALPLTH_mpi.o: global.mod mpi.mod +SALTSMTH_mpi.o: global.mod mpi.mod +SETBCS_mpi.o: global.mod mpi.mod +VELPLTH_mpi.o: global.mod mpi.mod +WQ3D_mpi.o: global.mod mpi.mod +WQSKE3_mpi.o: global.mod mpi.mod diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Makefile.aix b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Makefile.aix index da24926da..76ee61e71 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Makefile.aix +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Makefile.aix @@ -30,7 +30,7 @@ OBJECTS = \ ACON.o CALEXP.o CALTSXY.o READWIMS1.o WQSKE4.o GATECTLREAD.o SCANEFDC.o \ VELPLTH.o DRIFTER.o SURFPLT.o WINDWAVE.o s_sedzlj.o EEXPOUT.o RESTOUT.o \ WQ3D.o s_shear.o CALHEAT.o CALPUVTT.o VARZEROReal.o \ -BAL2T5.o READOIL.o CALEXP2T0.o \ +BAL2T5.o READOIL.o \ AINIT.o CALEXP2T.o CALUVW.o DUMP.o READWIMS2.o SCANGATECTL.o SVBKSB.o WQZERO.o \ BAL2T1.o CALFQC.o CALVEGSER.o RELAX2T.o SCANGSER.o SVDCMP.o WQZERO2.o \ BAL2T2.o CALHDMF.o CALWQC.o RESTIN1.o SCANGWSR.o TIMELOG.o WQZERO3.o \ diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/NEGDEP.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/NEGDEP.for index 81b21f29e..51c8a4425 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/NEGDEP.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/NEGDEP.for @@ -5,10 +5,14 @@ C ADDED ALTERNATE SOR EQUATION SOLVER RELAX2T C ** SUBROUTINE NEGDEP CHECK EXTERNAL SOLUTION FOR NEGATIVE DEPTHS C USE GLOBAL + USE MPI DIMENSION QCHANUT(NCHANM),QCHANVT(NCHANM) + INTEGER INEGFLG + INEGFLG=0 C C ** CHECK FOR NEGATIVE DEPTHS C + IF(MYRANK.EQ.0)THEN IF(ISNEGH.GE.1)THEN INEGFLG=0 DO L=2,LA @@ -150,8 +154,9 @@ C STOP ENDIF ENDIF + ENDIF 1001 FORMAT(2I5,10(1X,E12.4)) - 1002 FORMAT(3I4,10(1X,E9.2)) +C1002 FORMAT(3I4,10(1X,E9.2)) 1991 FORMAT(2I5,12F8.3) 1992 FORMAT(10X,12F8.3) 1111 FORMAT(' NEG DEPTH AT CELL CENTER') diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUT3D.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUT3D.for index cfff51ee4..2af61fc3e 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUT3D.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUT3D.for @@ -3,6 +3,7 @@ C C CHANGE RECORD C USE GLOBAL + USE MPI CHARACTER *11 SALFN,TEMFN,DYEFN,SEDFN,UUUFN,VVVFN,WWWFN, & CMPFN,SNDFN,TOXFN @@ -16,6 +17,7 @@ C C C ** INITIALIZE OUTPUT FILES C + IF(MYRANK.EQ.0)THEN IAD=I3DMAX-I3DMIN+1 JAD=J3DMAX-J3DMIN+1 NCALL3D=NCALL3D+1 @@ -1351,12 +1353,12 @@ C ENDIF ENDIF ENDIF - 500 FORMAT(5I5) +C 500 FORMAT(5I5) 501 FORMAT(72I4) 502 FORMAT(I5,F10.4) - 505 FORMAT(8F10.5) - 506 FORMAT(I5,2X,F10.5,5X,I5) - 510 FORMAT(2I5,4(2X,F10.5)) +C 505 FORMAT(8F10.5) +C 506 FORMAT(I5,2X,F10.5,5X,I5) +C 510 FORMAT(2I5,4(2X,F10.5)) 520 FORMAT('IAD = ',I5,' JAD = ',I5//) 521 FORMAT('SALMAX = ',E12.4,' SALMIN = ',E12.4/) 522 FORMAT('TEMMAX = ',E12.4,' TEMMIN = ',E12.4/) @@ -1371,6 +1373,7 @@ C 551 FORMAT(72F7.1) 559 FORMAT(2I4,2X,72I2) CLOSE(50) + ENDIF RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUTOIL.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUTOIL.for index c969db886..f3cd43677 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUTOIL.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUTOIL.for @@ -3,6 +3,7 @@ SUBROUTINE OUTOIL USE GLOBAL + USE MPI IMPLICIT NONE @@ -11,6 +12,7 @@ ! REAL OILCONC + IF(MYRANK.EQ.0)THEN IF(JSPD==1) THEN OPEN(7773,FILE='MASS-TOTAL.DAT',STATUS='UNKNOWN') @@ -123,6 +125,7 @@ C & OILAREA, OILTHICK, SQRT(OILAREA/PI),SQRT(BETA1/PI*SQRT(N*DT)) ENDDO ENDIF + ENDIF END SUBROUTINE -!} \ No newline at end of file +!} diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUTPUT2.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUTPUT2.for index dd7d831bd..4570ccc70 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUTPUT2.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/OUTPUT2.for @@ -3,23 +3,26 @@ C C CHANGE RECORD C USE GLOBAL + USE MPI C C ** OUTPUT RESULTS OF RELAXATION SOLUTION C + IF(MYRANK.EQ.0)THEN WRITE (7,40) RP 40 FORMAT (1H1,' RESULTS OF RELAX SOLUTION - RP=',F5.2,//) WRITE (7,41) 41 FORMAT (' GLOBAL SQUARED ERROR',//) WRITE(7,43)ERRMAX,ERRMIN 43 FORMAT('ERRMAX =',3X,E12.4,5X,'ERRMIN =',3X,E12.4) - 20 FORMAT (1X,I5,3X,10E12.4) +C 20 FORMAT (1X,I5,3X,10E12.4) WRITE(7,40)RP WRITE (7,42) 42 FORMAT (' ITERATIONS TO CONVERGENCE',//) WRITE(7,44)ITRMAX,ITRMIN 44 FORMAT('ITRMAX =',I5,5X,'ITRMIN =',I5) - 21 FORMAT (1X,I5,5X,10I10) - 30 FORMAT (10E12.4) +C 21 FORMAT (1X,I5,5X,10I10) +C 30 FORMAT (10E12.4) + ENDIF C C ** OUTPUT HARMONIC ANALYSIS C @@ -34,25 +37,25 @@ C DO L=2,LA PAM(L)=PAM(L)*GI ENDDO - WRITE (7,55) + IF(MYRANK.EQ.0) WRITE (7,55) CALL PPLOT (1) 55 FORMAT (1H1,'TIDAL SURFACE DISPLACEMENT AMPLITUDE IN METERS',//) DO L=2,LA PAM(L)=0.5*TIDALP*PPH(L)/PI ENDDO - WRITE(7,588) + IF(MYRANK.EQ.0) WRITE(7,588) CALL PPLOT (1) 588 FORMAT (1H1,'TIDAL SURFACE DISPLACEMENT PHASE IN SEC',//) C C ** PRINTED OUTPUT OF P,U,AND V AMPLITUDES C - 72 FORMAT(3I5,4(3X,E12.4)) +C 72 FORMAT(3I5,4(3X,E12.4)) C C ** OUTPUT VECTOR POTENTIAL TRANSPORT VELOCITY C - 1458 FORMAT(1H1,' X VECTOR POTENTIAL TRANSPORT VEL, M/S, LAYER',I5,//) - 1459 FORMAT(1H1,' Y VECTOR POTENTIAL TRANSPORT VEL, M/S, LAYER',I5,//) - 100 CONTINUE +C1458 FORMAT(1H1,' X VECTOR POTENTIAL TRANSPORT VEL, M/S, LAYER',I5,//) +C1459 FORMAT(1H1,' Y VECTOR POTENTIAL TRANSPORT VEL, M/S, LAYER',I5,//) +C 100 CONTINUE RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/PPLOT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/PPLOT.for index ae329f9cc..64029fc81 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/PPLOT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/PPLOT.for @@ -3,6 +3,7 @@ C C CHANGE RECORD C USE GLOBAL + USE MPI CHARACTER BLANK,ASTER,LET1(51),LET2(51) DIMENSION BNDU(51),BNDL(51) CHARACTER*1,ALLOCATABLE,DIMENSION(:,:)::CHARY @@ -39,16 +40,16 @@ C ENDDO IF(IPT.EQ.1)THEN DO M=1,NBAN - WRITE (7,10) BNDU(M),LET1(M),BNDL(M) + IF(MYRANK.EQ.0) WRITE (7,10) BNDU(M),LET1(M),BNDL(M) ENDDO ELSE DO M=1,NBAN - WRITE (7,10) BNDU(M),LET2(M),BNDL(M) + IF(MYRANK.EQ.0) WRITE (7,10) BNDU(M),LET2(M),BNDL(M) ENDDO ENDIF 10 FORMAT (5X,E12.4,5X,A1,5X,E12.4) - 11 FORMAT (////) - WRITE(7,12) +C 11 FORMAT (////) + IF(MYRANK.EQ.0) WRITE(7,12) 12 FORMAT(1H1) C C ** LOAD CHARACTER ARRAY @@ -78,9 +79,9 @@ C JS=JJ JE=JJ+119 IF(JE.GT.JC) JE=JC - WRITE(7,22)JS,JE + IF(MYRANK.EQ.0) WRITE(7,22)JS,JE DO I=1,IC - WRITE (7,20) I,(CHARY(I,J),J=JS,JE) + IF(MYRANK.EQ.0) WRITE (7,20) I,(CHARY(I,J),J=JS,JE) ENDDO ENDDO 20 FORMAT (1X,I3,2X,120A1) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RCAHQ.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RCAHQ.for index 8e7a95c2d..6f20e2c55 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RCAHQ.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RCAHQ.for @@ -7,6 +7,7 @@ C ** WITH WITHDRAWL-RETURN FLOW OPTION DEACTIVATED BY CNWR C C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP? USE GLOBAL + USE MPI REAL,ALLOCATABLE,DIMENSION(:)::DZRCA REAL,ALLOCATABLE,DIMENSION(:)::DZZRCA @@ -27,6 +28,7 @@ C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP? C C ** WRITE TIME INVARIANT FILES ON FIRST ENTRY C + IF(MYRANK.EQ.0)THEN IF(JSWASP.EQ.0) GOTO 1000 JSWASP=0 OPEN(1,FILE='EFDC.RCA',STATUS='UNKNOWN') @@ -723,12 +725,13 @@ C ENDDO CLOSE(2) ENDIF + ENDIF 200 FORMAT(3I5,6F15.6) 201 FORMAT(' L,I(ROW),J(COL),QX(I,J,K),K=1,KC ',/) 202 FORMAT(' L,I(ROW),J(COL),QY(I,J,K),K=1,KC ',/) 203 FORMAT(' L,I(ROW),J(COL),QZ(I,J,K),K=1,KS ',/) - 204 FORMAT(' L,I(ROW),J(COL),AX(I,J,K),K=1,KC ',/) - 205 FORMAT(' L,I(ROW),J(COL),AY(I,J,K),K=1,KC ',/) +C 204 FORMAT(' L,I(ROW),J(COL),AX(I,J,K),K=1,KC ',/) +C 205 FORMAT(' L,I(ROW),J(COL),AY(I,J,K),K=1,KC ',/) 206 FORMAT(' L,I(ROW),J(COL),AZ(I,J,K),K=1,KS ',/) 207 FORMAT(' L,I(ROW),J(COL),SELS(I,J),SELE(I,J),DSEL(I,J) ',/) 208 FORMAT(' L,I(ROW),J(COL),SAL(I,J,K),K=1,KC ',/) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/README.md b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/README.md new file mode 100644 index 000000000..f1314a3d8 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/README.md @@ -0,0 +1,62 @@ +# Merge notes + +For the following files there was no clear, distinct approach to merge +the diffs that were present between the version of EFDC provided by NIER +(start of 2022) and the version present in Openda around the same time. +Each file corresponds with a single commit that introduced the patch for +that file. Note, this might not have been the right way to resolve the +conflicts... + +* `CALAVBOLD_mpi.for`: It is noted that `CALAVBOLD_mpi` performs + calculations using `SQRT` while the corresponding non-MPI + implementation uses multiplication with `0.5`... It is unclear why + this difference exists. No action has been taken to unify these + computations. +* `CALPUV2C.for`: The diffs contain some odd instructions in the loops + present in the OpenDA version. It has been decided to accept the + patches from NIER here and adopt that variant of the implementation. + Similarly, the assignment of `ICORDRY=1` is replaced with the NIER + alternative of `ICORDRY=ICORDRY+1`. It is not clear why these + differences exist and which might be the proper one... +* `CGATEFLX.for`: The NIER source misses the fix introducing boolean + `HUPG_HDWG_INITIALIZED` that was added in 2016 in OpenDA. + Additionally, the array GKMULT seems not to have been initialized in + all possible situations and could have been used uninitialized in + some. These patches were not brought back to OpenDA. +* `HDMT2T.for`: The NIER source does not invoke `CALEXP2TO` any longer + and shows slightly modified if-statements to consider which subroutine + to call. This subroutine is also no longer present in the provided + sources. It has been decided to cherry-pick these line diffs and + remove the remaining source file corresponding to `CALEXP2TO` all + together. +* `INPUT.for`: Input processing is extended with processing of + `WINDCOEFF` and `EFDC2` input files. It is unclear why this was not + yet present in OpenDA? Also, `IBIN_TYPE` is extracted with read calls. + NOTE: variable `TIDAPL` is *not* scaled with 86400 in OpenDA while + this is done in NIER. This seems to be a difference in conversion + factors of one day (86400 seconds in one day). It is unclear where + this difference comes from and how to resolve it... +* `READWIMS1.for`: It seems the variable initialisation was not divided + by the loop limit. This has been reintroduced. Note, there were + differences in various timing calculations. These are considered to be + the right ones in OpenDA. The differences are to be propagated back to + NIER. +* `RWQBEN2.for`: There seemed to be a patch missing in OpenDA. The NIER + version is taken for this file where a slightly different (possibly + renamed) set of variables are used to extract properties from cards. + These seem to be reassigned at previously used variables elsewhere in + the source. +* `VARINIT.for`: The comparison for `NQCTYPM` has been changed from + `.EQ.` to `.GE`. This seems mostly used. Inspection of the input decks + does not give more hints to the proper use of these values. Also, + `LCMWQ` setting is updated to match NIER. +* `WQ3D.for`: The version in OpenDA also considered `TASER` values in + the condition for the various while-loops and other statements. The + decision was made that the version in OpenDA is accurate and the + patches are to be propagated back to NIER. +* `WQSKE3.for`: This includes the missing loops (2 chunks) regarding + "green algae salinity tox" from NIER towards OpenDA. Additionally, + this converts all comparisons in OpenDA of the form + `IF(LMASKDRY(L).AND.IWQM.GE.1)THEN` from `.AND.` to `.OR.` to be + consistent with all other comparisons done like this. Also, the + comparison `IF(IWQBEN.EQ.1)THEN` now compares to zero instead. diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READOIL.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READOIL.for index 257755fd9..d4c522125 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READOIL.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READOIL.for @@ -6,9 +6,9 @@ IMPLICIT NONE - INTEGER(4):: NP1, I, J, K - REAL(RKD) :: XC(4), YC(4), AREA2, RANVAL - REAL(8), EXTERNAL::DRAND + INTEGER(4):: NP1 + REAL(RKD) :: RANVAL + REAL(8) :: DRAND REAL(RKD) :: OILAREAP REAL(RKD) :: ACCRAD @@ -142,7 +142,7 @@ CLOSE(21) RETURN - 999 STOP 'OIL.INFO READING ERROR!' +C 999 STOP 'OIL.INFO READING ERROR!' END SUBROUTINE diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READWIMS1.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READWIMS1.for index 402638596..e5c4b0bb5 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READWIMS1.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READWIMS1.for @@ -8,6 +8,7 @@ C ** READ THE EVENT INFORMATION FROM GUI SYSTEM C C USE GLOBAL + USE MPI REAL TXMASS,TXSW,SDAY,EDAY,EVDAY,TLOADTX,TXMASS2,TXVOL REAL TXMASS_3D(KC),TXMASS0(KC) INTEGER ISYEAR,ISMONTH,ISDATE,ISHR,ISMN, @@ -16,6 +17,7 @@ C & JSDAY,JEDAY,JEVDAY,JYEARDAY INTEGER IDTX CHARACTER*20 TXNAME + TXSW=0.0 C C READ TOX EVENT FROM WIMS INFORMATION C @@ -74,7 +76,7 @@ C NPTXLDS=FLOAT(NINT(TLOADTX*86400.)) ! LOADING START TIME [SEC] NPTXLDE=NPTXLDS+FLOAT(NINT(FLOAT(ITXPRD)*60.)) ! LOADING END TIME [SEC] TXMASS2=TXMASS/(FLOAT(ITXPRD)*60.) ! RELEASED MASS/TIME [KG/SEC] - TXVOL=0.000001 ! LOADING VOL/SEC [M3/SEC] + TXVOL=0.001 ! LOADING VOL/SEC [M3/SEC] TXLDC=TXMASS2/TXVOL ! CONC. FOR TXSER.INP [MG/L] TBEGIN1=SDAY @@ -89,14 +91,14 @@ C C PRINT TOXIC TIMESERIES FILE C !{ GeoSR, YSSONG, 101125 - IF(IDTOX.GT.0.AND.IDTOX.LT.4440)THEN ! ONLY FOR TOXIC MODULE + IF(IDTOX.GT.0.AND.IDTOX.LT.4440.AND.MYRANK.EQ.0)THEN ! ONLY FOR TOXIC MODULE !} OPEN(21,FILE='TXSER.INP',STATUS='UNKNOWN') CLOSE(21,STATUS='DELETE') OPEN(21,FILE='TXSER.INP',STATUS='UNKNOWN') DO K=1,KC - TXMASS_3D(K)=TXLDC + TXMASS_3D(K)=TXLDC/FLOAT(KC) TXMASS0(K)=0.0 ENDDO @@ -116,7 +118,7 @@ C CLOSE(21) ENDIF - IF(IDTOX.GT.0.AND.IDTOX.LT.4440)THEN ! ONLY FOR TOXIC MODULE (CWCHO) + IF(IDTOX.GT.0.AND.IDTOX.LT.4440.AND.MYRANK.EQ.0)THEN ! ONLY FOR TOXIC MODULE (CWCHO) OPEN(21,FILE='TOXEVENT.LOG',STATUS='UNKNOWN') WRITE(21,8998) ISYEAR,ISMONTH,ISDATE,ISHR,ISMN WRITE(21,8997) IEVYEAR,IEVMONTH,IEVDATE,IEVHR,IEVMN @@ -129,9 +131,8 @@ C 8997 FORMAT('LOADING TIME :',2X,I4,'.',I2,'/',I2,'.',I2,':',I2) 8995 FORMAT('LOADING PERIOD [MIN] :',I4) 8994 FORMAT('LOADING MASS [g] :',F12.3) ! 2010.12.8 - 8993 FORMAT('LOADING RATE [KG/S] :',F7.3) - - IF(IDTOX.GE.4440)THEN ! ONLY FOR OIL MODULE(CWCHO 101101) + 8993 FORMAT('LOADING RATE [KG/S] :',F8.3) + IF(IDTOX.GE.4440.AND.MYRANK.EQ.0)THEN ! ONLY FOR OIL MODULE(CWCHO 101101) ! [CWCHO, 101203] OPEN(1,FILE='TOX2.INFO',STATUS='UNKNOWN') @@ -182,12 +183,12 @@ C----------------------------------------------------------------------C DATE3=DATE2+153 IF(IMONTH.GE.3 .AND. IMONTH.LE.7 ) THEN - ITDATE=DATE2 + ITDATE=INT(DATE2,KIND(ITDATE)) IRMONTH=8 ENDIF IF(IMONTH.GE.8 .AND. IMONTH.LE.12 ) THEN - ITDATE=DATE3 + ITDATE=INT(DATE3,KIND(ITDATE)) IRMONTH=13 ENDIF diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READWIMS2.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READWIMS2.for index 8a217b329..12c76e33e 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READWIMS2.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/READWIMS2.for @@ -34,7 +34,7 @@ C ENDIF ! 2014.09.14. YSSONG, COMMENTOUT ENDIF 8999 FORMAT('LOADING POINT :',2(F12.3,1X),2X,'(',I4,',',I4,')') - 8998 FORMAT('LOADING POINT :',2(F12.3,1X)) !,2X,'(',I4,',',I4,')') +C8998 FORMAT('LOADING POINT :',2(F12.3,1X)) !,2X,'(',I4,',',I4,')') CLOSE(21) RETURN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RELAX2T.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RELAX2T.for index 15e6ac768..fa0a156b0 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RELAX2T.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RELAX2T.for @@ -14,6 +14,9 @@ C ** NON-CONVERGENCE IS SIGNALED WHEN THE ITERATIONS EXCEED A C ** MAXIMUM. C USE GLOBAL + USE MPI + REAL RPT + RPT=0.0 RJ2=RP C C PAVG=0.0 @@ -67,7 +70,7 @@ C C C ** CHECK MAXIMUM ITERATION CRITERIA C - IF(ITER .GE. ITERM)THEN + IF(ITER .GE. ITERM.AND.MYRANK.EQ.0)THEN WRITE(6,600) WRITE(6,601)RSQ WRITE(8,600) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN1.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN1.for index e994b6d91..f71228f44 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN1.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN1.for @@ -5,12 +5,13 @@ C ADDED CODE TO PROPERLY INITIAL RESTART INPUT FOR DRYING AND WETTING C ** SUBROUTINE RESTIN1 READS A RESTART FILE C USE GLOBAL + USE MPI REAL,ALLOCATABLE,DIMENSION(:)::TDUMMY ALLOCATE(TDUMMY(KCM)) TDUMMY=0. C - PRINT *,'READING RESTART FILE: RESTART.INP' + IF(MYRANK.EQ.0) PRINT *,'READING RESTART FILE: RESTART.INP' OPEN(1,FILE='RESTART.INP',STATUS='UNKNOWN') ISBELVC=0 READ(1,908,ERR=1000)NREST @@ -208,8 +209,8 @@ C ENDDO ENDIF CLOSE(1) - 6666 FORMAT(3I10,F12.6) - 6667 FORMAT(7I5,2X,E12.4,2X,E12.4) +C6666 FORMAT(3I10,F12.6) +C6667 FORMAT(7I5,2X,E12.4,2X,E12.4) DO K=1,KC SAL(1,K)=0. TEM(1,K)=0. @@ -408,7 +409,6 @@ C C C *** DSLLC END BLOCK C - PRINT *,'READING RESTART FILE: TEMP.RST' OPEN(1,FILE='TEMP.RST',STATUS='UNKNOWN') DO L=2,LA READ(1,*)LDUM,IDUM,JDUM,(TDUMMY(K),K=1,KC),TEMB(L) @@ -512,19 +512,23 @@ C ENDDO ENDIF IF(ISDRY.EQ.99)THEN - PRINT *,'READING RESTART FILE: RSTWD.INP' + IF(MYRANK.EQ.0)PRINT *,'READING RESTART FILE: RSTWD.INP' OPEN(1,FILE='RSTWD.INP',STATUS='UNKNOWN') + IF(MYRANK.EQ.0)THEN OPEN(2,FILE='RSTWD.RCK',STATUS='UNKNOWN') CLOSE(2,STATUS='DELETE') OPEN(2,FILE='RSTWD.RCK',STATUS='UNKNOWN') + ENDIF DO L=2,LA READ(1,*)LDUM,IDUM,JDUM,ISCDRY(L),NATDRY(L), & IMASKDRY(L),SUB(L),SVB(L) + IF(MYRANK.EQ.0)THEN WRITE(2,913)LDUM,IDUM,JDUM,ISCDRY(L),NATDRY(L), & IMASKDRY(L),SUB(L),SVB(L),SUBO(L),SVBO(L) + ENDIF ENDDO CLOSE(1) - CLOSE(2) + IF(MYRANK.EQ.0) CLOSE(2) ENDIF 913 FORMAT(6I10,4F7.3) C @@ -534,13 +538,14 @@ C IF(IMASKDRY(L).EQ.0) LMASKDRY(L)=.TRUE. IF(IMASKDRY(L).GT.0) LMASKDRY(L)=.FALSE. END DO + MPI_IMASKDRY = IMASKDRY C C *** DSLLC END BLOCK C GOTO 3000 - 101 FORMAT(I5) - 102 FORMAT(3I5,12F8.2) +C 101 FORMAT(I5) +C 102 FORMAT(3I5,12F8.2) C C ** WRITE READ ERRORS ON RESTART C @@ -614,8 +619,8 @@ C STOP 600 FORMAT(2X,'I,J,BELVOLD,BELVNEW',2I5,2F12.2) - 906 FORMAT(5E15.7) - 907 FORMAT(12E12.4) +C 906 FORMAT(5E15.7) +C 907 FORMAT(12E12.4) 908 FORMAT(12I10) 2000 FORMAT(' READ ERROR ON FILE RESTART.INP ERR 1000') 2001 FORMAT(' READ ERROR ON FILE RESTART.INP ERR 1001 L =',I6) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN10.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN10.for index 6bcba021b..510c36bc4 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN10.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN10.for @@ -5,8 +5,9 @@ C ** SUBROUTINE RESTINP READS A RESTART FILE GENERATED BY A C ** PRE SEPTEMBER 8, 1992 VERSION OF EFDC.FOR C USE GLOBAL + USE MPI - PRINT *,'READING RESTIN10 FILE: RESTART.INP' + IF(MYRANK.EQ.0)PRINT *,'READING RESTIN10 FILE: RESTART.INP' OPEN(1,FILE='RESTART.INP',STATUS='UNKNOWN') READ(1,*,ERR=1000)NREST DO L=2,LA @@ -286,8 +287,8 @@ C 1001 FORMAT(' READ ERROR ON FILE RESTART.INP ') STOP 1002 CONTINUE - 907 FORMAT(12E12.4) - 908 FORMAT(12I10) +C 907 FORMAT(12E12.4) +C 908 FORMAT(12I10) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN2.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN2.for index b70ffc2fe..a3b9786ee 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN2.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTIN2.for @@ -5,8 +5,9 @@ C ** SUBROUTINE RESTINP READS A RESTART FILE FOR (KC/2) LAYERS AND C ** AND INITIALIZES FOR KC LAYERS C USE GLOBAL + USE MPI - PRINT *,'READING RESTIN2 FILE: RESTART.INP' + IF(MYRANK.EQ.0)PRINT *,'READING RESTIN2 FILE: RESTART.INP' OPEN(1,FILE='RESTART.INP',STATUS='UNKNOWN') READ(1,908,ERR=1000)NREST DO L=2,LA @@ -201,8 +202,8 @@ C 1001 FORMAT(' READ ERROR ON FILE RESTART.INP ') STOP 1002 CONTINUE - 906 FORMAT(4E15.7) - 907 FORMAT(12E12.4) +C 906 FORMAT(4E15.7) +C 907 FORMAT(12E12.4) 908 FORMAT(12I10) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTOUT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTOUT.for index a1052f586..c92f7f168 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTOUT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RESTOUT.for @@ -6,6 +6,7 @@ C ADD OUTPUT OF BED LOAD TRANSPORT QSBDLDX QSBDLDY C ** SUBROUTINE RESTOUT WRITES A RESTART FILE C USE GLOBAL + USE MPI CHARACTER*64 RESTFN ! { GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.5.23 REAL HPRES(LCM),H1PRES(LCM),HWQRES(LCM),H2WQRES(LCM) ! NEG. DEP.: JGCHO 2014.9.3 @@ -16,13 +17,165 @@ C ! { GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.6.3 IF (IRSTYP.EQ.-19) GOTO 7502 ! } GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.6.3 - IF(IRSTYP.EQ.0)THEN + + call collect_in_zero(BELV) + call collect_in_zero(HP) + call collect_in_zero(H1P) + call collect_in_zero(HWQ) + call collect_in_zero(H2WQ) + call collect_in_zero(UHDYE) + call collect_in_zero(UHDY1E) + call collect_in_zero(VHDXE) + call collect_in_zero(VHDX1E) + + do k=0,kcm + call collect_in_zero(QQSQR(:,k)) + call collect_in_zero(QQ(:,k)) + call collect_in_zero(QQ1(:,k)) + call collect_in_zero(QQL(:,k)) + call collect_in_zero(QQL1(:,k)) + call collect_in_zero(DML(:,k)) + enddo + + call collect_in_zero_array(U) + call collect_in_zero_array(U1) + call collect_in_zero_array(V) + call collect_in_zero_array(V1) + + IF(ISCO(1).EQ.1)THEN + call collect_in_zero_array(SAL) + call collect_in_zero_array(SAL1) + ENDIF + IF(ISCO(2).EQ.1)THEN + call collect_in_zero_array(TEM) + call collect_in_zero_array(TEM1) + ENDIF + IF(ISCO(3).EQ.1)THEN + call collect_in_zero_array(DYE) + call collect_in_zero_array(DYE1) + ENDIF + IF(ISCO(4).EQ.1)THEN + call collect_in_zero(SFLSBOT) + call collect_in_zero_array(SFL) + call collect_in_zero_array(SFL2) + ENDIF + IF(ISCO(5).EQ.1)THEN + do nt=1,ntox + call collect_in_zero_array(TOX(:,:,nt)) + call collect_in_zero_array(TOX1(:,:,nt)) + call collect_in_zero_array_kbm(TOXB(:,:,nt)) + call collect_in_zero_array_kbm(TOXB1(:,:,nt)) + enddo + ENDIF + IF(ISCO(6).EQ.1)THEN + do ns=1,nsed + call collect_in_zero_array(SED(:,:,ns)) + call collect_in_zero_array(SED1(:,:,ns)) + call collect_in_zero_array_kbm(SEDB(:,:,ns)) + call collect_in_zero_array_kbm(SEDB1(:,:,ns)) + enddo + ENDIF + IF(ISCO(7).EQ.1)THEN + do ns=1,nsnd + call collect_in_zero_array(SND(:,:,ns)) + call collect_in_zero_array(SND1(:,:,ns)) + call collect_in_zero_array_kbm(SNDB(:,:,ns)) + call collect_in_zero_array_kbm(SNDB1(:,:,ns)) + enddo + ENDIF + IF(ISCO(6).EQ.1.OR.ISCO(7).EQ.1)THEN + call collect_in_zero_array_kbm(HBED) + call collect_in_zero_array_kbm(HBED1) + call collect_in_zero_array_kbm(VDRBED) + call collect_in_zero_array_kbm(VDRBED1) + ENDIF + call collect_in_zero(QSUME) + call collect_in_zero_array(QSUM) + IF(ISGWIE.GE.1)THEN + call collect_in_zero(AGWELV) + call collect_in_zero(AGWELV1) + ENDIF + + CLOS_TMP=CLOS + CLOW_TMP=CLOW + CLOE_TMP=CLOE + CLON_TMP=CLON + NLOS_TMP=NLOS + NLOW_TMP=NLOW + NLOE_TMP=NLOE + NLON_TMP=NLON + + DO K=1,KCM + DO LL=1,NBBSM + IF(.NOT.ISDOMAIN(LCBS(LL)))THEN + CLOS_TMP(LL,K,1:NSTVM)=0. + NLOS_TMP(LL,K,1:NSTVM)=0 + ENDIF + ENDDO + ENDDO + + DO K=1,KCM + DO LL=1,NBBWM + IF(.NOT.ISDOMAIN(LCBW(LL)))THEN + CLOW_TMP(LL,K,1:NSTVM)=0. + NLOW_TMP(LL,K,1:NSTVM)=0 + ENDIF + ENDDO + ENDDO + + DO K=1,KCM + DO LL=1,NBBEM + IF(.NOT.ISDOMAIN(LCBE(LL)))THEN + CLOE_TMP(LL,K,1:NSTVM)=0. + NLOE_TMP(LL,K,1:NSTVM)=0 + ENDIF + ENDDO + ENDDO + + DO K=1,KCM + DO LL=1,NBBNM + IF(.NOT.ISDOMAIN(LCBN(LL)))THEN + CLON_TMP(LL,K,1:NSTVM)=0. + NLON_TMP(LL,K,1:NSTVM)=0 + ENDIF + ENDDO + ENDDO + + CALL MPI_ALLREDUCE(CLOS_TMP,CLOS,NBBSM*KCM*NSTVM, + & MPI_REAL,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(CLOW_TMP,CLOW,NBBWM*KCM*NSTVM, + & MPI_REAL,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(CLOE_TMP,CLOE,NBBEM*KCM*NSTVM, + & MPI_REAL,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(CLON_TMP,CLON,NBBNM*KCM*NSTVM, + & MPI_REAL,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(NLOS_TMP,NLOS,NBBSM*KCM*NSTVM, + & MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(NLOW_TMP,NLOW,NBBWM*KCM*NSTVM, + & MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(NLOE_TMP,NLOE,NBBEM*KCM*NSTVM, + & MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(NLON_TMP,NLON,NBBNM*KCM*NSTVM, + & MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,IERR) + +CGEO if(myrank.eq.0)THEN +CGEO print*, n,'NLOS1',sum(NLOS) +CGEO print*, n,'CLOS1',sum(CLOS) +CGEO print*, n,'NLOW1',sum(NLOW) +CGEO print*, n,'CLOW1',sum(CLOW) +CGEO print*, n,'NLOE1',sum(NLOE) +CGEO print*, n,'CLOE1',sum(CLOE) +CGEO print*, n,'NLON1',sum(NLON) +CGEO print*, n,'CLON1',sum(CLON) +CGEO endif + + IF(IRSTYP.EQ.0.AND.MYRANK.EQ.0)THEN PRINT *,'Restart Snapshot @ Timeday: ',TIMEDAY OPEN(99,FILE='RESTART.OUT',STATUS='UNKNOWN') CLOSE(99,STATUS='DELETE') OPEN(99,FILE='RESTART.OUT',STATUS='UNKNOWN') ENDIF - IF(IRSTYP.EQ.1)THEN + IF(IRSTYP.EQ.1.AND.MYRANK.EQ.0)THEN OPEN(99,FILE='CRASHST.OUT',STATUS='UNKNOWN') CLOSE(99,STATUS='DELETE') OPEN(99,FILE='CRASHST.OUT',STATUS='UNKNOWN') @@ -69,6 +222,7 @@ C ELSE TIME=TIMESEC/TCON ENDIF + IF(MYRANK.EQ.0) THEN WRITE(99,909)N,TIME DO L=2,LA !{ NEG. DEP.: JGCHO 2014.9.3 @@ -120,7 +274,7 @@ C IF(ISCO(6).EQ.1)THEN DO NS=1,NSED WRITE(99,907)(SEDB(L,K,NS),K=1,KB) - WRITE(99,907)(SED1(L,K,NS),K=1,KC) + WRITE(99,907)(SED(L,K,NS),K=1,KC) WRITE(99,907)(SEDB1(L,K,NS),K=1,KB) WRITE(99,907)(SED1(L,K,NS),K=1,KC) ENDDO @@ -288,51 +442,87 @@ C ENDDO ENDIF CLOSE(99) + ENDIF C C *** SPECIAL FILES C IF(ISWAVE.GE.1)THEN - OPEN(1,FILE='WVQWCP.OUT',STATUS='UNKNOWN') - CLOSE(1, STATUS='DELETE') - OPEN(1,FILE='WVQWCP.OUT',STATUS='UNKNOWN') - DO L=2,LA - WRITE(1,911)IL(L),JL(L),QQWV1(L),QQWV2(L),QQWV3(L),QQWC(L), - & QQWCR(L),QQ(L,0) - ENDDO - CLOSE(1) + call collect_in_zero(QQWV1) + call collect_in_zero(QQWV2) + call collect_in_zero(QQWV3) + call collect_in_zero(QQWC) + call collect_in_zero(QQWCR) + do k=0,kcm + call collect_in_zero(QQ(:,k)) + enddo ENDIF IF(ISCO(1).GE.1.AND.ISTRAN(1).GT.0)THEN - OPEN(1,FILE='SALT.RST',STATUS='UNKNOWN') - CLOSE(1, STATUS='DELETE') - OPEN(1,FILE='SALT.RST',STATUS='UNKNOWN') - DO L=2,LA - WRITE(1,912)L,IL(L),JL(L),(SAL(L,K),K=1,KC) - ENDDO - CLOSE(1) + call collect_in_zero_array(SAL) ENDIF IF(ISCO(2).GE.1.AND.ISTRAN(2).GT.0)THEN - OPEN(1,FILE='TEMP.RSTO',STATUS='UNKNOWN') - CLOSE(1, STATUS='DELETE') - OPEN(1,FILE='TEMP.RSTO',STATUS='UNKNOWN') - DO L=2,LA - WRITE(1,912)L,IL(L),JL(L),(TEM(L,K),K=1,KC),TEMB(L) - ENDDO - CLOSE(1) - ENDIF - IF(ISDRY.EQ.99)THEN - OPEN(1,FILE='RSTWD.OUT',STATUS='UNKNOWN') - CLOSE(1, STATUS='DELETE') - OPEN(1,FILE='RSTWD.OUT',STATUS='UNKNOWN') - DO L=2,LA - WRITE(1,913)L,IL(L),JL(L),ISCDRY(L),NATDRY(L), - & IMASKDRY(L),SUB(L),SVB(L),SUBO(L),SVBO(L) - ENDDO - CLOSE(1) - ENDIF + call collect_in_zero_array(TEM) + call collect_in_zero(TEMB) + ENDIF + IF(ISDRY.EQ.99)THEN + call collect_in_zero_int(ISCDRY) + call collect_in_zero_int(NATDRY) + call collect_in_zero_int(IMASKDRY) + call collect_in_zero(SUB) + call collect_in_zero(SVB) + call collect_in_zero(SUBO) + call collect_in_zero(SVBO) + ENDIF C + IF(MYRANK.EQ.0)THEN + IF(ISWAVE.GE.1)THEN + OPEN(1,FILE='WVQWCP.OUT',STATUS='UNKNOWN') + CLOSE(1, STATUS='DELETE') + OPEN(1,FILE='WVQWCP.OUT',STATUS='UNKNOWN') + DO L=2,LA + WRITE(1,911)IL(L),JL(L),QQWV1(L),QQWV2(L),QQWV3(L),QQWC(L), + & QQWCR(L),QQ(L,0) + ENDDO + CLOSE(1) + ENDIF + IF(ISCO(1).GE.1.AND.ISTRAN(1).GT.0)THEN + OPEN(1,FILE='SALT.RST',STATUS='UNKNOWN') + CLOSE(1, STATUS='DELETE') + OPEN(1,FILE='SALT.RST',STATUS='UNKNOWN') + DO L=2,LA + WRITE(1,912)L,IL(L),JL(L),(SAL(L,K),K=1,KC) + ENDDO + CLOSE(1) + ENDIF + IF(ISCO(2).GE.1.AND.ISTRAN(2).GT.0)THEN + OPEN(1,FILE='TEMP.RST',STATUS='UNKNOWN') + CLOSE(1, STATUS='DELETE') + OPEN(1,FILE='TEMP.RSTO',STATUS='UNKNOWN') + DO L=2,LA + WRITE(1,912)L,IL(L),JL(L),(TEM(L,K),K=1,KC),TEMB(L) + ENDDO + CLOSE(1) + ENDIF + IF(ISDRY.EQ.99)THEN + OPEN(1,FILE='RSTWD.OUT',STATUS='UNKNOWN') + CLOSE(1, STATUS='DELETE') + OPEN(1,FILE='RSTWD.OUT',STATUS='UNKNOWN') + DO L=2,LA + WRITE(1,913)L,IL(L),JL(L),ISCDRY(L),NATDRY(L), + & IMASKDRY(L),SUB(L),SVB(L),SUBO(L),SVBO(L) + ENDDO + CLOSE(1) + ENDIF + ENDIF +C C ** OUTPUT SALINITY AND TEMPATURE DATA ASSIMILATION C - IF(NLCDA.GT.0)THEN +CGEO if(myrank.eq.0)THEN +CGEO print*, n,'FSALASM1',sum(FSALASM) +CGEO print*, n,'FVOLASM1',sum(FVOLASM) +CGEO print*, n,'FTEMASM1',sum(FTEMASM) +CGEO endif +C + IF(NLCDA.GT.0.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='DATAASM.OUT') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='DATAASM.OUT') @@ -344,6 +534,35 @@ C ENDIF 5678 FORMAT(2I6,3E14.5) C + do ns=1,nsed + call collect_in_zero_array_kbm(SEDB(:,:,ns)) + enddo + do ns=1,nsnd + call collect_in_zero_array_kbm(SNDB(:,:,ns)) + enddo + call collect_in_zero_array_kbm(VDRBED) + call collect_in_zero_array_kbm(PORBED) + call collect_in_zero(ZELBEDA) + call collect_in_zero(HBEDA) + call collect_in_zero_array_kbm(HBED) + call collect_in_zero_array_kbm(BDENBED) + call collect_in_zero(BELV) + call collect_in_zero(HP) + do ns=1,nsed + call collect_in_zero_array(SED(:,:,ns)) + enddo + do ns=1,nsnd + call collect_in_zero_array(SND(:,:,ns)) + enddo + do nx=1,nsnd + call collect_in_zero(QSBDLDX(:,nx)) + call collect_in_zero(QSBDLDY(:,nx)) + enddo + do nt=1,ntox + call collect_in_zero_array_kbm(TOXB(:,:,nx)) + enddo +C + IF(MYRANK.EQ.0)THEN IF(ISTRAN(6).GT.0.OR.ISTRAN(7).GT.0.AND. & ISDTXBUG.EQ.1.AND.N.EQ.NTS)THEN OPEN(1,FILE='BEDRST.SED') @@ -480,7 +699,8 @@ C ENDDO CLOSE(1) ENDIF - 339 FORMAT(2I5,6F14.5) + ENDIF +C 339 FORMAT(2I5,6F14.5) 101 FORMAT(2I5,18E13.5) 102 FORMAT(10X,18E13.5) 111 FORMAT(' IL JL SEDBT(K=1,KB)') @@ -506,6 +726,23 @@ C ! { GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 7501 CONTINUE ! IF (IRSTYP.EQ.-20) GOTO 7501 + call collect_in_zero(HP) + call collect_in_zero_array(UHDY2) + call collect_in_zero_array(VHDX2) + call collect_in_zero_array(W2) + call collect_in_zero_array(U) + call collect_in_zero_array(V) + + call collect_in_zero_array(SAL) + call collect_in_zero_array(TEM) + do ns=1,nsed + call collect_in_zero_array(SED(:,:,ns)) + enddo + +CGEO if(myrank.eq.0)THEN +CGEO print*, n,'QCTLT',sum(QCTLT) +CGEO endif + IF(MYRANK.EQ.0)THEN IF (IRSTYP.LE.-20 .AND. ISRESTO.LE.-20) THEN IF(IRSTYP.EQ.-20)THEN OPEN(7510,FILE='EE_HYDRO.OUT',STATUS='UNKNOWN') @@ -572,11 +809,154 @@ C CALL FLUSH(7510) CLOSE(7510,STATUS='KEEP') ENDIF + ENDIF ! } GEOSR WRITE HYDRO FIELD FOR WQ ALONE : JGCHO 2010.11.10 ! { GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.5.23 7502 CONTINUE ! IF (IRSTYP.EQ.-19) GOTO 7502 - IF (IRSTYP.EQ.-19) THEN + call collect_in_zero(HP) + call collect_in_zero(H1P) + call collect_in_zero(HWQ) + call collect_in_zero(H2WQ) + + call collect_in_zero(UHDYE) + call collect_in_zero(UHDY1E) + call collect_in_zero(VHDXE) + call collect_in_zero(VHDX1E) + + call collect_in_zero_array(U) + call collect_in_zero_array(U1) + call collect_in_zero_array(V) + call collect_in_zero_array(V1) + + do k=0,kcm + call collect_in_zero(QQSQR(:,k)) + call collect_in_zero(QQ(:,k)) + call collect_in_zero(QQ1(:,k)) + call collect_in_zero(QQL(:,k)) + call collect_in_zero(QQL1(:,k)) + call collect_in_zero(DML(:,k)) + enddo + + IF(ISCO(1).EQ.1)THEN + call collect_in_zero_array(SAL) + call collect_in_zero_array(SAL1) + ENDIF + IF(ISCO(2).EQ.1)THEN + call collect_in_zero_array(TEM) + call collect_in_zero_array(TEM1) + ENDIF + IF(ISCO(3).EQ.1)THEN + call collect_in_zero_array(DYE) + call collect_in_zero_array(DYE1) + ENDIF + IF(ISCO(4).EQ.1)THEN + call collect_in_zero(SFLSBOT) + call collect_in_zero_array(SFL) + call collect_in_zero_array(SFL2) + ENDIF + IF(ISCO(5).EQ.1)THEN + do nt=1,ntox + call collect_in_zero_array(TOX(:,:,nt)) + call collect_in_zero_array(TOX1(:,:,nt)) + call collect_in_zero_array_kbm(TOXB(:,:,nt)) + call collect_in_zero_array_kbm(TOXB1(:,:,nt)) + enddo + ENDIF + IF(ISCO(6).EQ.1)THEN + do ns=1,nsed + call collect_in_zero_array(SED(:,:,ns)) + call collect_in_zero_array(SED1(:,:,ns)) + call collect_in_zero_array_kbm(SEDB(:,:,ns)) + call collect_in_zero_array_kbm(SEDB1(:,:,ns)) + enddo + ENDIF + IF(ISCO(7).EQ.1)THEN + do ns=1,nsnd + call collect_in_zero_array(SND(:,:,ns)) + call collect_in_zero_array(SND1(:,:,ns)) + call collect_in_zero_array_kbm(SNDB(:,:,ns)) + call collect_in_zero_array_kbm(SNDB1(:,:,ns)) + enddo + ENDIF + IF(ISCO(6).EQ.1.OR.ISCO(7).EQ.1)THEN + call collect_in_zero_array_kbm(HBED) + call collect_in_zero_array_kbm(HBED1) + call collect_in_zero_array_kbm(VDRBED) + call collect_in_zero_array_kbm(VDRBED1) + ENDIF + + call collect_in_zero(QSUME) + call collect_in_zero_array(QSUM) + IF(ISGWIE.GE.1)THEN + call collect_in_zero(AGWELV) + call collect_in_zero(AGWELV1) + ENDIF + + CLOS_TMP=CLOS + CLOW_TMP=CLOW + CLOE_TMP=CLOE + CLON_TMP=CLON + NLOS_TMP=NLOS + NLOW_TMP=NLOW + NLOE_TMP=NLOE + NLON_TMP=NLON + + DO K=1,KCM + DO LL=1,NBBSM + IF(.NOT.ISDOMAIN(LCBS(LL)))THEN + CLOS_TMP(LL,K,1:NSTVM)=0. + NLOS_TMP(LL,K,1:NSTVM)=0 + ENDIF + ENDDO + ENDDO + + DO K=1,KCM + DO LL=1,NBBWM + IF(.NOT.ISDOMAIN(LCBW(LL)))THEN + CLOW_TMP(LL,K,1:NSTVM)=0. + NLOW_TMP(LL,K,1:NSTVM)=0 + ENDIF + ENDDO + ENDDO + + DO K=1,KCM + DO LL=1,NBBEM + IF(.NOT.ISDOMAIN(LCBE(LL)))THEN + CLOE_TMP(LL,K,1:NSTVM)=0. + NLOE_TMP(LL,K,1:NSTVM)=0 + ENDIF + ENDDO + ENDDO + + DO K=1,KCM + DO LL=1,NBBNM + IF(.NOT.ISDOMAIN(LCBN(LL)))THEN + CLON_TMP(LL,K,1:NSTVM)=0. + NLON_TMP(LL,K,1:NSTVM)=0 + ENDIF + ENDDO + ENDDO + + CALL MPI_ALLREDUCE(CLOS_TMP,CLOS,NBBSM*KCM*NSTVM, + & MPI_REAL,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(CLOW_TMP,CLOW,NBBWM*KCM*NSTVM, + & MPI_REAL,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(CLOE_TMP,CLOE,NBBEM*KCM*NSTVM, + & MPI_REAL,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(CLON_TMP,CLON,NBBNM*KCM*NSTVM, + & MPI_REAL,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(NLOS_TMP,NLOS,NBBSM*KCM*NSTVM, + & MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(NLOW_TMP,NLOW,NBBWM*KCM*NSTVM, + & MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(NLOE_TMP,NLOE,NBBEM*KCM*NSTVM, + & MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,IERR) + CALL MPI_ALLREDUCE(NLON_TMP,NLON,NBBNM*KCM*NSTVM, + & MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,IERR) + + IF(MYRANK.EQ.0)THEN + IF(IRSTYP.EQ.-19) THEN WRITE(*,'(A,F10.6,2x,i3.3)')'Restart Snapshot @ Timeday: ' & ,TIMEDAY,NINT(TIMEDAY) @@ -727,7 +1107,7 @@ C WRITE(99,907)(CLON(LL,K,M),K=1,KC) ENDDO ENDDO - ENDIF + ENDIF IF(ISCO(6).EQ.1)THEN DO NT=1,NSED M=MSVSED(NT) @@ -760,7 +1140,7 @@ C WRITE(99,907)(CLON(LL,K,M),K=1,KC) ENDDO ENDDO - ENDIF + ENDIF IF(ISCO(7).EQ.1)THEN DO NT=1,NSND M=MSVSND(NT) @@ -809,9 +1189,23 @@ C ENDDO ENDIF CLOSE(99) + ENDIF + ENDIF C C *** SPECIAL FILES C + call collect_in_zero_array(SAL) + call collect_in_zero_array(TEM) + call collect_in_zero(TEMB) + call collect_in_zero_int(ISCDRY) + call collect_in_zero_int(NATDRY) + call collect_in_zero_int(IMASKDRY) + call collect_in_zero(SUB) + call collect_in_zero(SVB) + call collect_in_zero(SUBO) + call collect_in_zero(SVBO) +C + IF(MYRANK.EQ.0)THEN IF(ISWAVE.GE.1)THEN WRITE(RESTFN,'(A,I3.3,A)') 'WVQWCP',NINT(TIMEDAY),'.OUT' OPEN(1,FILE=TRIM(RESTFN),STATUS='UNKNOWN') @@ -858,9 +1252,37 @@ C ENDDO ENDDO ENDIF - + ENDIF C - IF(ISTRAN(6).GT.0 .OR. ISTRAN(7).GT.0 .AND. + do ns=1,nsed + call collect_in_zero_array_kbm(SEDB(:,:,ns)) + enddo + do ns=1,nsnd + call collect_in_zero_array_kbm(SNDB(:,:,ns)) + enddo + call collect_in_zero_array_kbm(VDRBED) + call collect_in_zero_array_kbm(PORBED) + call collect_in_zero(ZELBEDA) + call collect_in_zero(HBEDA) + call collect_in_zero_array_kbm(HBED) + call collect_in_zero_array_kbm(BDENBED) + call collect_in_zero(BELV) + call collect_in_zero(HP) + do ns=1,nsed + call collect_in_zero_array(SED(:,:,ns)) + enddo + do ns=1,nsnd + call collect_in_zero_array(SND(:,:,ns)) + enddo + do nx=1,nsnd + call collect_in_zero(QSBDLDX(:,nx)) + call collect_in_zero(QSBDLDY(:,nx)) + enddo + do nt=1,ntox + call collect_in_zero_array_kbm(TOXB(:,:,nx)) + enddo + IF(MYRANK.EQ.0)THEN + IF(ISTRAN(6).GT.0 .OR. ISTRAN(7).GT.0 .AND. & ISDTXBUG.EQ.1.AND.N.EQ.NTS)THEN WRITE(RESTFN,'(A,I3.3,A)') 'BEDRST',NINT(TIMEDAY),'.SED' @@ -988,8 +1410,7 @@ C ENDDO CLOSE(1) ENDIF - - ENDIF ! IF (IRSTYP.EQ.-19) THEN + ENDIF ! } GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.5.23 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/ROUT3D.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/ROUT3D.for index 9049a4f41..d871d0e0f 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/ROUT3D.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/ROUT3D.for @@ -3,6 +3,7 @@ C C CHANGE RECORD C USE GLOBAL + USE MPI CHARACTER *12 SALFN,TEMFN,DYEFN,SEDFN,UUUFN,VVVFN,WWWFN, & CMPFN,SNDFN,TOXFN @@ -16,6 +17,7 @@ C C C ** INITIALIZE OUTPUT FILES C + IF(MYRANK.EQ.0)THEN IAD=I3DMAX-I3DMIN+1 JAD=J3DMAX-J3DMIN+1 NRCAL3D=NRCAL3D+1 @@ -1359,12 +1361,12 @@ C ENDIF ENDIF ENDIF - 500 FORMAT(5I5) +C 500 FORMAT(5I5) 501 FORMAT(72I4) 502 FORMAT(I5,F10.4) - 505 FORMAT(8F10.5) - 506 FORMAT(I5,2X,F10.5,5X,I5) - 510 FORMAT(2I5,4(2X,F10.5)) +C 505 FORMAT(8F10.5) +C 506 FORMAT(I5,2X,F10.5,5X,I5) +C 510 FORMAT(2I5,4(2X,F10.5)) 520 FORMAT('IAD = ',I5,' JAD = ',I5//) 521 FORMAT('RSALMAX = ',E12.4,' RSALMIN = ',E12.4/) 522 FORMAT('RTEMMAX = ',E12.4,' RTEMMIN = ',E12.4/) @@ -1379,6 +1381,8 @@ C 551 FORMAT(72F7.1) 559 FORMAT(2I4,2X,72I2) CLOSE(50) + ENDIF + RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSALPLTH.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSALPLTH.for index 11b180c10..a3058eeae 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSALPLTH.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSALPLTH.for @@ -5,10 +5,14 @@ C ** SUBROUTINE RSALPLTH WRITES FILES FOR RESIDUAL SCALAR FIELD C ** CONTOURING IN HORIZONTAL PLANES C USE GLOBAL + USE MPI DIMENSION DBS(10) CHARACTER*80 TITLE DIMENSION CONC(LCM,KCM) + INTEGER LUN + LUN=0 C + IF(MYRANK.EQ.0)THEN IF(JSRSPH(ICON).NE.1) GOTO 300 LINES=LA-1 LEVELS=2 @@ -301,13 +305,14 @@ C ENDIF ENDIF CLOSE(LUN) + ENDIF 99 FORMAT(A80) 100 FORMAT(I10,F12.4) 101 FORMAT(2I10) 200 FORMAT(2I5,1X,6E14.6) 250 FORMAT(12E12.4) 400 FORMAT(1X,6E14.6) - 420 FORMAT(1X,13E11.3) +C 420 FORMAT(1X,13E11.3) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSALPLTV.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSALPLTV.for index 0d8d040d4..74b890ca9 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSALPLTV.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSALPLTV.for @@ -8,13 +8,15 @@ C C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP? USE GLOBAL - CHARACTER*80 TITLE1,TITLE2,TITLE3,TITLE5 + USE MPI + CHARACTER*80 TITLE1,TITLE2,TITLE3 REAL,SAVE,ALLOCATABLE,DIMENSION(:)::ABTMP IF(.NOT.ALLOCATED(ABTMP))THEN ALLOCATE(ABTMP(KCM)) ABTMP=0.0 ENDIF C + IF(MYRANK.EQ.0)THEN IF(ITMP.EQ.2) RETURN IF(ITMP.EQ.3) RETURN IF(ITMP.EQ.4) RETURN @@ -504,6 +506,7 @@ C 101 FORMAT(2I10) 200 FORMAT(2I5,1X,6E14.6) 250 FORMAT(12E12.4) + ENDIF RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSMICI.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSMICI.for index 752df6068..d09ef55bf 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSMICI.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSMICI.for @@ -4,6 +4,7 @@ C CHANGE RECORD C READ IN SPATIALLY AND/OR TEMPORALLY VARYING ICS (UNIT INSMICI). C USE GLOBAL + USE MPI CHARACTER TITLE(3)*79,ICICONT*3 REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XSMPOC @@ -19,28 +20,34 @@ C XSMPOP=0.0 ENDIF C - PRINT *,'WQ: SD READING WQSDICI.INP' + IF(MYRANK.EQ.0) PRINT *,'WQ: SD READING WQSDICI.INP' OPEN(1,FILE='WQSDICI.INP',STATUS='OLD') OPEN(2,FILE='WQ3D.OUT',STATUS='UNKNOWN',POSITION='APPEND') IF(ISMTICI.EQ.0)THEN READ(1,50) (TITLE(M),M=1,3) + IF(MYRANK.EQ.0)THEN WRITE(2,999) WRITE(2,50) (TITLE(M),M=1,3) ENDIF - WRITE(2,60)'* INITIAL CONDITIONS AT ', ISMTICI, - & ' TH DAY FROM MODEL START' + ENDIF READ(1,999) READ(1,50) TITLE(1) + IF(MYRANK.EQ.0)THEN + WRITE(2,60)'* INITIAL CONDITIONS AT ', ISMTICI, + & ' TH DAY FROM MODEL START' WRITE(2,50) TITLE(1) + ENDIF DO M=2,LA READ(1,*) I,J,(XSMPON(NW),NW=1,NSMG), & (XSMPOP(NW),NW=1,NSMG),(XSMPOC(NW),NW=1,NSMG),XSM1NH4, & XSM2NH4,XSM2NO3,XSM2PO4,XSM2H2S,XSMPSI,XSM2SI,XSMBST,XSMT + IF(MYRANK.EQ.0)THEN WRITE(2,90) I,J,(XSMPON(NW),NW=1,NSMG), & (XSMPOP(NW),NW=1,NSMG),(XSMPOC(NW),NW=1,NSMG),XSM1NH4, & XSM2NH4,XSM2NO3,XSM2PO4,XSM2H2S,XSMPSI,XSM2SI,XSMBST,XSMT + ENDIF IF(IJCT(I,J).LT.1 .OR. IJCT(I,J).GT.8)THEN - PRINT*, 'I, J, LINE# = ', I,J,M-1 + IF(MYRANK.EQ.0) PRINT*, 'I, J, LINE# = ', I,J,M-1 STOP 'ERROR!! INVALID (I,J) IN FILE WQSDICI.INP' ENDIF L=LIJ(I,J) @@ -60,17 +67,19 @@ C SMT(L) =XSMT ENDDO READ(1,52) ISMTICI, ICICONT + IF(MYRANK.EQ.0)THEN WRITE(2,52) ISMTICI, ICICONT + ENDIF IF(ICICONT.EQ.'END')THEN CLOSE(1) ISMICI = 0 ENDIF - CLOSE(2) + IF(MYRANK.EQ.0) CLOSE(2) 999 FORMAT(1X) 50 FORMAT(A79) 52 FORMAT(I7, 1X, A3) 60 FORMAT(/, A24, I5, A24) - 84 FORMAT(3I5, 20F8.4, F8.2) +C 84 FORMAT(3I5, 20F8.4, F8.2) 90 FORMAT(2I5, 18E12.4) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSMRST.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSMRST.for index ba4cc9686..354873c0d 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSMRST.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSMRST.for @@ -4,6 +4,7 @@ C CHANGE RECORD C READ ICS FROM RESTART FILE FROM INSMRST. C USE GLOBAL + USE MPI LOGICAL FEXIST C C CHECK FIRST TO SEE IF BINARY RESTART FILE EXISTS. IF NOT, USE @@ -11,7 +12,7 @@ C THE ASCII FILE INSTEAD. C INQUIRE(FILE='WQSDRST.BIN', EXIST=FEXIST) IF(.NOT. FEXIST)THEN - PRINT *,'WQ: READING WQSDRST.INP' + IF(MYRANK.EQ.0) PRINT *,'WQ: READING WQSDRST.INP' OPEN(1,FILE='WQSDRST.INP',STATUS='UNKNOWN') READ(1,999) READ(1,999) @@ -23,7 +24,7 @@ C ENDDO CLOSE(1) ELSE - PRINT *,'WQ: READING WQSDRST.BIN' + IF(MYRANK.EQ.0) PRINT *,'WQ: READING WQSDRST.BIN' OPEN(UNIT=1, FILE='WQSDRST.BIN', & FORM='UNFORMATTED', STATUS='UNKNOWN') READ(1) NN_, XTIME @@ -40,7 +41,7 @@ C ENDDO CLOSE(1) ENDIF - 90 FORMAT(I5, 18E12.4) +C 90 FORMAT(I5, 18E12.4) 999 FORMAT(1X) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSURFPLT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSURFPLT.for index b775c64ef..b1d5518cf 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSURFPLT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RSURFPLT.for @@ -5,7 +5,9 @@ C ** SUBROUTINE SURFPLT WRITES FILES TO CONTOUR FREE SURFACE C ** ELEVATION C USE GLOBAL + USE MPI CHARACTER*80 TITLE + IF(MYRANK.EQ.0)THEN IF(JSRPPH.NE.1) GOTO 300 OPEN(10,FILE='RSURFCN.OUT',STATUS='UNKNOWN') CLOSE(10,STATUS='DELETE') @@ -33,9 +35,10 @@ C WRITE(10,200)IL(L),JL(L),DLON(L),DLAT(L),SURFEL ENDDO CLOSE(10) + ENDIF 99 FORMAT(A80) 100 FORMAT(I10,F12.4) - 101 FORMAT(2I10) +C 101 FORMAT(2I10) 200 FORMAT(2I5,1X,6E14.6) 250 FORMAT(12E12.4) RETURN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RVELPLTH.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RVELPLTH.for index 6ec789c77..c69a56c81 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RVELPLTH.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RVELPLTH.for @@ -7,12 +7,14 @@ C C *** PMC THIS ROUTINE USES HMP, THE STATIC IC DEPTH. SHOULDN'T IT USE HP? USE GLOBAL + USE MPI DIMENSION DBS(10) CHARACTER*80 TITLE1,TITLE2,TITLE3 IF(JSRVPH.NE.1) GOTO 300 C C ** WRITE HEADINGS C + IF(MYRANK.EQ.0)THEN TITLE1='HORIZ EULERIAN MEAN TRANSPORT VELOCITY' TITLE2='HORIZ VECTOR POTENTIAL TRANSPORT VELOCITY' TITLE3='HORIZ MEAN MASS TRANSPORT VELOCITY' @@ -44,7 +46,9 @@ C CLOSE(12) CLOSE(13) JSRVPH=0 + ENDIF 300 CONTINUE + IF(MYRANK.EQ.0)THEN IF(ISDYNSTP.EQ.0)THEN TIME=DT*FLOAT(N)+TCON*TBEGIN TIME=TIME/TCON @@ -91,6 +95,7 @@ C CLOSE(11) CLOSE(12) CLOSE(13) + ENDIF 99 FORMAT(A80) 100 FORMAT(I10,F12.4) 101 FORMAT(2I10) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RVELPLTV.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RVELPLTV.for index 3c9c52b7b..15c17259b 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RVELPLTV.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RVELPLTV.for @@ -6,6 +6,7 @@ C ** OF VELOCITY NORMAL TO AN ARBITARY SEQUENCE OF (I,J) POINTS AND C ** AND VERTICAL PLANE TANGENTIAL-VERTICAL VELOCITY VECTORS C USE GLOBAL + USE MPI CHARACTER*80 TITLE10,TITLE20,TITLE30 CHARACTER*80 TITLE40,TITLE50,TITLE60 @@ -21,6 +22,7 @@ C REAL,ALLOCATABLE,DIMENSION(:,:)::RLVELT REAL,ALLOCATABLE,DIMENSION(:,:)::RLW C + IF(MYRANK.EQ.0)THEN ALLOCATE(RVELN(KCM,100)) ALLOCATE(RVELT(KCM,100)) ALLOCATE(RW(KCM,100)) @@ -556,6 +558,7 @@ C 101 FORMAT(2I10) 200 FORMAT(2I5,1X,6E14.6) 250 FORMAT(12E12.4) + ENDIF RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQAGR.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQAGR.for index aab1728aa..7685e43a0 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQAGR.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQAGR.for @@ -6,28 +6,33 @@ C GROWTH, RESP. & PREDATION RATES, AND BASE LIGHT EXTINCT. COEFF. C (UNIT INWQAGR). C USE GLOBAL + USE MPI CHARACTER TITLE(3)*79, AGRCONT*3 OPEN(7890,FILE=AGRFN,STATUS='UNKNOWN') open(7891,FILE='WQALGGX.INP',STATUS='UNKNOWN') + IF(MYRANK.EQ.0)THEN OPEN(2,FILE='WQ3D.OUT',STATUS='UNKNOWN',POSITION='APPEND') + ENDIF IF(AGRDAY.EQ.0)THEN READ(7890,50) (TITLE(M),M=1,3) - WRITE(2,999) - WRITE(2,50) (TITLE(M),M=1,3) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,50) (TITLE(M),M=1,3) ! Also write X-species if present if (NXSP.gt.0) then READ(7891,50) (TITLE(M),M=1,3) - write(2,*) '%%%% X-Species START %%%%' - WRITE(2,50) (TITLE(M),M=1,3) - write(2,*) '%%%% X-Species END %%%%' + IF(MYRANK.EQ.0) WRITE(2,*) '%%%% X-Species START %%%%' + IF(MYRANK.EQ.0) WRITE(2,50) (TITLE(M),M=1,3) + IF(MYRANK.EQ.0) WRITE(2,*) '%%%% X-Species END %%%%' endif ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,60)'* ALGAL KINETIC VALUE AT', TIMTMP, ! GEOSR DAY read jgcho 2016.10.06 & ' TH DAY FROM MODEL START' + ENDIF READ(7890,999) READ(7890,50) TITLE(1) - WRITE(2,50) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,50) TITLE(1) DO I=1,IWQZ C C READ(1,51) MM,WQPMC(I),WQPMD(I),WQPMG(I),WQBMRC(I), @@ -35,39 +40,41 @@ C READ(7890,*) MM, WQPMC(I),WQPMD(I),WQPMG(I),WQPMM(I),WQBMRC(I), & WQBMRD(I),WQBMRG(I),WQBMRM(I),WQPRRC(I),WQPRRD(I), & WQPRRG(I),WQPRRM(I),WQKEB(I) + IF(MYRANK.EQ.0)THEN WRITE(2,51) MM, WQPMC(I),WQPMD(I),WQPMG(I),WQPMM(I),WQBMRC(I), & WQBMRD(I),WQBMRG(I),WQBMRM(I),WQPRRC(I),WQPRRD(I), & WQPRRG(I),WQPRRM(I),WQKEB(I) + ENDIF ENDDO READ(7890,*) AGRDAY, AGRCONT - WRITE(2,*) AGRDAY, AGRCONT + IF(MYRANK.EQ.0) WRITE(2,*) AGRDAY, AGRCONT ! Repeat for x-species if present if (NXSP.gt.0) then - WRITE(2,*) '%%%% X-Species START %%%%' - WRITE(2,60)'* ALGAL KINETIC VALUE AT', TIMTMP, + IF(MYRANK.EQ.0) WRITE(2,*) '%%%% X-Species START %%%%' + IF(MYRANK.EQ.0) WRITE(2,60)'* ALGAL KINETIC VALUE AT', TIMTMP, & ' TH DAY FROM MODEL START' READ(7891,999) READ(7891,50) TITLE(1) DO I=1,IWQZ READ(7891,*) MM, (WQPMX(I,nsp),nsp=1,NXSP) & ,(WQBMRX(I,nsp),nsp=1,NXSP),(WQPRRX(I,nsp),nsp=1,NXSP) - WRITE(2,51) MM, (WQPMX(I,nsp),nsp=1,NXSP) + IF(MYRANK.EQ.0) WRITE(2,51) MM, (WQPMX(I,nsp),nsp=1,NXSP) & ,(WQBMRX(I,nsp),nsp=1,NXSP),(WQPRRX(I,nsp),nsp=1,NXSP) ENDDO READ(7891,*) AGRDAY, AGRCONT - WRITE(2,*) AGRDAY, AGRCONT - write(2,*) '%%%% X-Species END %%%%' + IF(MYRANK.EQ.0) WRITE(2,*) AGRDAY, AGRCONT + IF (MYRANK.EQ.0) write(2,*) '%%%% X-Species END %%%%' endif IF(AGRCONT.EQ.'END')THEN CLOSE(7890) if (NXSP.gt.0) CLOSE(7891) IWQAGR = 0 ENDIF - CLOSE(2) + IF(MYRANK.EQ.0) CLOSE(2) 999 FORMAT(1X) 50 FORMAT(A79) 51 FORMAT(I8, 100F8.3) ! Note, this might need some attention - 52 FORMAT(I7, 1X, A3) +C 52 FORMAT(I7, 1X, A3) 60 FORMAT(/, A24, F5.1, A24) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQATM.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQATM.for index 50005ca47..17e208a12 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQATM.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQATM.for @@ -6,6 +6,7 @@ C ** FOR THE 22 STATE VARIABLES MULTIPLIED BY THE RAINFALL FLOW RATE !VB CHANG C ** ENTERING EACH GRID CELL. COMPUTED LOADS ARE IN G/DAY. C USE GLOBAL + USE MPI C C CV2 = CONVERSION TO GET UNITS OF G/DAY C WQATM(NW) HAS UNITS OF MG/L @@ -20,6 +21,7 @@ C WQATML(L,KC,NW)=WQATM(NW)*RAINT(L)*DXYP(L)*CV2 ENDDO ENDDO + IF(MYRANK.EQ.0)THEN IF(ITNWQ.EQ.0.AND.DEBUG)THEN OPEN(1,FILE='WQATM.DIA',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') @@ -35,6 +37,7 @@ C ENDDO CLOSE(1) ENDIF + ENDIF 110 FORMAT(1X,2I4,2X,1P,7E11.3,/,15X,7E11.3,/,15X,7E11.3) 112 FORMAT('# WET ATMOSPHERIC DEPOSITION DIAGNOSTIC FILE',/, & ' N, TIME = ', I10, F12.5/) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQATM_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQATM_mpi.for new file mode 100644 index 000000000..bf1669b8e --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQATM_mpi.for @@ -0,0 +1,47 @@ + SUBROUTINE RWQATM_mpi +C +C CHANGE RECORD +C ** COMPUTES WET ATMOSPHERIC DEPOSITION USING CONSTANT CONCENTRATIONS +C ** FOR THE 22 STATE VARIABLES MULTIPLIED BY THE RAINFALL FLOW RATE !VB CHANGED 21 TO 22 +C ** ENTERING EACH GRID CELL. COMPUTED LOADS ARE IN G/DAY. +C + USE GLOBAL + USE MPI +C +C CV2 = CONVERSION TO GET UNITS OF G/DAY +C WQATM(NW) HAS UNITS OF MG/L +C RAINT(L) HAS UNITS OF M/SEC +C DXYP(L) HAS UNITS OF M2 +C WQATML(L,KC,NW) HAS UNITS OF G/DAY +C + + CV2=86400.0 + DO NW=1,NWQV +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQATML(L,KC,NW)=WQATM(NW)*RAINT(L)*DXYP(L)*CV2 + ENDDO + ENDDO + IF(MYRANK.EQ.0)THEN + IF(ITNWQ.EQ.0.AND.DEBUG)THEN + OPEN(1,FILE='WQATM.DIA',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='WQATM.DIA',STATUS='UNKNOWN') + IF(ISDYNSTP.EQ.0)THEN + TIME=(DT*FLOAT(N)+TCON*TBEGIN)/86400. + ELSE + TIME=TIMESEC/86400. + ENDIF + WRITE(1,112) N,TIME + DO L=2,LA + WRITE(1,110) IL(L),JL(L),(WQATML(L,KC,NW),NW=1,NWQV) + ENDDO + CLOSE(1) + ENDIF + ENDIF + 110 FORMAT(1X,2I4,2X,1P,7E11.3,/,15X,7E11.3,/,15X,7E11.3) + 112 FORMAT('# WET ATMOSPHERIC DEPOSITION DIAGNOSTIC FILE',/, + & ' N, TIME = ', I10, F12.5/) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQBEN2.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQBEN2.for index 2e4d5122e..f89a24d4e 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQBEN2.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQBEN2.for @@ -15,6 +15,7 @@ C 350.00000 <-- DAY AT WHICH FOLLOWING FLUXES BECOME ACTIVE C 9999.99999 <-- ENTER LARGE DAY AT END OF FILE C USE GLOBAL + USE MPI CHARACTER TITLE(3)*79, CCMRM*1 INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::IZONE @@ -24,6 +25,8 @@ C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XBFO2 REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XBFPO4D REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XBFSAD + INTEGER IZA + IZA=0 IF(.NOT.ALLOCATED(IZONE ))THEN ALLOCATE(IZONE(NSMZM)) @@ -43,21 +46,36 @@ C ENDIF C OPEN(1,FILE=BENFN,STATUS='UNKNOWN') + IF(MYRANK.EQ.0)THEN OPEN(2,FILE='WQ3D.OUT',STATUS='UNKNOWN',POSITION='APPEND') + ENDIF C C SKIP OVER THREE HEADER RECORDS: C READ(1,50) (TITLE(M),M=1,3) - WRITE(2,999) - WRITE(2,50) (TITLE(M),M=1,3) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,50) (TITLE(M),M=1,3) C C SKIP OVER ALL COMMENT CARDS AT BEGINNING OF FILE: C REWIND(1) CCMRM = '#' CALL SKIPCOMM(1, CCMRM) - READ(1, *) IBENZ - WRITE(2, 65) TIMTMP, IBENZ + READ(1, *) IBENZ +!{ GEOSR BENTHIC FLUX FOR ANOXIC ENV : YSSONG 2015.09.08 + IF(IBENZ.LT.NSMZ)THEN + IF(MYRANK.EQ.0) WRITE(*,*) 'ERROR : IBENZ(WQBENFLX.INP) + & SHOLUD BE LESS THAN NSMZ WQ3DWC.INP' + PRINT *, "Application suspended. Hit ENTER to continue" + READ(*,*) + ENDIF + IF(IWQBENOX.NE.0.AND.IBENZ.LT.3)THEN + IF(MYRANK.EQ.0) WRITE(*,*) 'ERROR : IBENZ(WQBENFLX.INP) + & MUST BE 3' + PRINT *, "Application suspended. Hit ENTER to continue" + READ(*,*) + ENDIF + IF(MYRANK.EQ.0) WRITE(2, 65) TIMTMP, IBENZ 65 FORMAT(' * BENTHIC FLUXES AT ', F10.5,' DAYS OF MODEL RUN',/, & ' NUMBER OF BENTHIC FLUX ZONES = ', I4) C @@ -78,20 +96,23 @@ C C C UNEXPECTED END-OF-FILE ENCOUNTERED: C - 15 WRITE(2,16) BENFN + 15 CONTINUE + IF(MYRANK.EQ.0) WRITE(2,16) BENFN 16 FORMAT(//,' ************* WARNING *************',/, & ' END-OF-FILE ENCOUNTERED IN FILE: ', A20,/,/ & ' BENTHIC FLUXES SET TO VALUES CORRESPONDING ', & ' TO LAST DAY IN FILE.',/) BENDAY=(TCON*TBEGIN + NTC*TIDALP)/86400.0 ! *** PMC SINGLE LINE 20 CONTINUE - WRITE(2, 48) BDAY + IF(MYRANK.EQ.0) WRITE(2, 48) BDAY 48 FORMAT(/,' DAY IN BENTHIC FLUX FILE: ',F10.5,/, & ' ZONE FPO4 FNH4 FNO3 FSAD FCOD FSOD') DO I=1,IBENZ MM = IZONE(I) + IF(MYRANK.EQ.0) THEN WRITE(2,51) MM,XBFPO4D(MM),XBFNH4(MM),XBFNO3(MM),XBFSAD(MM), & XBFCOD(MM),XBFO2(MM) + ENDIF ENDDO C C DETERMINE BENTHIC FLUX FOR EACH CELL (L) BY INTERPOLATING BETWEEN @@ -101,21 +122,36 @@ C DO L=2,LA IZM = IBENMAP(L,1) IZS = IBENMAP(L,2) + IF(IWQBENOX.NE.0) IZA = IBENMAP(L,3) !{ GEOSR BENTHIC FLUX FOR ANOXIC ENV : YSSONG 2015.09.08 XM = XBENMUD(L) - WQBFPO4D(L) = XM*XBFPO4D(IZM) + (1.0-XM)*XBFPO4D(IZS) - WQBFNH4(L) = XM*XBFNH4(IZM) + (1.0-XM)*XBFNH4(IZS) - WQBFNO3(L) = XM*XBFNO3(IZM) + (1.0-XM)*XBFNO3(IZS) - WQBFSAD(L) = XM*XBFSAD(IZM) + (1.0-XM)*XBFSAD(IZS) - WQBFCOD(L) = XM*XBFCOD(IZM) + (1.0-XM)*XBFCOD(IZS) - WQBFO2(L) = XM*XBFO2(IZM) + (1.0-XM)*XBFO2(IZS) +C WQBFPO4D(L) = XM*XBFPO4D(IZM) + (1.0-XM)*XBFPO4D(IZS) !{ GEOSR BENTHIC FLUX FOR ANOXIC ENV : YSSONG 2015.09.08 +C WQBFNH4(L) = XM*XBFNH4(IZM) + (1.0-XM)*XBFNH4(IZS) +C WQBFNO3(L) = XM*XBFNO3(IZM) + (1.0-XM)*XBFNO3(IZS) +C WQBFSAD(L) = XM*XBFSAD(IZM) + (1.0-XM)*XBFSAD(IZS) +C WQBFCOD(L) = XM*XBFCOD(IZM) + (1.0-XM)*XBFCOD(IZS) +C WQBFO2(L) = XM*XBFO2(IZM) + (1.0-XM)*XBFO2(IZS) + WQBFOXPO4D(L,1) = XM*XBFPO4D(IZM) + (1.0-XM)*XBFPO4D(IZS) !{ GEOSR BENTHIC FLUX FOR ANOXIC ENV : YSSONG 2015.09.08 + WQBFOXNH4(L,1) = XM*XBFNH4(IZM) + (1.0-XM)*XBFNH4(IZS) + WQBFOXNO3(L,1) = XM*XBFNO3(IZM) + (1.0-XM)*XBFNO3(IZS) + WQBFOXSAD(L,1) = XM*XBFSAD(IZM) + (1.0-XM)*XBFSAD(IZS) + WQBFOXCOD(L,1) = XM*XBFCOD(IZM) + (1.0-XM)*XBFCOD(IZS) + WQBFOXO2(L,1) = XM*XBFO2(IZM) + (1.0-XM)*XBFO2(IZS) + IF(IWQBENOX.NE.0)THEN + WQBFOXPO4D(L,2) = XBFPO4D(IZA) + WQBFOXNH4(L,2) = XBFNH4(IZA) + WQBFOXNO3(L,2) = XBFNO3(IZA) + WQBFOXSAD(L,2) = XBFSAD(IZA) + WQBFOXCOD(L,2) = XBFCOD(IZA) + WQBFOXO2(L,2) = XBFO2(IZA) + ENDIF ENDDO CLOSE(1) - CLOSE(2) + IF(MYRANK.EQ.0)CLOSE(2) 999 FORMAT(1X) 50 FORMAT(A79) 51 FORMAT(I8, 10F8.3) - 52 FORMAT(I7, 1X, A3) - 60 FORMAT(/, A24, I5, A24) +C 52 FORMAT(I7, 1X, A3) +C 60 FORMAT(/, A24, I5, A24) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.for index 351d0f673..55940a6b7 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.for @@ -6,12 +6,14 @@ C: I/O CONTROL VARIABLES C: SPATIALLY AND TEMPORALLY CONSTANT REAL PARAMETERS C USE GLOBAL + USE MPI C IMPLICIT NONE C PARAMETER (CONV1=1.0E3,CONV2=8.64E4) PMC Single Line CHARACTER TITLE(5)*79, CCMRM*1 CHARACTER LINE*255 + CHARACTER FMTSTR*80 REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XDSL REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XPSL REAL WQTDTEMP(1000),CONV1,CONV2,WQDIUDT,XC,XP,XPC,XPD,XPG @@ -30,7 +32,7 @@ C PARAMETER (CONV1=1.0E3,CONV2=8.64E4) PMC Single Line REAL XMRM1, XMRM2, XMRM3,XMRM4,XMRMA,XMRMB,XMRMC,XMRMD, ! MACROALGAE & XMRME REAL XPSQ,XDSQ,XMUD - INTEGER M,N1,II,JJ,KK,M1,NT,ISSKIP,NW,ND,LF,LL,L,nsp + INTEGER M,N1,II,JJ,KK,NT,ISSKIP,NW,ND,LF,LL,L,nsp INTEGER IWQDT,IWQKIN,ITMP,IZ,IN,IJKC,IWQZX,IZMUD,IZSAND INTEGER IZANOX,MDUM ! Variables for benthic flux for anoxic env INTEGER I,J,K @@ -40,7 +42,6 @@ C PARAMETER (CONV1=1.0E3,CONV2=8.64E4) PMC Single Line REAL WQKGX1(NXSP),WQKGX2(NXSP),WQKGPX1(NXSP) ! C05 in WQ3DWC2.INP & ,WQKGPX2(NXSP) REAL WQTRX(NXSP),WQKTBX(NXSP) ! C06 in WQ3DWC2.INP - REAL XWQVX(NXSP) CHARACTER*80 FLN integer iww(100),jww(100) C @@ -53,9 +54,11 @@ C XPSL=0.0 ENDIF - - OPEN(2,FILE='WQ3D.OUT',STATUS='UNKNOWN',POSITION='APPEND') - PRINT *,'WQ: READING WQ3DWC.INP - MAIN WATER QUALITY CONTROL FILE' + IF(MYRANK.EQ.0)THEN + OPEN(2,FILE='WQ3D.OUT',STATUS='UNKNOWN',POSITION='APPEND') ! GEOSR jgcho 2015.9.10 + ENDIF + IF(MYRANK.EQ.0) PRINT *, + & 'WQ: READING WQ3DWC.INP - MAIN WATER QUALITY CONTROL FILE' OPEN(1,FILE='WQ3DWC.INP',STATUS='UNKNOWN') C C READ FIRST LINE IN WQ3DWC.INP FILE. IF FIRST CHARACTER IS '#', THEN @@ -72,29 +75,29 @@ C CCMRM = '#' IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) (TITLE(M), M=1,3) - WRITE(2,90) (TITLE(M), M=1,3) + IF(MYRANK.EQ.0) WRITE(2,90) (TITLE(M), M=1,3) C C I/O CONTROL VARIABLES C READ(1,999) C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,90) TITLE(1) - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) ISWQLVL,NWQV,NWQZ,NWQPS,NWQTD,NWQTS,NTSWQV,NSMG,NSMZ, & NTSSMV,NSMTS,NWQKDPT - WRITE(2,*) ISWQLVL,NWQV,NWQZ,NWQPS,NWQTD,NWQTS,NTSWQV,NSMG,NSMZ, - & NTSSMV,NSMTS,NWQKDPT + IF(MYRANK.EQ.0) WRITE(2,*) ISWQLVL,NWQV,NWQZ,NWQPS,NWQTD,NWQTS, + & NTSWQV,NSMG,NSMZ,NTSSMV,NSMTS,NWQKDPT IF(ISWQLVL.LT.0.OR.ISWQLVL.GT.4)STOP 'BAD KINETICS OPTION' ! *** PMC C *** C02A ! *** ONLY USED WHEN ISWQLVL=1-3 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) (ISTRWQ(NW),NW=1,NWQV) - WRITE(2,*) (ISTRWQ(NW),NW=1,NWQV) + IF(MYRANK.EQ.0) WRITE(2,*) (ISTRWQ(NW),NW=1,NWQV) IF(ISWQLVL.EQ.0)THEN DO NW=1,NWQV ISTRWQ(NW)=0 @@ -108,36 +111,45 @@ C *** C03 IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) IWQDT,IWQM,IWQBEN,IWQSI,IWQFCB,IWQSRP,IWQSTOX, & IWQKA(1), IWQVLIM - WRITE(2,*) IWQDT,IWQM,IWQBEN,IWQSI,IWQFCB,IWQSRP,IWQSTOX, - & IWQKA(1), IWQVLIM + IF(MYRANK.EQ.0) WRITE(2,*) IWQDT,IWQM,IWQBEN,IWQSI,IWQFCB, + & IWQSRP,IWQSTOX,IWQKA(1), IWQVLIM C *** C04 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) IWQZ,IWQNC,IWQRST,NDMWQ,LDMWQ,NDDOAVG,NDLTAVG,IDNOTRVA + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQZ,IWQNC,IWQRST,NDMWQ,LDMWQ,NDDOAVG,NDLTAVG,IDNOTRVA + ENDIF C *** C05 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) IWQICI,IWQAGR,IWQSTL,IWQSUN,IWQPSL,IWQNPL, ISDIURDO, & WQDIUDT, IWQKIN + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQICI,IWQAGR,IWQSTL,IWQSUN,IWQPSL,IWQNPL, ISDIURDO, & WQDIUDT, IWQKIN + ENDIF IWQDIUDT = NINT(WQDIUDT*3600.0/DT) + IF(MYRANK.EQ.0)THEN WRITE(2,83)': FREQUENCY OF DIURNAL DO OUTPUT (IN DT UNIT) =', & IWQDIUDT WRITE(2,83)'* IWQDT (DTWQ(D) = DT(S)*IWQDT/86400) = ', & IWQDT + ENDIF DTD = DT/86400.0 C DTWQ = DTD*REAL(IWQDT)*REAL(NWQKDPT) PMC DTWQ = DTD*REAL(NWQKDPT) DTWQO2 = DTWQ*0.5 !IF(IWQM.EQ.1)THEN + IF(MYRANK.EQ.0)THEN WRITE(2,80)'* FULL VERSION WITH 21 VARIABLES IS ACTIVATED ' + ENDIF !ELSE IF(IWQM.EQ.2)THEN !STOP 'SMALL VERSION WITH 9 VARIABLES IS NOT OPERATIONAL, STOPPING' !ELSE !STOP '** ERROR!!! INVALID IWQM VALUE **' !ENDIF + IF(MYRANK.EQ.0)THEN IF(IWQBEN.EQ.1)THEN WRITE(2,80)'* SEDIMENT PROCESS MODEL IS ACTIVATED ' ELSE IF(IWQBEN.EQ.0)THEN @@ -243,13 +255,16 @@ C DTWQ = DTD*REAL(IWQDT)*REAL(NWQKDPT) PMC WRITE(2,80)'* FILE KINETICS.INP NOT USED ' ENDIF WRITE(2,999) + ENDIF C *** C06 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) IWQTS,TWQTSB,TWQTSE,WQTSDT, ISWQAVG, ISWQMIN, ISWQMAX, & ISCOMP + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQTS,TWQTSB,TWQTSE,WQTSDT, ISWQAVG, ISWQMIN, ISWQMAX, & ISCOMP + ENDIF C C ISWQAVG > 0 TURNS ON BINARY FILE OUTPUT FOR WQ DAILY AVERAGES C ISWQMIN > 0 TURNS ON BINARY FILE OUTPUT FOR WQ DAILY MINIMUMS @@ -261,13 +276,16 @@ C IF(ISCOMP .GT. 0)THEN CALL WQZERO3 C CALL INITBIN3 - CALL INITBIN5 + IF(MYRANK.EQ.0) CALL INITBIN5 !} ENDIF IF(IWQTS.GT.NWQTS)THEN + IF(MYRANK.EQ.0)THEN WRITE(2,80)'** IWQTS SHOULD BE <= NWQTS ** ' + ENDIF IWQTS=NWQTS ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,84) & '* TIME-SERIES OUTPUT FROM ', TWQTSB, ' DAY ', & ' TO ', TWQTSE, ' DAY ', @@ -278,6 +296,7 @@ C CALL INITBIN3 & ' BIN FILE SWITCH ISWQMAX =', ISWQMAX,' (0=OFF) ', & ' BIN FILE SWITCH ISCOMP =', ISCOMP, ' (0=OFF) ' WRITE(2,999) + ENDIF C *** C07 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) @@ -285,16 +304,19 @@ C *** C07 READ(1,90) TITLE(M) ENDDO IF(IWQTS.GE.1)THEN + IF(MYRANK.EQ.0)THEN WRITE(2,80)': ICWQTS(I)=1, TIME-SERIES OUTPUT FOR VARIABLE I ' WRITE(2,80)': ICWQTS(I)\=1, NO TIME-SERIES OUTPUT FOR VAR. I ' WRITE(2,999) DO M=1,2 WRITE(2,90) TITLE(M) ENDDO + ENDIF DO M=1,IWQTS READ(1,*) II,JJ,(ICWQTS(NW,M),NW=1,13) + READ(1,*) (ICWQ TS(NW,M),NW=14,NTSWQV),ICWQTS(IDNOTRVA,M) + IF(MYRANK.EQ.0)THEN WRITE(2,*) II,JJ,(ICWQTS(NW,M),NW=1,13) - READ(1,*) (ICWQTS(NW,M),NW=14,NTSWQV),ICWQTS(IDNOTRVA,M) WRITE(2,*) (ICWQTS(NW,M),NW=14,NTSWQV),ICWQTS(IDNOTRVA,M) IF(IJCT(II,JJ).LT.1 .OR. IJCT(II,JJ).GT.8)THEN WRITE(2,86) II,JJ,M @@ -303,6 +325,8 @@ C *** C07 ENDIF LWQTS(M)=LIJ(II,JJ) WRITE(2,94) II,JJ,(ICWQTS(NW,M),NW=1,NTSWQV+1) + ENDIF +! GEOSR X jgcho 2016.02.18 iww(M)=II jww(M)=JJ ENDDO @@ -310,6 +334,7 @@ C *** C07 IWQTSB = NINT(TWQTSB/DTD) IWQTSE = NINT(TWQTSE/DTD) IWQTSDT = NINT(WQTSDT*3600.0/DT) + IF(MYRANK.EQ.0)THEN WRITE(2,999) WRITE(2,83)': TIME-SERIES STARTING TIME STEP (IN DT UNIT) =', & IWQTSB @@ -317,13 +342,14 @@ C *** C07 & IWQTSE WRITE(2,83)': FREQUENCY OF TS OUTPUT (IN DT UNIT) =', & IWQTSDT + ENDIF C PMC IF(MOD(IWQTSDT,IWQDT).NE.0) C PMC & STOP 'ERROR!! IWQTSDT SHOULD BE MULTIPLE OF IWQDT' 999 FORMAT(1X) 90 FORMAT(A79) - 91 FORMAT(10I8) - 92 FORMAT(10F8.4) - 93 FORMAT(I8,3F8.4) +C 91 FORMAT(10I8) +C 92 FORMAT(10F8.4) +C 93 FORMAT(I8,3F8.4) 94 FORMAT(2I5, 13I5, /, 10X, 9I5) 95 FORMAT(A254) 80 FORMAT(A50) @@ -336,23 +362,29 @@ C C CONSTANT PARAMETERS FOR ALGAE (SEE TABLE 3-1) C8 C + IF(MYRANK.EQ.0)THEN WRITE(2,999) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2,90) TITLE(1) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQKHNC,WQKHND,WQKHNG,WQKHNM,WQKHPC,WQKHPD,WQKHPG, & WQKHPM,WQKHS,WQSTOX + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQKHNC,WQKHND,WQKHNG,WQKHNM,WQKHPC,WQKHPD,WQKHPG, & WQKHPM,WQKHS,WQSTOX - WRITE(2,80)'* HALF-SAT. COSNTANT (G/M^3) FOR NUTRIENT UPTAKE ' + WRITE(2,80)'* HALF-SAT. CONSTANT (G/M^3) FOR NUTRIENT UPTAKE ' WRITE(2,81)' : (KHNC, KHPC) = ', WQKHNC,WQKHPC WRITE(2,81)' : (KHND, KHPD, KHS) = ', WQKHND,WQKHPD,WQKHS WRITE(2,81)' : (KHNG, KHPG) = ', WQKHND,WQKHPG WRITE(2,81)' : (KHNM, KHPM) = ', WQKHNM,WQKHPM WRITE(2,82)'* SAL. WHERE MICROSYSTIS GROWTH IS HALVED = ', & WQSTOX + ENDIF WQSTOX = WQSTOX*WQSTOX C C9 @@ -363,25 +395,36 @@ C READ(1,95)LINE READ(LINE,*,END=109,ERR=109) WQKETSS,WQKECHL,WQCHLC,WQCHLD,WQCHLG, & WQCHLM,WQDOPC,WQDOPD,WQDOPG, WQDOPM(1), WQKEPOM - 109 WRITE(2,*) WQKETSS,WQKECHL,WQCHLC,WQCHLD,WQCHLG,WQCHLM,WQDOPC, + 109 CONTINUE + IF(MYRANK.EQ.0)THEN + WRITE(2,*) WQKETSS,WQKECHL,WQCHLC,WQCHLD,WQCHLG,WQCHLM,WQDOPC, & WQDOPD,WQDOPG, WQDOPM(1) , WQKEPOM + ENDIF IF(ISTRAN(6).EQ.0)THEN WQKETSS=0.0 + IF(MYRANK.EQ.0)THEN WRITE(2,80)': SINCE TSS IS NOT MODELED, KETSS IS FORCED TO 0 ' ENDIF + ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,80)'* LIGHT EXTINC. COEFF. DUE TO TSS, CHL & POM ' WRITE(2,81)' : KETSS (/M PER G/M^3) = ', WQKETSS WRITE(2,81)' : KECHL (/M PER MG/M^3) = ', WQKECHL + ENDIF IF(WQKECHL .LT. 0.0)THEN + IF(MYRANK.EQ.0)THEN WRITE(2,80) '* USE RILEY (1956) EQUATION FOR WQKECHL ' WRITE(2,80) ' : KECHL = 0.054*CHL**0.667 + 0.0088*CHL ' ENDIF + ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,81)' : KEPOM (/M PER G/M^3) = ', WQKEPOM ! *** END DSLLC BLOCK WRITE(2,80)'* CARBON-TO-CHL RATIO (G C PER MG CHL) ' WRITE(2,81)' : (CCHLC, CCHLD, CCHLG) = ', WQCHLC,WQCHLD,WQCHLG WRITE(2,80)'* DEPTH (M) OF MAXIMUM ALGAL GROWTH ' WRITE(2,81)' : (DOPTC, DOPTD, DOPTG) = ', WQDOPC,WQDOPD,WQDOPG + ENDIF WQCHLC=1.0/(WQCHLC+ 1.E-12) WQCHLD=1.0/(WQCHLD+ 1.E-12) WQCHLG=1.0/(WQCHLG+ 1.E-12) @@ -391,6 +434,7 @@ C *** C10 IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQI0,WQISMIN,WQFD,WQCIA,WQCIB,WQCIC,WQCIM,REAC(1), & PARADJ + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQI0,WQISMIN,WQFD,WQCIA,WQCIB,WQCIC,WQCIM,REAC(1), & PARADJ WRITE(2,82)'*INITIAL IO (LY/D) AT WATER SURFACE = ',WQI0 @@ -400,6 +444,7 @@ C *** C10 & ,' WEIGHTING FACTOR FOR RAD. AT (-1) DAY = ',WQCIB & ,' WEIGHTING FACTOR FOR RAD. AT (-2) DAYS = ',WQCIC & ,' FRACTION OF SOLAR RADIATION THAT IS PAR = ',PARADJ + ENDIF WQI0=PARADJ*WQI0 !/(WQFD+1.E-18) ! *** APPLY CONVERSION TO OPTIMAL LIGHT WQI1 = WQI0 WQI2 = WQI0 @@ -413,41 +458,48 @@ C *** C11 IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*)WQTMC1,WQTMC2,WQTMD1,WQTMD2,WQTMG1,WQTMG2,WQTMM1,WQTMM2, & WQTMP1, WQTMP2 + IF(MYRANK.EQ.0)THEN WRITE(2,*)WQTMC1,WQTMC2,WQTMD1,WQTMD2,WQTMG1,WQTMG2,WQTMM1, & WQTMM2,WQTMP1, WQTMP2 + ENDIF C *** C12 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*)WQKG1C,WQKG2C,WQKG1D,WQKG2D,WQKG1G,WQKG2G,WQKG1M,WQKG2M, & WQKG1P, WQKG2P + IF(MYRANK.EQ.0)THEN WRITE(2,*)WQKG1C,WQKG2C,WQKG1D,WQKG2D,WQKG1G,WQKG2G,WQKG1M, & WQKG2M,WQKG1P, WQKG2P WRITE(2,80)'* LOWER OPTIMUM TEMP FOR ALGAL GROWTH (DEGC) ' WRITE(2,81)' : (TMC1, TMD1, TMG1 ) = ', WQTMC1,WQTMD1,WQTMG1 WRITE(2,80)'* UPPER OPTIMUM TEMP FOR ALGAL GROWTH (DEGC) ' WRITE(2,81)' : (TMC2, TMD2, TMG2 ) = ', WQTMC2,WQTMD2,WQTMG2 + ENDIF C C *** C13 CONSTANT PARAMETERS FOR ALGAE (SEE TABLE 3-1) C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQTRC,WQTRD,WQTRG,WQTRM,WQKTBC,WQKTBD,WQKTBG,WQKTBM + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQTRC,WQTRD,WQTRG,WQTRM,WQKTBC,WQKTBD,WQKTBG,WQKTBM WRITE(2,80)'* REFERENCE TEMPERATURE FOR ALGAL METABOLISM (OC) ' WRITE(2,81)' : (TRC, TRD, TRG) = ', WQTRC,WQTRD,WQTRG WRITE(2,80)'* TEMPERATURE EFFECT FOR ALGAL METABOLISM ' WRITE(2,81)' : (KTBC, KTBD, KTBG) = ', WQKTBC,WQKTBD,WQKTBG + ENDIF C C *** C14 CONSTANT PARAMETERS FOR CARBON (SEE TABLE 3-2) C - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,90) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQFCRP,WQFCLP,WQFCDP,WQFCDC,WQFCDD,WQFCDG, & WQKHRC,WQKHRD,WQKHRG + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQFCRP,WQFCLP,WQFCDP,WQFCDC,WQFCDD,WQFCDG, & WQKHRC,WQKHRD,WQKHRG WRITE(2,80)'* CARBON DISTRIBUTION COEFF FOR ALGAL PREDATION ' @@ -456,28 +508,36 @@ C WRITE(2,81)' : (FCDC, FCDD, FCDG) = ', WQFCDC,WQFCDD,WQFCDG WRITE(2,80)'* HALF-SAT. CONSTANT (GO/M*3) FOR ALGAL DOC EXCRET' WRITE(2,81)' : (KHRC, KHRD, KHRG) = ', WQKHRC,WQKHRD,WQKHRG + ENDIF CFCDCWQ = 1.0 - WQFCDC CFCDDWQ = 1.0 - WQFCDD CFCDGWQ = 1.0 - WQFCDG XC = ABS(1.0 - (WQFCRP+WQFCLP+WQFCDP)) + IF(MYRANK.EQ.0)THEN IF(XC .GT. 0.0001)THEN WRITE(2,*) WRITE(2,*) ' WARNING! FCRP+FCLP+FCDP NOT EQUAL TO 1.0' WRITE(2,*) ENDIF + ENDIF C *** C15 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2,90) TITLE(1) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQFCRPM,WQFCLPM,WQFCDPM,WQFCDM, WQKHRM(1) + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQFCRPM,WQFCLPM,WQFCDPM,WQFCDM, WQKHRM(1) + ENDIF C *** C16 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*)WQKRC,WQKLC,WQKDC(1),WQKRCALG,WQKLCALG,WQKDCALG, & WQKDCALM(1) + IF(MYRANK.EQ.0)THEN WRITE(2,*)WQKRC,WQKLC,WQKDC(1),WQKRCALG,WQKLCALG,WQKDCALG, & WQKDCALM(1) WRITE(2,80)'* MINIMUM DISSOLUTION RATE (/DAY) OF ORGANIC C ' @@ -485,11 +545,13 @@ C *** C16 WRITE(2,80)'* CONSTANT RELATING DISSOLUTION RATE TO ALGAE ' WRITE(2,81)' : (KRCALG,KLCALG,KDCALG)= ', WQKRCALG,WQKLCALG, & WQKDCALG + ENDIF C *** C17 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQTRHDR,WQTRMNL,WQKTHDR,WQKTMNL,WQKHORDO,WQKHDNN, & WQAANOX + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQTRHDR,WQTRMNL,WQKTHDR,WQKTMNL,WQKHORDO,WQKHDNN, & WQAANOX WRITE(2,80)'* REFERENCE TEMP FOR HYDROLYSIS/MINERALIZATION(OC)' @@ -500,18 +562,24 @@ C *** C17 WRITE(2,81)' : (KHORDO, KHDNN) = ', WQKHORDO,WQKHDNN WRITE(2,80)'* RATION OF DENITRIFICATION TO OXIC DOC RESP ' WRITE(2,81)' : (AANOX) = ', WQAANOX + ENDIF WQAANOX = WQAANOX*WQKHORDO C C *** C18 CONSTANT PARAMETERS FOR PHOSPHORUS (TABLE 3-3) C + IF(MYRANK.EQ.0)THEN WRITE(2,999) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2,90) TITLE(1) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQFPRP,WQFPLP,WQFPDP,WQFPIP,WQFPRC,WQFPRD,WQFPRG, & WQFPLC,WQFPLD,WQFPLG + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQFPRP,WQFPLP,WQFPDP,WQFPIP,WQFPRC,WQFPRD,WQFPRG, & WQFPLC,WQFPLD,WQFPLG WRITE(2,80)'* PHOSPHORUS DISTRIBUTION COEF FOR ALGAL PREDATION' @@ -521,61 +589,81 @@ C WRITE(2,81)' : (FPRC, FPRD, FPRG) = ', WQFPRC,WQFPRD,WQFPRG WRITE(2,80)'* PHOSPHORUS DIST COEF OF LPOP FOR ALGAL METABOLIS' WRITE(2,81)' : (FPLC, FPLD, FPLG) = ', WQFPLC,WQFPLD,WQFPLG + ENDIF XP = ABS(1.0 - (WQFPRP+WQFPLP+WQFPDP+WQFPIP)) + IF(MYRANK.EQ.0)THEN IF(XP .GT. 0.0001)THEN WRITE(2,*) WRITE(2,*) ' WARNING! FPRP+FPLP+FPDP+FPIP NOT EQUAL TO 1.0' WRITE(2,*) ENDIF + ENDIF C *** C19 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2,90) TITLE(1) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*)WQFPRPM,WQFPLPM,WQFPDPM,WQFPIPM,WQFPRM,WQFPLM,WQAPCM + IF(MYRANK.EQ.0)THEN WRITE(2,*)WQFPRPM,WQFPLPM,WQFPDPM,WQFPIPM,WQFPRM,WQFPLM,WQAPCM + ENDIF C *** C20 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQFPDC,WQFPDD,WQFPDG,WQFPDM,WQFPIC,WQFPID,WQFPIG, & WQFPIM,WQKPO4P + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQFPDC,WQFPDD,WQFPDG,WQFPDM,WQFPIC,WQFPID,WQFPIG, & WQFPIM,WQKPO4P + ENDIF IF(IWQSRP.NE.1 .AND. IWQSRP.NE.2)THEN WQKPO4P = 0.0 + IF(MYRANK.EQ.0)THEN WRITE(2,80)': NO SORPTION OF PO4T/SA, SO KPO4P IS FORCED TO 0 ' ENDIF + ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,80)'* PHOSPHORUS DIST COEF OF DOP FOR ALGAL METABOLISM' WRITE(2,81)' : (FPDC, FPDD, FPDG) = ', WQFPDC,WQFPDD,WQFPDG WRITE(2,80)'* PHOSPHORUS DIST COEF OF NH4 FOR ALGAL METABOLISM' WRITE(2,81)' : (FPIC, FPID, FPIG) = ', WQFPIC,WQFPID,WQFPIG WRITE(2,82)'* PARITITION COEFF FOR SORBED/DISSOLVED PO4 =', & WQKPO4P + ENDIF XPC = ABS(1.0 - (WQFPRC+WQFPLC+WQFPDC+WQFPIC)) + IF(MYRANK.EQ.0)THEN IF(XPC .GT. 0.0001)THEN WRITE(2,*) WRITE(2,*) ' WARNING! FPRC+FPLC+FPDC+FPIC NOT EQUAL TO 1.0' WRITE(2,*) ENDIF + ENDIF XPD = ABS(1.0 - (WQFPRD+WQFPLD+WQFPDD+WQFPID)) + IF(MYRANK.EQ.0)THEN IF(XPD .GT. 0.0001)THEN WRITE(2,*) WRITE(2,*) ' WARNING! FPRD+FPLD+FPDD+FPID NOT EQUAL TO 1.0' WRITE(2,*) ENDIF + ENDIF XPG = ABS(1.0 - (WQFPRG+WQFPLG+WQFPDG+WQFPIG)) + IF(MYRANK.EQ.0)THEN IF(XPG .GT. 0.0001)THEN WRITE(2,*) WRITE(2,*) ' WARNING! FPRG+FPLG+FPDG+FPIG NOT EQUAL TO 1.0' WRITE(2,*) ENDIF + ENDIF C *** C21 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQKRP,WQKLP,WQKDP,WQKRPALG,WQKLPALG,WQKDPALG,WQCP1PRM, & WQCP2PRM,WQCP3PRM + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQKRP,WQKLP,WQKDP,WQKRPALG,WQKLPALG,WQKDPALG,WQCP1PRM, & WQCP2PRM,WQCP3PRM WRITE(2,80)'* MINIMUM HYDROLYSIS RATE (/DAY) OF ORGANIC P ' @@ -586,17 +674,23 @@ C *** C21 WRITE(2,80)'* CONSTANT USED IN DETERMINING P-TO-C RATIO ' WRITE(2,81)' : (CPPRM1,CPPRM2,CPPRM3)= ', WQCP1PRM,WQCP2PRM, & WQCP3PRM + ENDIF C C *** C22 CONSTANT PARAMETERS FOR NITROGEN (TABLE 3-4) C + IF(MYRANK.EQ.0)THEN WRITE(2,999) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2,90) TITLE(1) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQFNRP,WQFNLP,WQFNDP,WQFNIP,WQFNRC,WQFNRD,WQFNRG, & WQFNLC,WQFNLD,WQFNLG + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQFNRP,WQFNLP,WQFNDP,WQFNIP,WQFNRC,WQFNRD,WQFNRG, & WQFNLC,WQFNLD,WQFNLG WRITE(2,80)'* NITROGEN DISTRIBUTION COEFF FOR ALGAL PREDATION ' @@ -606,26 +700,34 @@ C WRITE(2,81)' : (FNRC, FNRD, FNRG) = ', WQFNRC,WQFNRD,WQFNRG WRITE(2,80)'* NITROGEN DIST COEF OF LPON FOR ALGAL METABOLISM ' WRITE(2,81)' : (FNLC, FNLD, FNLG) = ', WQFNLC,WQFNLD,WQFNLG + ENDIF XN = ABS(1.0 - (WQFNRP+WQFNLP+WQFNDP+WQFNIP)) + IF(MYRANK.EQ.0)THEN IF(XN .GT. 0.0001)THEN WRITE(2,*) WRITE(2,*) ' WARNING! FNRP+FNLP+FNDP+FNIP NOT EQUAL TO 1.0' WRITE(2,*) ENDIF WRITE(2,999) + ENDIF C *** C23 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2,90) TITLE(1) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*)WQFNRPM,WQFNLPM,WQFNDPM,WQFNIPM,WQFNRM,WQFNLM + IF(MYRANK.EQ.0)THEN WRITE(2,*)WQFNRPM,WQFNLPM,WQFNDPM,WQFNIPM,WQFNRM,WQFNLM + ENDIF C *** C24 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQFNDC,WQFNDD,WQFNDG,WQFNDM,WQFNIC,WQFNID,WQFNIG, & WQFNIM,WQANCC,WQANCD,WQANCG,WQANCM + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQFNDC,WQFNDD,WQFNDG,WQFNDM,WQFNIC,WQFNID,WQFNIG, & WQFNIM,WQANCC,WQANCD,WQANCG,WQANCM WRITE(2,80)'* NITROGEN DIST COEF OF DON FOR ALGAL METABOLISM ' @@ -634,28 +736,36 @@ C *** C24 WRITE(2,81)' : (FNIC, FNID, FNIG) = ', WQFNIC,WQFNID,WQFNIG WRITE(2,80)'* NITROGEN-TO-CARBON RATIO IN ALGAE ' WRITE(2,81)' : (ANCC, ANCD, ANCG) = ', WQANCC,WQANCD,WQANCG + ENDIF XNC = ABS(1.0 - (WQFNRC+WQFNLC+WQFNDC+WQFNIC)) + IF(MYRANK.EQ.0)THEN IF(XNC .GT. 0.0001)THEN WRITE(2,*) WRITE(2,*) ' WARNING! FNRC+FNLC+FNDC+FNIC NOT EQUAL TO 1.0' WRITE(2,*) ENDIF + ENDIF XND = ABS(1.0 - (WQFNRD+WQFNLD+WQFNDD+WQFNID)) + IF(MYRANK.EQ.0)THEN IF(XND .GT. 0.0001)THEN WRITE(2,*) WRITE(2,*) ' WARNING! FNRD+FNLD+FNDD+FNID NOT EQUAL TO 1.0' WRITE(2,*) ENDIF + ENDIF XNG = ABS(1.0 - (WQFNRG+WQFNLG+WQFNDG+WQFNIG)) + IF(MYRANK.EQ.0)THEN IF(XNG .GT. 0.0001)THEN WRITE(2,*) WRITE(2,*) ' WARNING! FNRG+FNLG+FNDG+FNIG NOT EQUAL TO 1.0' WRITE(2,*) ENDIF + ENDIF C *** C25 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQANDC,WQNITM,WQKHNDO,WQKHNN,WQTNIT,WQKN1,WQKN2 + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQANDC,WQNITM,WQKHNDO,WQKHNN,WQTNIT,WQKN1,WQKN2 WRITE(2,82)'* MASS NO3 REDUCED PER DOC OXIDIZED (GN/GC)= ',WQANDC & ,'* MAXIMUM NITRIFICATION RATE (G N /M^3/D) = ',WQNITM @@ -664,29 +774,39 @@ C *** C25 WRITE(2,81)' : (KHNITDO, KHNITN) = ', WQKHNDO,WQKHNN WRITE(2,80)'* SUB & SUPER-OPTIMUM TEMP EFFECT ON NITRIFICATION' WRITE(2,81)' : (KNIT1, KNIT2) = ', WQKN1,WQKN2 + ENDIF C *** C26 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQKRN,WQKLN,WQKDN,WQKRNALG,WQKLNALG,WQKDNALG + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQKRN,WQKLN,WQKDN,WQKRNALG,WQKLNALG,WQKDNALG WRITE(2,80)'* MINIMUM HYDROLYSIS RATE (/DAY) OF ORGANIC N ' WRITE(2,81)' : (KRN, KLN, KDN) = ', WQKRN,WQKLN,WQKDN WRITE(2,80)'* CONSTANT RELATING HYDROLYSIS RATE TO ALGAE ' WRITE(2,81)' : (KRNALG,KLNALG,KDNALG)= ', WQKRNALG,WQKLNALG, & WQKDNALG + ENDIF C C *** C27 CONSTANT PARAMETERS FOR SILICA (TABLE 3-5) C + IF(MYRANK.EQ.0)THEN WRITE(2,999) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2,90) TITLE(1) + ENDIF IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQFSPP,WQFSIP,WQFSPD,WQFSID,WQASCD,WQKSAP,WQKSU, & WQTRSUA,WQKTSUA + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQFSPP,WQFSIP,WQFSPD,WQFSID,WQASCD,WQKSAP,WQKSU, & WQTRSUA,WQKTSUA + ENDIF + IF(MYRANK.EQ.0)THEN IF(IWQSRP.NE.1 .AND. IWQSRP.NE.2)THEN WQKSAP = 0.0 WRITE(2,80)': NO SORPTION OF PO4T/SA, SO KSAP IS FORCED TO 0 ' @@ -700,17 +820,19 @@ C & ,'*DISSOLUTION RATE (/D) OF PSI = ',WQKSU & ,' REFERENCE TEMP FOR PSI DISSOLUTION (OC) = ',WQTRSUA & ,' TEMPERATURE EFFECT ON PSI DISSOLUTION = ',WQKTSUA + ENDIF C C *** C28 CONSTANT PARAMETERS FOR COD & DO (TABLE 3-6) -C - WRITE(2,999) +C #### GHYUN + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQAOCR,WQAONT, WQKRO(1), WQKTR(1),WQKHCOD(1),WQKCD(1), & WQTRCOD, WQKTCOD, WQAOCRPM, WQAOCRRM + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQAOCR,WQAONT, WQKRO(1), WQKTR(1),WQKHCOD(1),WQKCD(1), & WQTRCOD, WQKTCOD, WQAOCRPM, WQAOCRRM WRITE(2,82)'* DO-TO-CARBON RATIO IN RESPIRATION = ',WQAOCR @@ -723,17 +845,19 @@ C & ,' TEMPERATURE EFFECT ON COD OXIDATION = ',WQKTCOD & ,': DO-TO-CARBON RATIO MACROALGAE PHOTOSYNTH = ',WQAOCRPM & ,': DO-TO-CARBON RATIO MACROALGAE RESPIRATION= ',WQAOCRRM + ENDIF C C *** C29 CONSTANT PARAMETERS FOR TAM & FCB (TABLE 3-7) C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) WQKHBMF,WQBFTAM,WQTTAM,WQKTAM,WQTAMDMX,WQKDOTAM, & WQKFCB,WQTFCB + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQKHBMF,WQBFTAM,WQTTAM,WQKTAM,WQTAMDMX,WQKDOTAM, & WQKFCB,WQTFCB WRITE(2,82) @@ -745,6 +869,7 @@ C & ,' CONSTANT RELATING TAM SOLUBILITY TO DO = ',WQKDOTAM & ,'* FIRST-ORDER DIE-OFF RATE AT 20OC (/D) = ',WQKFCB & ,' TEMPERATURE EFFECT ON BACTERIA DIE-OFF = ',WQTFCB + ENDIF C C SET UP LOOK-UP TABLE FOR TEMPERATURE DEPENDENCY OVER -15 OC TO 40 OC C @@ -802,7 +927,7 @@ C IF(WTEMP.GT.WQTMD2)THEN WQTDGP(M) = EXP(-WQKG2P*(WTEMP-WQTMP2)*(WTEMP-WQTMP2) ) ENDIF - 555 FORMAT(F7.2,4E12.4) +C 555 FORMAT(F7.2,4E12.4) WQTDRC(M) = EXP( WQKTBC*(WTEMP-WQTRC) ) WQTDRD(M) = EXP( WQKTBD*(WTEMP-WQTRD) ) WQTDRG(M) = EXP( WQKTBG*(WTEMP-WQTRG) ) @@ -817,7 +942,9 @@ C WQKCOD(M,1) = WQKCD(1) * EXP( WQKTCOD*(WTEMP-WQTRCOD) ) TT20 = WTEMP-20.0 WQTDKR(M,1) = WQKTR(1)**TT20 + IF(MYRANK.EQ.0)THEN WRITE(2,2222)M,WQKTR(1),WQTDKR(M,1) + ENDIF WQTDTAM(M) = WQKHBMF * WQBFTAM * EXP( WQKTAM*(WTEMP-WQTTAM) ) WQTT = WQKFCB * WQTFCB**TT20 * DTWQO2 WQTD1FCB(M) = 1.0 - WQTT @@ -830,17 +957,19 @@ C *** C30 C READ SECOND PART: RWQC2 C PARAMETERS FOR WATER QUALITY STATE VARIABLE TIME SERIES C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO READ(1,*) (NWQCSR(NW),NW=1,NWQV) + IF(MYRANK.EQ.0)THEN WRITE(2,*) (NWQCSR(NW),NW=1,NWQV) WRITE(2,970)(NWQCSR(NW),NW=1,NWQV) + ENDIF ! *** SAVE THE NUMBER OF WQ TIME SERIES DO NW=1,NWQV NT=4+NTOX+NSED+NSND+NW @@ -851,37 +980,41 @@ C *** C31 C READ SECOND PART: RWQC2 C PARAMETERS FOR OPEN BOUNDARY CONDITIONS C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) NWQOBS,NWQOBW,NWQOBE,NWQOBN + IF(MYRANK.EQ.0)THEN WRITE(2,*) NWQOBS,NWQOBW,NWQOBE,NWQOBN WRITE(2,23)'* # OF OPEN BDRY CELLS ON SOUTH BDRY = ',NWQOBS WRITE(2,23)'* # OF OPEN BDRY CELLS ON WEST BDRY = ',NWQOBW WRITE(2,23)'* # OF OPEN BDRY CELLS ON EAST BDRY = ',NWQOBE WRITE(2,23)'* # OF OPEN BDRY CELLS ON NORTH BDRY = ',NWQOBN + ENDIF IF(NWQOBS.GT.NBBSM) STOP 'ERROR!! NWQOBS SHOULD <= NBBSM' IF(NWQOBW.GT.NBBWM) STOP 'ERROR!! NWQOBW SHOULD <= NBBWM' IF(NWQOBE.GT.NBBEM) STOP 'ERROR!! NWQOBE SHOULD <= NBBEM' IF(NWQOBN.GT.NBBNM) STOP 'ERROR!! NWQOBN SHOULD <= NBBNM' + IF(MYRANK.EQ.0)THEN WRITE(2,999) WRITE(2,80)'* CONSTANT OBC AT (ICBX(M),JCBX(M)) IF IWQOBX(M)=0' WRITE(2,80)': READ TIME-SERIES OBCS IWQOBX TIMES IF IWQOBX > 0' + ENDIF C C *** C32 C SOUTH BDRY C READ(1,90) TITLE(M) C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBS.GT.0)THEN DO M=1,NWQOBS @@ -895,19 +1028,21 @@ C ELSE STOP ' WQ: SOUTH OBC: MISS MATCH BETWEEN NCBS & NWQOBS' ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBS(M),JWQCBS(M),(IWQOBS(M,NW),NW=1,NWQV) WRITE(2,969) IWQCBS(M),JWQCBS(M),(IWQOBS(M,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF C C *** C33 C: CONSTANT BOTTOM AND SURFACE OBCS C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBS.GT.0)THEN DO M=1,NWQOBS @@ -919,16 +1054,18 @@ C CBS(M,1,NT)=WQOBCS(M,1,NW) ENDDO ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBS(M),JWQCBS(M),(WQOBCS(M,1,NW),NW=1,NWQV) WRITE(2,97) IWQCBS(M),JWQCBS(M),(WQOBCS(M,1,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF C *** C34 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBS.GT.0)THEN DO M=1,NWQOBS @@ -940,8 +1077,10 @@ C *** C34 CBS(M,2,NT)=WQOBCS(M,2,NW) ENDDO ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBS(M),JWQCBS(M),(WQOBCS(M,2,NW),NW=1,NWQV) WRITE(2,97) IWQCBS(M),JWQCBS(M),(WQOBCS(M,2,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF C @@ -949,13 +1088,13 @@ C *** C35 C WEST BDRY C READ(1,90) TITLE(M) C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBW.GT.0)THEN DO M=1,NWQOBW @@ -969,19 +1108,21 @@ C ELSE STOP ' WQ: WST OBC: MISS MATCH BETWEEN NCBW & NWQOBW' ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBW(M),JWQCBW(M),(IWQOBW(M,NW),NW=1,NWQV) WRITE(2,969) IWQCBW(M),JWQCBW(M),(IWQOBW(M,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF C C *** C36 C: CONSTANT BOTTOM AND SURFACE OBCS C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBW.GT.0)THEN DO M=1,NWQOBW @@ -993,16 +1134,18 @@ C CBW(M,1,NT)=WQOBCW(M,1,NW) ENDDO ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBW(M),JWQCBW(M),(WQOBCW(M,1,NW),NW=1,NWQV) WRITE(2,97) IWQCBW(M),JWQCBW(M),(WQOBCW(M,1,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF C *** C37 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBW.GT.0)THEN DO M=1,NWQOBW @@ -1014,8 +1157,10 @@ C *** C37 CBW(M,2,NT)=WQOBCW(M,2,NW) ENDDO ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBW(M),JWQCBW(M),(WQOBCW(M,2,NW),NW=1,NWQV) WRITE(2,97) IWQCBW(M),JWQCBW(M),(WQOBCW(M,2,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF C @@ -1023,13 +1168,13 @@ C *** C38 C EAST BDRY C READ(1,90) TITLE(M) C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBE.GT.0)THEN DO M=1,NWQOBE @@ -1043,19 +1188,21 @@ C ELSE STOP ' WQ: EAST OBC: MISS MATCH BETWEEN NCBE & NWQOBE' ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBE(M),JWQCBE(M),(IWQOBE(M,NW),NW=1,NWQV) WRITE(2,969) IWQCBE(M),JWQCBE(M),(IWQOBE(M,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF C C *** C39 C: CONSTANT BOTTOM AND SURFACE OBCS C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBE.GT.0)THEN DO M=1,NWQOBE @@ -1067,16 +1214,18 @@ C CBE(M,1,NT)=WQOBCE(M,1,NW) ENDDO ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBE(M),JWQCBE(M),(WQOBCE(M,1,NW),NW=1,NWQV) WRITE(2,97) IWQCBE(M),JWQCBE(M),(WQOBCE(M,1,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) C *** C40 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBE.GT.0)THEN DO M=1,NWQOBE @@ -1088,8 +1237,10 @@ C *** C40 CBE(M,2,NT)=WQOBCE(M,2,NW) ENDDO ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBE(M),JWQCBE(M),(WQOBCE(M,2,NW),NW=1,NWQV) WRITE(2,97) IWQCBE(M),JWQCBE(M),(WQOBCE(M,2,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF C @@ -1097,13 +1248,13 @@ C *** C41 C NORTH BDRY C READ(1,90) TITLE(M) C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBN.GT.0)THEN DO M=1,NWQOBN @@ -1117,19 +1268,21 @@ C ELSE STOP ' WQ: NORTH OBC: MISS MATCH BETWEEN NCBN & NWQOBN' ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBN(M),JWQCBN(M),(IWQOBN(M,NW),NW=1,NWQV) WRITE(2,969) IWQCBN(M),JWQCBN(M),(IWQOBN(M,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF C C *** C42 C: CONSTANT BOTTOM AND SURFACE OBCS C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBN.GT.0)THEN DO M=1,NWQOBN @@ -1141,16 +1294,18 @@ C CBN(M,1,NT)=WQOBCN(M,1,NW) ENDDO ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBN(M),JWQCBN(M),(WQOBCN(M,1,NW),NW=1,NWQV) WRITE(2,97) IWQCBN(M),JWQCBN(M),(WQOBCN(M,1,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) C *** C43 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) DO M=1,5 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO IF(NWQOBN.GT.0)THEN DO M=1,NWQOBN @@ -1162,8 +1317,10 @@ C *** C43 CBN(M,2,NT)=WQOBCN(M,2,NW) ENDDO ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQCBN(M),JWQCBN(M),(WQOBCN(M,2,NW),NW=1,NWQV) WRITE(2,97) IWQCBN(M),JWQCBN(M),(WQOBCN(M,2,NW),NW=1,NWQV) + ENDIF ENDDO ENDIF C @@ -1171,7 +1328,7 @@ C *** C44 C SPATIALLY/TEMPORALLY CONSTANT INITIAL CONDITIONS: WQCHLX=1/WQCHLX C READ DATA POINTS & DO INTERNAL INTERPOLATION? C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) @@ -1181,14 +1338,17 @@ C ENDDO ENDIF READ(1,*) (WQV(1,1,NW), NW=1,6) - WRITE(2,*) (WQV(1,1,NW), NW=1,6) READ(1,*) (WQV(1,1,NW), NW=7,13) - WRITE(2,*) (WQV(1,1,NW), NW=7,13) READ(1,*) (WQV(1,1,NW), NW=14,NWQV),WQV(1,1,IDNOTRVA),WQMCMIN + IF(MYRANK.EQ.0)THEN + WRITE(2,*) (WQV(1,1,NW), NW=1,6) + WRITE(2,*) (WQV(1,1,NW), NW=7,13) WRITE(2,*) (WQV(1,1,NW), NW=14,NWQV),WQV(1,1,IDNOTRVA),WQMCMIN + ENDIF IF(IWQICI.NE.1)THEN - WRITE(2,999) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2,21)' : (BC, BD, BG) = ', (WQV(1,1,NW),NW=1,3) WRITE(2,21)' : (RPOC, LPOC, DOC) = ', (WQV(1,1,NW),NW=4,6) WRITE(2,21)' : (RPOP,LPOP,DOP,PO4T) = ', (WQV(1,1,NW),NW=7,10) @@ -1197,6 +1357,7 @@ C WRITE(2,21)' : (SU, SA, COD, DO) = ', (WQV(1,1,NW),NW=16,19) WRITE(2,981)' : (TAM, FCB,MALG) = ', & (WQV(1,1,NW),NW=20,NWQV) + ENDIF WQCHL(1,1) = WQV(1,1,1)*WQCHLC + WQV(1,1,2)*WQCHLD & + WQV(1,1,3)*WQCHLG IF(IWQSRP.EQ.1)THEN @@ -1280,7 +1441,9 @@ C WQKMVD(L)=0.25 WQKMVE(L)=2.0 ENDDO + IF(MYRANK.EQ.0)THEN WRITE(2,9003) + ENDIF 9003 FORMAT(/,' MACALGMP.INP - MACROALGAE MAP FILE',/, & ' PSHADE = SHADE FACTOR FOR TREE CANOPY (1.0=NO CANOPY)',/, & ' KMV = MACROALGAE HALF-SATURATION VELOCITY (M/SEC)',/, @@ -1293,14 +1456,15 @@ C & ' KMVE = MACROALGAE VEL. LIMIT LOGISTIC FUNC. PARAM. E',/, & ' I J L PSHADE KMV KMVMIN KBP KMVA KMVB', & ' KMVC KMVD KMVE') - PRINT *,'WQ: MACALGMP.INP' + IF(MYRANK.EQ.0) PRINT *,'WQ: MACALGMP.INP' OPEN(3,FILE='MACALGMP.INP',STATUS='UNKNOWN') CALL SKIPCOMM(3, CCMRM) 9001 READ(3,*,END=9002) II, JJ, XMRM1, XMRM2, XMRM3, XMRM4, & XMRMA, XMRMB, XMRMC, XMRMD, XMRME IF(II .LE. 0) GOTO 9002 IF(IJCT(II,JJ).LT.1 .OR. IJCT(II,JJ).GT.8)THEN - PRINT*, 'I, J, IJCT(I,J) = ', II,JJ,IJCT(II,JJ) + IF(MYRANK.EQ.0) PRINT*, 'I, J, IJCT(I,J) = ' + & , II,JJ,IJCT(II,JJ) STOP 'ERROR!! INVALID (I,J) IN FILE MACALGMP.INP' ENDIF LL=LIJ(II,JJ) @@ -1316,9 +1480,11 @@ C WQKMVE(LL)=XMRME WQV(LL,1,IDNOTRVA)=WQV(1,1,IDNOTRVA) WQVO(LL,1,IDNOTRVA)=WQV(1,1,IDNOTRVA) + IF(MYRANK.EQ.0)THEN WRITE(2,9004) II, JJ, LL, PSHADE(LL), WQKMV(LL), WQKMVMIN(LL), & WQKBP(LL), WQKMVA(LL), WQKMVB(LL), WQKMVC(LL), WQKMVD(LL), & WQKMVE(LL) + ENDIF 9004 FORMAT(' ',I3,' ',I3,' ',I3, 9F7.3) GOTO 9001 9002 CLOSE(3) @@ -1328,7 +1494,7 @@ C C *** C45 C SPATIALLY/TEMPORALLY CONSTANT ALGAL GROWTH, RESPIRATION & PREDATION RA C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) @@ -1336,12 +1502,15 @@ C READ(1,*) WQPMC(1),WQPMD(1),WQPMG(1),WQPMM(1),WQBMRC(1), & WQBMRD(1),WQBMRG(1),WQBMRM(1),WQPRRC(1),WQPRRD(1), & WQPRRG(1),WQPRRM(1),WQKEB(1) + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQPMC(1),WQPMD(1),WQPMG(1),WQPMM(1),WQBMRC(1), & WQBMRD(1),WQBMRG(1),WQBMRM(1),WQPRRC(1),WQPRRD(1), & WQPRRG(1),WQPRRM(1),WQKEB(1) + ENDIF IF(IWQAGR.NE.1)THEN - WRITE(2,999) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2,80)'* ALGAL GROWTH RATE (/DAY) ' WRITE(2,21)' : (PMC, PMD, PMG) = ', WQPMC(1),WQPMD(1), & WQPMG(1) @@ -1353,6 +1522,7 @@ C & WQPRRG(1) WRITE(2,82) & '* BASE LIGHT EXTINCTION COEFFICIENT (/M) = ',WQKEB(1) + ENDIF DO I=2,IWQZ WQPMC(I)=WQPMC(1) WQPMD(I)=WQPMD(1) @@ -1372,18 +1542,21 @@ C C C *** C46 SPATIALLY/TEMPORALLY CONSTANT SETTLING VELOCITIES AND REAERATION FACTO C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*)WQWSC(1),WQWSD(1),WQWSG(1),WQWSRP(1),WQWSLP(1),WQWSS(1), & WQWSM, REAC(1) + IF(MYRANK.EQ.0)THEN WRITE(2,*)WQWSC(1),WQWSD(1),WQWSG(1),WQWSRP(1),WQWSLP(1), & WQWSS(1),WQWSM, REAC(1) + ENDIF IF(IWQSTL.NE.1)THEN - WRITE(2,999) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2,80)'* ALGAL SETTLING RATE (M/DAY) ' WRITE(2,21)' : (WSC, WSD, WSG) = ', WQWSC(1),WQWSD(1), & WQWSG(1) @@ -1391,6 +1564,7 @@ C WRITE(2,21)' : (WSRP, WSLP) = ', WQWSRP(1),WQWSLP(1) WRITE(2,80)'* SETTLING RATE OF PARTICULATE METAL (M/DAY) ' WRITE(2,21)' : (WSS) = ', WQWSS(1) + ENDIF DO I=2,IWQZ WQWSC(I)=WQWSC(1) WQWSD(I)=WQWSD(1) @@ -1404,24 +1578,34 @@ C C C *** C47 SPATIALLY/TEMPORALLY CONSTANT BENTHIC FLUXES C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) -! If bentic flux for anoxic env some arrays have two dimensions - IF(IWQBEN .EQ. 0 .AND. IWQBENOX .NE. 0)THEN +!{ GEOSR BENTHIC FLUX FOR ANOXIC ENV : YSSONG 2015.09.08 +C READ(1,*) WQBFPO4D(1),WQBFNH4(1),WQBFNO3(1),WQBFSAD(1), !{ GEOSR BENTHIC FLUX FOR ANOXIC ENV : YSSONG 2015.09.08 +C & WQBFCOD(1),WQBFO2(1) +C WRITE(2,*) WQBFPO4D(1),WQBFNH4(1),WQBFNO3(1),WQBFSAD(1), +C & WQBFCOD(1),WQBFO2(1) + IF(IWQBEN.EQ.0.AND.IWQBENOX.NE.0)THEN MDUM=2 ELSE MDUM=1 ENDIF READ(1,*) (WQBFOXPO4D(1,M),WQBFOXNH4(1,M),WQBFOXNO3(1,M), & WQBFOXSAD(1,M),WQBFOXCOD(1,M),WQBFOXO2(1,M),M=1,MDUM) + IF(MYRANK.EQ.0)THEN WRITE(2,*) (WQBFOXPO4D(1,M),WQBFOXNH4(1,M),WQBFOXNO3(1,M), & WQBFOXSAD(1,M),WQBFOXCOD(1,M),WQBFOXO2(1,M),M=1,MDUM) IF(IWQBEN.EQ.0)THEN - WRITE(2,999) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) +C WRITE(2,21)' : (PO4D, NH4, NO3) = ',WQBFPO4D(1),WQBFNH4(1), !{ GEOSR BENTHIC FLUX FOR ANOXIC ENV : YSSONG 2015.09.08 +C & WQBFNO3(1) +C WRITE(2,21)' : (SAD, COD, DO) = ',WQBFSAD(1),WQBFCOD(1), +C & WQBFO2(1) + IF(MYRANK.EQ.0)THEN WRITE(2,21)' : (PO4D, NH4, NO3) =',WQBFOXPO4D(1,1),WQBFOXNH4(1,1), & WQBFOXNO3(1,1) WRITE(2,21)' : (SAD, COD, DO) =',WQBFOXSAD(1,1),WQBFOXCOD(1,1), @@ -1431,6 +1615,8 @@ C & WQBFOXNH4(1,2),WQBFOXNO3(1,2) WRITE(2,21)' : (SAD, COD, DO) =',WQBFOXSAD(1,2), & WQBFOXCOD(1,2),WQBFOXO2(1,2) + ENDIF + ENDIF ENDIF DO L=2,LA WQBFPO4D(L)=WQBFOXPO4D(1,1) @@ -1447,31 +1633,35 @@ C C *** TEMPORALLY-CONSTANT VALUES FOR POINT SOURCE CONCENTRATIONS IN MG/L C *** EXCEPT XPSQ (M^3/S), TAM (KMOL/D), FCB (MPN/L). C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,999) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) C *** C48 IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) IWQPS,NPSTMSR + IF(MYRANK.EQ.0)THEN WRITE(2,*) IWQPS,NPSTMSR WRITE(2,23)'* NUMBER OF CELLS FOR POINT SOURCE INPUT = ',IWQPS WRITE(2,23)'* NUMBER WITH VARIABLE POINT SOURCE INPUT = ',NPSTMSR + ENDIF IF(IWQPS.GT.NWQPS) STOP 'ERROR!! IWQPS SHOULD BE <= NWQPS' DO M=1,3 READ(1,90) TITLE(M) - WRITE(2,90) TITLE(M) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(M) ENDDO DO M=1,IWQPS READ(1,*) I,J,K,ITMP,XPSQ,(XPSL(NW),NW=1,6) - WRITE(2,*) I,J,K,ITMP,XPSQ,(XPSL(NW),NW=1,6) READ(1,*) (XPSL(NW),NW=7,13) - WRITE(2,*) (XPSL(NW),NW=7,13) READ(1,*) (XPSL(NW),NW=14,NWQV) + IF(MYRANK.EQ.0)THEN + WRITE(2,*) I,J,K,ITMP,XPSQ,(XPSL(NW),NW=1,6) + WRITE(2,*) (XPSL(NW),NW=7,13) WRITE(2,*) (XPSL(NW),NW=14,NWQV) WRITE(2,294) I,J,K,ITMP,XPSQ,(XPSL(NW),NW=1,NWQV) + ENDIF IF(IJCT(I,J).LT.1 .OR. IJCT(I,J).GT.8)THEN WRITE(*,911) I,J STOP 'ERROR!! INVALID (I,J) IN FILE WQ3DWC.INP FOR PSL' @@ -1553,21 +1743,24 @@ C C *** SPATIALLY/TEMPORALLY-CONSTANT VALUES FOR NON-POINT SOURCE INPUT C *** CONSTITUENT UNITS OF G/M2/DAY EXCEPT FCB WHICH IS MPN/M2/DAY. C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) DO M=1,3 READ(1,999) ENDDO READ(1,*) XDSQ,(XDSL(NW),NW=1,6) - WRITE(2,*) XDSQ,(XDSL(NW),NW=1,6) READ(1,*) (XDSL(NW),NW=7,13) - WRITE(2,*) (XDSL(NW),NW=7,13) READ(1,*) (XDSL(NW),NW=14,NWQV) + IF(MYRANK.EQ.0)THEN + WRITE(2,*) XDSQ,(XDSL(NW),NW=1,6) + WRITE(2,*) (XDSL(NW),NW=7,13) WRITE(2,*) (XDSL(NW),NW=14,NWQV) + ENDIF IF(IWQNPL.NE.1)THEN - WRITE(2,999) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2, 21)' : (DSQ, CHC, CHD, CHG) = ',XDSQ,(XDSL(NW),NW=1,3) WRITE(2, 21)' : (ROC, LOC, DOC) = ',(XDSL(NW),NW=4,6) WRITE(2, 21)' : (ROP, LOP, DOP, P4D) = ',(XDSL(NW),NW=7,10) @@ -1575,9 +1768,9 @@ C WRITE(2, 21)' : (NHX, NOX) = ',(XDSL(NW),NW=14,15) WRITE(2, 21)' : (SUU, SAA, COD, DOX) = ',(XDSL(NW),NW=16,19) WRITE(2,981)' : (TAM, FCB) = ',(XDSL(NW),NW=20,NWQV) + ENDIF C PMC WQDSQ(1,1) = XDSQ C PMC DO NW=1,18 -C PMC WQWDSL(1,1,NW) = XDSL(NW) * CONV1 ! CONVERT FROM KG/DAY TO G/DAY C PMC ENDDO ! *** CONVERT FROM Kmol TO moles @@ -1604,18 +1797,21 @@ C *** C50 WET DEPOSTION (MULTIPLIED BY RAINFALL VOLUME IN RWQATM) C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) DO M=1,3 READ(1,999) ENDDO READ(1,*) (WQATM(NW),NW=1,6) - WRITE(2,*) (WQATM(NW),NW=1,6) READ(1,*) (WQATM(NW),NW=7,13) - WRITE(2,*) (WQATM(NW),NW=7,13) READ(1,*) (WQATM(NW),NW=14,NWQV) + IF(MYRANK.EQ.0)THEN + WRITE(2,*) (WQATM(NW),NW=1,6) + WRITE(2,*) (WQATM(NW),NW=7,13) WRITE(2,*) (WQATM(NW),NW=14,NWQV) - WRITE(2,999) - WRITE(2,90) TITLE(1) + ENDIF + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0)THEN WRITE(2, 21)' : (CHC, CHD, CHG) = ',(WQATM(NW),NW=1,3) WRITE(2, 21)' : (ROC, LOC, DOC) = ',(WQATM(NW),NW=4,6) WRITE(2, 21)' : (ROP, LOP, DOP, P4D) = ',(WQATM(NW),NW=7,10) @@ -1623,96 +1819,108 @@ C WRITE(2, 21)' : (NHX, NOX) = ',(WQATM(NW),NW=14,15) WRITE(2, 21)' : (SUU, SAA, COD, DOX) = ',(WQATM(NW),NW=16,19) WRITE(2,981)' : (TAM, FCB) = ',(WQATM(NW),NW=20,NWQV) + ENDIF C C *** C51 INPUT/OUTPUT FILE NAMES FOR SPATIALLY AND/OR TEMPORALLY VARYING PARAMETERS C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,90) TITLE(1) - WRITE(2,999) - WRITE(2,90) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,90) TITLE(1) READ(1,295) RSTOFN - WRITE(2,85)'* OUTPUT FILE FOR RESTART (**NOT USED**) = ', RSTOFN READ(1,295) ICIFN + IF(MYRANK.EQ.0)THEN + WRITE(2,85)'* OUTPUT FILE FOR RESTART (**NOT USED**) = ', RSTOFN WRITE(2,85)'* FILE FOR INITIAL CONDITIONS = ', ICIFN + ENDIF IF(IWQICI.EQ.1)THEN - continue ELSE IF(IWQICI.EQ.2)THEN - continue ELSE IF(ICIFN(1:4).NE.'NONE'.AND.ICIFN(1:4).NE.'none') & STOP 'ERROR!! INVALID IWQICI/ICIFN' ENDIF READ(1,295) AGRFN + IF(MYRANK.EQ.0)THEN WRITE(2,85)'* FILE FOR ALGAL GROWTH, RESP., PREDATAT. = ', AGRFN + ENDIF IF(IWQAGR.EQ.1)THEN - continue ELSE IF(AGRFN(1:4).NE.'NONE'.AND.AGRFN(1:4).NE.'none') & STOP 'ERROR!! INVALID IWQAGR/AGRFN' ENDIF READ(1,295) STLFN + IF(MYRANK.EQ.0)THEN WRITE(2,85)'* FILE FOR SETTLING RATES OF ALGAE, PART. = ', STLFN + ENDIF IF(IWQSTL.EQ.1)THEN - continue ELSE IF(STLFN(1:4).NE.'NONE'.AND.STLFN(1:4).NE.'none') & STOP 'ERROR!! INVALID IWQSTL/STLFN' ENDIF READ(1,295) SUNFN + IF(MYRANK.EQ.0)THEN WRITE(2,85)'* FILE FOR IO, FD, TE, KT = ', SUNFN + ENDIF IF(IWQSUN.EQ.1)THEN - continue ELSE ! IF(SUNFN(1:4).NE.'NONE'.AND.SUNFN(1:4).NE.'none') !& STOP 'ERROR!! INVALID IWQSUN/SUNFN' ENDIF READ(1,295) BENFN + IF(MYRANK.EQ.0)THEN WRITE(2,85)'* FILE FOR BENTHIC FLUX = ', BENFN + ENDIF IF(IWQBEN.EQ.2)THEN - continue ELSE IF(BENFN(1:4).NE.'NONE'.AND.BENFN(1:4).NE.'none') & STOP 'ERROR!! INVALID IWQBEN/BENFN' ENDIF READ(1,295) PSLFN + IF(MYRANK.EQ.0)THEN WRITE(2,85)'* FILE FOR POINT SOURCE INPUT = ', PSLFN + ENDIF READ(1,295) NPLFN + IF(MYRANK.EQ.0)THEN WRITE(2,85)'* FILE FOR NPS INPUT INCLUDING ATM. INPUT = ', NPLFN + ENDIF IF(IWQNPL.EQ.1)THEN - continue ELSE IF(NPLFN(1:4).NE.'NONE'.AND.NPLFN(1:4).NE.'none') & STOP 'ERROR!! INVALID IWQNPL/NPLFN' ENDIF READ(1,295) NCOFN + IF(MYRANK.EQ.0)THEN WRITE(2,85)'* DIAGNOSTIC FILE FOR NEGATIVE CONCENTRAT = ', NCOFN + ENDIF CLOSE(1) IF(IWQNC.EQ.1)THEN + IF(MYRANK.EQ.0)THEN OPEN(1,FILE=NCOFN,STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') OPEN(1,FILE=NCOFN,STATUS='UNKNOWN') WRITE(1,284)'* NEGATIVE CONCENTRATION OCCURS:' CLOSE(1) + ENDIF ELSE IF(NCOFN(1:4).NE.'NONE'.AND.NCOFN(1:4).NE.'none') & STOP 'ERROR!! INVALID IWQNC/NCOFN' ENDIF 294 FORMAT(2I4,2I3, 7F8.3, /, 14X, 7F8.3, /, 14X, 8F8.3) 295 FORMAT(44X, A50) - 96 FORMAT(2I5, 13I5, /, 10X, 8I5) +C 96 FORMAT(2I5, 13I5, /, 10X, 8I5) 969 FORMAT(2I4,1X,21I3) 970 FORMAT(1X,21I3) 97 FORMAT(2I4, 6F8.3, /, 8X, 7F8.3, /, 8X, 8F8.3) - 98 FORMAT(6F8.4, /, 7F8.4, /, 8F8.4) - 99 FORMAT(7F8.4, /, 7F8.4, /, 8F8.4) +C 98 FORMAT(6F8.4, /, 7F8.4, /, 8F8.4) +C 99 FORMAT(7F8.4, /, 7F8.4, /, 8F8.4) 21 FORMAT(A27, 1P, 4E11.3) 981 FORMAT(A27, 1P, 3E11.3) 23 FORMAT(A46, I5) @@ -1723,12 +1931,15 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L ! ! ! - PRINT *,'WQ: READING WQ3DWC2.INP - WATER QUALITY CONTROL FILE 2' +!{ GEOSR jgcho 2015.9.10 + IF(MYRANK.EQ.0) PRINT *,'WQ: READING WQ3DWC2.INP + & - WATER QUALITY CONTROL FILE 2' + IF(MYRANK.EQ.0)THEN write(2,*) write(2,*) write(2,*) write(2,'(a)') '===============Check WQ3DWC2.INP==============' -! + ENDIF ! OPEN(1,FILE='WQ3DWC2.INP',STATUS='UNKNOWN') ! @@ -1740,7 +1951,9 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L CCMRM = '#' IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,*) NXSP + IF(MYRANK.EQ.0)THEN WRITE(2,*) NXSP + ENDIF ! ! *** C02 WQ3DWC2.INP ! @@ -1748,7 +1961,9 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*) IWQX(i) + IF(MYRANK.EQ.0)THEN WRITE(2,*) i,IWQX(i) + ENDIF enddo ! ! *** C03 WQ3DWC2.INP @@ -1757,12 +1972,14 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*) WQKHNX(i),WQKHPX(i),WQKHSX(i),WQSTOXX(i) + IF(MYRANK.EQ.0)THEN WRITE(2,*) i,WQKHNX(i),WQKHPX(i),WQKHSX(i),WQSTOXX(i) - WRITE(2,80)'* HALF-SAT. CONSTANT (G/M^3) FOR NUTRIENT UPTAKE' + WRITE(2,80)'* HALF-SAT. CONSTANT (G/M^3) FOR NUTRIENT UPTAKE ' WRITE(2,81)' : (KHNX, KHPX) = ', WQKHNX(i),WQKHPX(i) WRITE(2,81)' : (KHS) = ', WQKHSX(i) WRITE(2,82)'* SAL. WHERE MICROSYSTIS GROWTH IS HALVED = ', & WQSTOXX(i) + ENDIF WQSTOXX(i) = WQSTOXX(i)*WQSTOXX(i) enddo ! @@ -1772,11 +1989,13 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*) WQCHLX(i),WQDOPX(i) + IF(MYRANK.EQ.0)THEN WRITE(2,*) i,WQCHLX(i),WQDOPX(i) WRITE(2,80)'* CARBON-TO-CHL RATIO (G C PER MG CHL) ' WRITE(2,81)' : (CCHLX) = ', WQCHLX(i) WRITE(2,80)'* DEPTH (M) OF MAXIMUM ALGAL GROWTH ' WRITE(2,81)' : (DOPTX) = ', WQDOPX(i) + ENDIF WQCHLX(i)=1.0/(WQCHLX(i)+ 1.E-12) enddo ! @@ -1786,11 +2005,13 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*)WQTMX1(i),WQTMX2(i),WQTMPX1(i),WQTMPX2(i) + IF(MYRANK.EQ.0)THEN write(2,*)i,WQTMX1(i),WQTMX2(i),WQTMPX1(i),WQTMPX2(i) WRITE(2,80)'* LOWER OPTIMUM TEMP FOR ALGAL GROWTH (DEGC) ' WRITE(2,81)' : (TMX1 ) = ', WQTMX1(i) WRITE(2,80)'* UPPER OPTIMUM TEMP FOR ALGAL GROWTH (DEGC) ' WRITE(2,81)' : (TMX2 ) = ', WQTMX2(i) + ENDIF enddo ! ! *** C06 WQ3DWC2.INP @@ -1799,7 +2020,9 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*)WQKGX1(i),WQKGX2(i),WQKGPX1(i),WQKGPX2(i) + IF(MYRANK.EQ.0)THEN write(2,*)i,WQKGX1(i),WQKGX2(i),WQKGPX1(i),WQKGPX2(i) + ENDIF enddo ! ! *** C07 WQ3DWC2.INP @@ -1808,11 +2031,13 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*)WQTRX(i),WQKTBX(i) + IF(MYRANK.EQ.0)THEN write(2,*)i,WQTRX(i),WQKTBX(i) WRITE(2,80)'* REFERENCE TEMPERATURE FOR ALGAL METABOLISM (OC)' WRITE(2,81)' : (TRX) = ', WQTRX(i) WRITE(2,80)'* TEMPERATURE EFFECT FOR ALGAL METABOLISM ' WRITE(2,81)' : (KTBX) = ', WQKTBX(i) + ENDIF enddo WQTDMIN=-10 ! changed from -10,BRW changed from -22 WQTDMAX=50 ! changed from 50, BRW changed from 38 @@ -1854,12 +2079,14 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*)WQFCDX(i),WQKHRX(i) + IF(MYRANK.EQ.0)THEN write(2,*)i,WQFCDX(i),WQKHRX(i) WRITE(2,80)'* CARBON DISTRIBUTION COEFF FOR ALGAL METABOLISM ' WRITE(2,81)' : (FCDX) = ', WQFCDX(i) WRITE(2,80) & '* HALF-SAT. CONSTANT (GO/M*3) FOR ALGAL DOC EXCRET' WRITE(2,81)' : (KHRX) = ', WQKHRX(i) + ENDIF CFCDWQX(i) = 1.0 - WQFCDX(i) enddo ! @@ -1869,6 +2096,7 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*)WQFPRX(i),WQFPLX(i) + IF(MYRANK.EQ.0)THEN write(2,*)i,WQFPRX(i),WQFPLX(i) WRITE(2,80) & '* PHOSPHORUS DIST COEF OF RPOP FOR ALGAL METABOLIS' @@ -1876,6 +2104,7 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L WRITE(2,80) & '* PHOSPHORUS DIST COEF OF LPOP FOR ALGAL METABOLIS' WRITE(2,81)' : (FPLX) = ', WQFPLX(i) + ENDIF enddo ! ! *** C10 WQ3DWC2.INP @@ -1884,6 +2113,7 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*)WQFPDX(i),WQFPIX(i) + IF(MYRANK.EQ.0)THEN write(2,*)i,WQFPDX(i),WQFPIX(i) WRITE(2,80) & '* PHOSPHORUS DIST COEF OF DOP FOR ALGAL METABOLISM' @@ -1891,14 +2121,14 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L WRITE(2,80) & '* PHOSPHORUS DIST COEF OF NH4 FOR ALGAL METABOLISM' WRITE(2,81)' : (FPIX) = ', WQFPIX(i) + ENDIF XPC = ABS(1.0 - (WQFPRX(i)+WQFPLX(i)+WQFPDX(i)+WQFPIX(i))) IF(XPC .GT. 0.0001)THEN - WRITE(2,*) - & '==================================================' - WRITE(2,*) i, - & ' WARNING! FPRX+FPLX+FPDX+FPIX NOT EQUAL TO 1.0' - WRITE(2,*) - & '==================================================' + IF(MYRANK.EQ.0)THEN + WRITE(2,*)'==================================================' + WRITE(2,*) i,' WARNING! FPRX+FPLX+FPDX+FPIX NOT EQUAL TO 1.0' + WRITE(2,*)'==================================================' + ENDIF ENDIF enddo ! @@ -1908,11 +2138,13 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*)WQFNRX(i),WQFNLX(i) + IF(MYRANK.EQ.0)THEN write(2,*)i,WQFNRX(i),WQFNLX(i) WRITE(2,80)'* NITROGEN DIST COEF OF RPON FOR ALGAL METABOLISM' WRITE(2,81)' : (FNRX) = ', WQFNRX(i) WRITE(2,80)'* NITROGEN DIST COEF OF LPON FOR ALGAL METABOLISM' WRITE(2,81)' : (FNLX) = ', WQFNLX(i) + ENDIF enddo ! ! *** C12 WQ3DWC2.INP @@ -1921,6 +2153,7 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*)WQFNDX(i),WQFNIX(i),WQANCX(i) + IF(MYRANK.EQ.0)THEN write(2,*)i,WQFNDX(i),WQFNIX(i),WQANCX(i) WRITE(2,80)'* NITROGEN DIST COEF OF DON FOR ALGAL METABOLISM ' WRITE(2,81)' : (FNDX) = ', WQFNDX(i) @@ -1928,14 +2161,14 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L WRITE(2,81)' : (FNIX) = ', WQFNIX(i) WRITE(2,80)'* NITROGEN-TO-CARBON RATIO IN ALGAE ' WRITE(2,81)' : (ANCX) = ', WQANCX(i) + ENDIF XNC = ABS(1.0 - (WQFNRX(i)+WQFNLX(i)+WQFNDX(i)+WQFNIX(i))) IF(XNC .GT. 0.0001)THEN - WRITE(2,*) - & '==================================================' - WRITE(2,*) i, - & ' WARNING! FNRX+FNLX+FNDX+FNIX NOT EQUAL TO 1.0' - WRITE(2,*) - & '==================================================' + IF(MYRANK.EQ.0)THEN + WRITE(2,*)'==================================================' + WRITE(2,*) i,' WARNING! FNRX+FNLX+FNDX+FNIX NOT EQUAL TO 1.0' + WRITE(2,*)'==================================================' + ENDIF ENDIF enddo ! @@ -1946,6 +2179,7 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L do i=1,NXSP READ(1,*) WQFSPPX(i),WQFSIPX(i),WQFSPDX(i),WQFSIDX(i) & ,WQASCDX(i) + IF(MYRANK.EQ.0)THEN write(2,*)i,WQFSPPX(i),WQFSIPX(i),WQFSPDX(i),WQFSIDX(i) & ,WQASCDX(i) WRITE(2,80) @@ -1958,6 +2192,7 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L & WQFSIDX(i) WRITE(2,82)'*SILICA-TO-CARBON RATIO IN DIATOMS = ', & WQASCDX(i) + ENDIF enddo ! ! *** C14 WQ3DWC2.INP @@ -1966,6 +2201,7 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*) WQPMX(1,i),WQBMRX(1,i),WQPRRX(1,i) + IF(MYRANK.EQ.0)THEN write(2,*) i,WQPMX(1,i),WQBMRX(1,i),WQPRRX(1,i) WRITE(2,80)'* ALGAL GROWTH RATE (/DAY) ' WRITE(2,21)' : (PMX) = ', WQPMX(1,i) @@ -1973,12 +2209,14 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L WRITE(2,21)' : (BMRX) = ', WQBMRX(1,i) WRITE(2,80)'* ALGAL PREDATION RATE (/DAY) ' WRITE(2,21)' : (PRRX) = ', WQPRRX(1,i) + ENDIF do ii=2,IWQZ WQPMX(ii,i)=WQPMX(1,i) WQBMRX(ii,i)=WQBMRX(1,i) WQPRRX(ii,i)=WQPRRX(1,i) enddo +! ENDIF enddo ! ! *** C15 WQ3DWC2.INP @@ -1987,10 +2225,14 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*) WQWSX(1,i) + IF(MYRANK.EQ.0)THEN WRITE(2,*)i,WQWSX(1,i) + ENDIF IF(IWQSTL.NE.1)THEN + IF(MYRANK.EQ.0)THEN WRITE(2,80)'* ALGAL SETTLING RATE (M/DAY) ' WRITE(2,21)' : (WSX) = ', WQWSX(1,i) + ENDIF DO ii=2,IWQZ WQWSX(ii,i)=WQWSX(1,i) ENDDO @@ -2001,11 +2243,16 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L ! IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,*) - read(1,*) m - write(2,*) 'IWQICIX=',m +!{ GEOSR X-species : jgcho 2015.10.01 + read(1,*) m ! GEOSR X-species : jgcho 2015.11.11 + IF(MYRANK.EQ.0)THEN + write(2,*) 'IWQICIX=',m ! GEOSR X-species : jgcho 2015.11.11 + ENDIF do i=1,NXSP READ(1,*) WQVX(1,1,i) + IF(MYRANK.EQ.0)THEN WRITE(2,*) i,WQVX(1,1,i) + ENDIF enddo if (m.ne.1) then DO K=1,KC @@ -2022,8 +2269,8 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L ENDDO else OPEN(714,FILE='WQWCRSTX.INP',STATUS='UNKNOWN') - WRITE(*,*) - & '* READING INITIAL CONDITIONS for Xspec. WQWCRSTX.INP' + IF(MYRANK.EQ.0) + & WRITE(*,*)'* READING INITIAL CONDITIONS for Xspec. WQWCRSTX.INP' read(714,*) read(714,*) DO M=1,(LA-1)*KC @@ -2046,8 +2293,10 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L do i=1,NXSP READ(1,*) ISSTOKEX(i),WQROH0X(i),WQRHOMNX(i),WQRHOMXX(i) & ,WQIRHALFX(i),WQCOEF1X(i),WQCOEF2X(i),WQCOEF3X(i) + IF(MYRANK.EQ.0)THEN WRITE(2,*) i,ISSTOKEX(i),WQROH0X(i),WQRHOMNX(i),WQRHOMXX(i) & ,WQIRHALFX(i),WQCOEF1X(i),WQCOEF2X(i),WQCOEF3X(i) + ENDIF WQCOEF1X(i)=WQCOEF1X(i)*(60.*24.) WQCOEF2X(i)=WQCOEF2X(i)*(60.*24.) WQCOEF3X(i)=WQCOEF3X(i)*(60.*24.) @@ -2056,13 +2305,17 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,*) READ(1,*) Light_Factor1, F_PAR + IF(MYRANK.EQ.0)THEN WRITE(2,*) Light_Factor1, F_PAR + ENDIF ! *** C18 WQ3DWC2.INP IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*) WQRX(i),WQAX(i),WQRESISX(i) + IF(MYRANK.EQ.0)THEN write(2,*) i,WQRX(i),WQAX(i),WQRESISX(i) + ENDIF enddo ! *** C19 WQ3DWC2.INP IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) @@ -2070,33 +2323,46 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L READ(1,*) ISCYANO,NSZONE,CONCYA,TGERMI,KCG,DGTIME, & CYA_TEM,CYA_P4D,CYA_NO3,CYA_Light,Light_Factor2,NNAT + IF(MYRANK.EQ.0)THEN write(2,*) ISCYANO,NSZONE,CONCYA,TGERMI,KCG,DGTIME, & CYA_TEM,CYA_P4D,CYA_NO3,CYA_Light,Light_Factor2,NNAT + ENDIF ! *** C20 WQ3DWC2.INP IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,*) IF(ISCYANO.EQ.1) THEN DO I=1,NSZONE READ(1,*) NUM_ZONE(I), NUM_CELL(I) + IF(MYRANK.EQ.0)THEN write(2,*) NUM_ZONE(I), NUM_CELL(I) + ENDIF ENDDO ENDIF ! *** C21 WQ3DWC2.INP +! CALL SEEK('C21') IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) - IF(ISSKIP .EQ. 0) READ(1,*) - CALL SEEK('C21') + IF(ISSKIP .EQ. 0) READ(1,*) + IF(MYRANK.EQ.0)THEN + CALL SEEK('C21') write(2,*) 'C21' + ENDIF DO nsp=1,NXSP READ(1,*) NWQCSRX(nsp) + IF(MYRANK.EQ.0)THEN write(2,*) NWQCSRX(nsp) + ENDIF NT=4+NTOX+NSED+NSND+NWQV+nsp NCSER(NT)=NWQCSRX(nsp) ENDDO read(1,*) + IF(MYRANK.EQ.0)THEN write(2,*) + ENDIF DO M=1,IWQPS READ(1,*) I,J,K,ITMP + IF(MYRANK.EQ.0)THEN WRITE(2,*) I,J,K,ITMP + ENDIF DO nsp=1,NXSP N1=4+NTOX+NSED+NSND+NWQV+nsp NCSERQ(M,N1)=ITMP @@ -2172,8 +2438,11 @@ C *** MG/L FOR 1-19, TAM-MOLES/L, AND FCB-MPN/L IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,*) READ(1,*) IWQBENOX,DOXCRT + IF(MYRANK.EQ.0)THEN write(2,*) IWQBENOX,DOXCRT write(2,*) + ENDIF + !} GEOSR X-species : jgcho 2015.09.17 close(1) ! ! @@ -2197,6 +2466,7 @@ C INITIALIZE IF(NXSP.ge.1)THEN IF(ISSTOKEX(1).EQ.1)THEN do i=1,IWQTS + IF(MYRANK.EQ.0)THEN WRITE(FLN,"('STOKE',I2.2,'.OUT')") i OPEN(1,FILE=trim(FLN)) ! VERTICAL VELOCITY, ALGAL-DENSITY, SOLAR RADIATION, chl-a PRINT AT EACH LAYER CLOSE(1,STATUS='DELETE') @@ -2205,23 +2475,30 @@ C INITIALIZE write(1,'(a,a)') 'VERTICAL VELOCITY, ALGAL-DENSITY,' & ,' SOLAR RADIATION, chl-a PRINT AT EACH LAYER' write(1,'(a,i4,a,i4)') 'I=',iww(i),' J=',jww(i) - write(1,7111) ' tm' - & ,((('vel_',nsp,'_',k),nsp=1,NXSP),k=KC,1,-1) - & ,((('den_',nsp,'_',k),nsp=1,NXSP),k=KC,1,-1) - & ,((('sol_',nsp,'_',k),nsp=1,NXSP),k=KC,1,-1) - & ,(('chl_',k),k=KC,1,-1) + write(FMTSTR, + & '("(a, 3(",I0,"(",I0,"(3x,a,i2.2,a,i2.2))),",I0,"(6x,a,i2.2))")') + & KC, NXSP, KC + write(1,FMTSTR) ' tm' + & ,(('vel_',nsp,'_',k,nsp=1,NXSP),k=KC,1,-1) + & ,(('den_',nsp,'_',k,nsp=1,NXSP),k=KC,1,-1) + & ,(('sol_',nsp,'_',k,nsp=1,NXSP),k=KC,1,-1) + & ,('chl_',k,k=KC,1,-1) CLOSE(1) + ENDIF enddo ENDIF ENDIF - 7111 format(a, 3(((3x,a,i2.2,a,i2.2))),(6x,a,i2.2) ) + !{ GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 if (IWQDGSTOX.eq.1) then + IF(MYRANK.EQ.0)THEN PRINT *,'WQ: READING WQDGSTOX.INP - DG Salt TOX Control' write(2,*) write(2,*) write(2,*) write(2,'(a)') '===============Check WQDGSTOX.INP==============' + ENDIF + OPEN(1,FILE='WQDGSTOX.INP',STATUS='OLD') ! *** C01 WQDGSTOX.INP ISSKIP = 0 @@ -2232,8 +2509,11 @@ C INITIALIZE IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,*) WQCOEFSA(1),WQCOEFSB(1),WQSALA(1),WQSALB(1) READ(1,*) WQCOEFSA(2),WQCOEFSB(2),WQSALA(2),WQSALB(2) + IF(MYRANK.EQ.0)THEN WRITE(2,*) WQCOEFSA(1),WQCOEFSB(1),WQSALA(1),WQSALB(1) WRITE(2,*) WQCOEFSA(2),WQCOEFSB(2),WQSALA(2),WQSALB(2) + ENDIF + IF (NXSP.gt.0) then allocate(WQCOEFSAX(NXSP)) allocate(WQCOEFSBX(NXSP)) @@ -2246,12 +2526,15 @@ C INITIALIZE IF(ISSKIP .EQ. 0) READ(1,*) do i=1,NXSP READ(1,*) WQCOEFSAX(i),WQCOEFSBX(i),WQSALAX(i),WQSALBX(i) + IF(MYRANK.EQ.0)THEN WRITE(2,*) i,WQCOEFSAX(i),WQCOEFSBX(i),WQSALAX(i),WQSALBX(i) + ENDIF enddo ENDIF CLOSE(1) endif !} GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 + DO I=1,IWQZ IWQKA(I)=IWQKA(1) WQKRO(I)=WQKRO(1) @@ -2265,22 +2548,26 @@ C INITIALIZE WQKHCOD(I)=WQKHCOD(1) ENDDO IF(IWQZ .GT. 1 .AND. IWQKIN .GT. 0)THEN - PRINT *,'WQ: KINETICS.INP' + IF(MYRANK.EQ.0) PRINT *,'WQ: KINETICS.INP' OPEN(1,FILE='KINETICS.INP',STATUS='UNKNOWN') CALL SKIPCOMM(1,CCMRM) + IF(MYRANK.EQ.0)THEN WRITE(2,*) ' ' WRITE(2,*) ' SPATIALLY-VARYING KINETICS.INP FILE' WRITE(2,9111) + ENDIF DO I=1,IWQZ READ(1,*) IZ, IWQKA(IZ), WQKRO(IZ), WQKTR(IZ), REAC(IZ), & WQKDC(IZ),WQKDCALM(IZ),WQKHRM(IZ),WQDOPM(IZ),WQKCD(IZ), & WQKHCOD(IZ) + IF(MYRANK.EQ.0)THEN WRITE(2,*) IZ, IWQKA(IZ), WQKRO(IZ), WQKTR(IZ), REAC(IZ), & WQKDC(IZ),WQKDCALM(IZ),WQKHRM(IZ),WQDOPM(IZ),WQKCD(IZ), & WQKHCOD(IZ) WRITE(2,9112) IZ, IWQKA(IZ), WQKRO(IZ), WQKTR(IZ), REAC(IZ), & WQKDC(IZ),WQKDCALM(IZ),WQKHRM(IZ),WQDOPM(IZ),WQKCD(IZ), & WQKHCOD(IZ) + ENDIF ENDDO CLOSE(1) ENDIF @@ -2297,7 +2584,9 @@ C WTEMP =1.00*REAL(M-1)*0.1 - 14.95 DO I=1,IWQZ WQKCOD(M,I) = WQKCD(I) * EXP( WQKTCOD*(WTEMP-WQTRCOD) ) WQTDKR(M,I) = WQKTR(I)**TT20 + IF(MYRANK.EQ.0)THEN WRITE(2,2223)M,I,WQKTR(I),WQTDKR(M,I) + ENDIF ENDDO ENDDO C @@ -2310,31 +2599,39 @@ C ENDDO IF(IWQZ .GT. 1)THEN OPEN(1,FILE='WQWCMAP.INP',STATUS='UNKNOWN') - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) READ(1,30) (TITLE(M), M=1,3) + IF(MYRANK.EQ.0)THEN WRITE(2,30) (TITLE(M), M=1,3) + ENDIF C C READ(1,999) C READ(1,999) - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0)THEN WRITE(2,32) + ENDIF IN=0 IJKC=IC*JC*KC DO M=1,IJKC READ(1,*,END=1111) I,J,K,IWQZX IN=IN+1 IF(IJCT(I,J).LT.1 .OR. IJCT(I,J).GT.8)THEN - PRINT*, 'I, J, K, IJCT(I,J) = ', I,J,K,IJCT(I,J) + IF(MYRANK.EQ.0) PRINT*, 'I, J, K, IJCT(I,J) = ', + & I,J,K,IJCT(I,J) STOP 'ERROR!! INVALID (I,J) IN FILE WQWCMAP.INP' ENDIF L = LIJ(I,J) IWQZMAP(L,K)=IWQZX + IF(MYRANK.EQ.0)THEN WRITE(2,31) L,I,J,K,IWQZMAP(L,K) + ENDIF ENDDO 1111 CONTINUE IF(IN.NE.(LA-1)*KC)THEN - PRINT*, 'ALL ACTIVE WATER CELLS SHOULD BE MAPPED FOR WQ PAR.' + IF(MYRANK.EQ.0) PRINT*, + & 'ALL ACTIVE WATER CELLS SHOULD BE MAPPED FOR WQ PAR.' STOP 'ERROR!! NUMBER OF LINES IN FILE WQWCMAP.INP =\ (LA-1)' ENDIF CLOSE(1) @@ -2354,10 +2651,12 @@ C ENDDO ENDDO OPEN(1,FILE='WQBENMAP.INP',STATUS='UNKNOWN') - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) DO M=1,4 READ(1,30) TITLE(M) + IF(MYRANK.EQ.0)THEN WRITE(2,30) TITLE(M) + ENDIF ENDDO C C SKIP ALL COMMENT CARDS AT BEGINNING OF FILE: @@ -2368,8 +2667,10 @@ C C C READ(1,999) C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0)THEN WRITE(2,33) + ENDIF IN=0 IJKC=IC*JC DO M=1,IJKC @@ -2380,7 +2681,8 @@ C ENDIF IN=IN+1 IF(IJCT(I,J).LT.1 .OR. IJCT(I,J).GT.8)THEN - PRINT*, 'I, J, K, IJCT(I,J) = ', I,J,IJCT(I,J) + IF(MYRANK.EQ.0) PRINT*, 'I, J, K, IJCT(I,J) = ', + & I,J,IJCT(I,J) STOP 'ERROR!! INVALID (I,J) IN FILE WQBENMAP.INP' ENDIF L = LIJ(I,J) @@ -2388,12 +2690,15 @@ C IBENMAP(L,2) = IZSAND IF(IWQBENOX.NE.0) IBENMAP(L,3) = IZANOX XBENMUD(L) = XMUD / 100.0 + IF(MYRANK.EQ.0)THEN WRITE(2,34) L, I, J, XBENMUD(L), IBENMAP(L,1), IBENMAP(L,2) + ENDIF ENDDO 1112 CONTINUE IF(IN .NE. (LA-1))THEN - PRINT*, 'ALL ACTIVE WATER CELLS SHOULD BE MAPPED FOR WQ PAR.' - STOP 'ERROR!! NUMBER OF LINES IN FILE WQBENMAP.INP <> (LA-1)' + IF(MYRANK.EQ.0) PRINT*, + & 'ALL ACTIVE WATER CELLS SHOULD BE MAPPED FOR WQ PAR.' + STOP 'ERROR1!! NUMBER OF LINES IN FILE WQBENMAP.INP <> (LA-1)' ENDIF CLOSE(1) ENDIF @@ -2406,10 +2711,12 @@ C ENDDO ENDDO OPEN(1,FILE='CYANOMAP.INP',STATUS='UNKNOWN') - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) DO M=1,4 READ(1,30) TITLE(M) + IF(MYRANK.EQ.0)THEN WRITE(2,30) TITLE(M) + ENDIF ENDDO C C SKIP ALL COMMENT CARDS AT BEGINNING OF FILE: @@ -2418,29 +2725,44 @@ C CCMRM = '#' CALL SKIPCOMM(1, CCMRM) C - WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0)THEN WRITE(2,33) + ENDIF IN=0 IJKC=IC*JC DO M=1,IJKC READ(1,*,END=1113) I, J, ICYAMUD IN=IN+1 IF(IJCT(I,J).LT.1 .OR. IJCT(I,J).GT.8)THEN - PRINT*, 'I, J, K, IJCT(I,J) = ', I,J,IJCT(I,J) + IF(MYRANK.EQ.0) PRINT*, 'I, J, K, IJCT(I,J) = ', + & I,J,IJCT(I,J) STOP 'ERROR!! INVALID (I,J) IN FILE WQBENMAP.INP' ENDIF L = LIJ(I,J) ICYAMAP(L) = ICYAMUD + IF(MYRANK.EQ.0)THEN WRITE(2,34) L, I, J, ICYAMAP(L) + ENDIF ENDDO 1113 CONTINUE IF(IN .NE. (LA-1))THEN - PRINT*, 'ALL ACTIVE WATER CELLS SHOULD BE MAPPED FOR WQ PAR.' + IF(MYRANK.EQ.0) PRINT*, + & 'ALL ACTIVE WATER CELLS SHOULD BE MAPPED FOR WQ PAR.' STOP 'ERROR2!! NUMBER OF LINES IN FILE WQBENMAP.INP <> (LA-1)' ENDIF CLOSE(1) ENDIF - CLOSE(2) + +! IF(ISCYANO.EQ.1)THEN +! OPEN(1,FILE='CYANO.OUT') +! CLOSE(1,STATUS='DELETE') +! OPEN(1,FILE='CYANO.OUT') +! CLOSE(1) +! ENDIF +!} GeoSR Bentic-cyano : JHLEE 2015.10.12 + + IF(MYRANK.EQ.0) CLOSE(2) 2222 FORMAT(' M,WQKTR(1),WQTDKR(M,1) = ',I5,2F10.4) 2223 FORMAT(' M,I,WQKTR(1),WQTDKR(M,I) = ',2I5,2F10.4) 30 FORMAT(A79) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.patch b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.patch deleted file mode 100644 index 952fce85a..000000000 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.patch +++ /dev/null @@ -1,27 +0,0 @@ -diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.for -index 1fbad036b..3e8b24c1e 100644 ---- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.for -+++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQC1.for -@@ -2205,16 +2205,16 @@ C INITIALIZE - write(1,'(a,a)') 'VERTICAL VELOCITY, ALGAL-DENSITY,' - & ,' SOLAR RADIATION, chl-a PRINT AT EACH LAYER' - write(1,'(a,i4,a,i4)') 'I=',iww(i),' J=',jww(i) -- write(1,7111) ' tm' -- & ,((('vel_',nsp,'_',k),nsp=1,NXSP),k=KC,1,-1) -- & ,((('den_',nsp,'_',k),nsp=1,NXSP),k=KC,1,-1) -- & ,((('sol_',nsp,'_',k),nsp=1,NXSP),k=KC,1,-1) -- & ,(('chl_',k),k=KC,1,-1) -+c write(1,7111) ' tm' -+c & ,((('vel_',nsp,'_',k),nsp=1,NXSP),k=KC,1,-1) -+c & ,((('den_',nsp,'_',k),nsp=1,NXSP),k=KC,1,-1) -+c & ,((('sol_',nsp,'_',k),nsp=1,NXSP),k=KC,1,-1) -+c & ,(('chl_',k),k=KC,1,-1) - CLOSE(1) - enddo - ENDIF - ENDIF -- 7111 format(a, 3(((3x,a,i2.2,a,i2.2))),(6x,a,i2.2) ) -+c 7111 format(a, 3(((3x,a,i2.2,a,i2.2))),(6x,a,i2.2) ) - !{ GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 - if (IWQDGSTOX.eq.1) then - IF(MYRANK.EQ.0)THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQCSR.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQCSR.for index d8c473812..3747fdc0a 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQCSR.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQCSR.for @@ -3,17 +3,19 @@ C C CHANGE RECORD C USE GLOBAL - + USE MPI IMPLICIT NONE CHARACTER*11 FNWQSR(40) CHARACTER*2 SNUM - INTEGER*4 I,NT,NW,IS,NS,ISO,ISTYP,K,M,M1,M2,LL,L,NSID - REAL RMULADJ,ADDADJ,CSERTMP,TIME,TDIFF,WTM1,WTM2 + INTEGER*4 NT,NW,IS,NS,ISO,ISTYP,K,M + REAL RMULADJ,ADDADJ,CSERTMP CHARACTER*12 FNWQSRX(NXSP) ! X-species INTEGER*4 nsp ! Number of x-species. + IF(MYRANK.EQ.0)THEN PRINT *,'WQ: READING CWQSRxx.INP - WQ CONCENTRATION TIME SERIES' + ENDIF ! *** DEFINE THE INPUT FILE NAMES DO NW = 1,NWQV @@ -72,9 +74,9 @@ C STOP 901 CONTINUE if (NXSP.gt.0) then - ! Deal with x-species - PRINT *, - & 'WQ: READING CWQSRX##.INP, X WQ CONCENTRATION TIME SERIES' + IF(MYRANK.EQ.0)THEN + PRINT *,'WQ: READING CWQSRX##.INP, X WQ CONCENTRATION TIME SERIES' + ENDIF DO nsp=1,NXSP WRITE(SNUM,'(I2.2)')nsp FNWQSRX(nsp)='CWQSRX'//SNUM//'.INP' @@ -130,8 +132,7 @@ C 801 CONTINUE 1 FORMAT(120X) 601 FORMAT(' READ ERROR WQ TIME SERIES, NWQ,NSER,MDATA = ',3I5) - 602 FORMAT(' READ OF FILES CWQSRNN.INP SUCCESSFUL'/) - +C 602 FORMAT(' READ OF FILES CWQSRNN.INP SUCCESSFUL'/) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQICI.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQICI.for index 3307c1eb7..e758c1e0c 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQICI.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQICI.for @@ -4,7 +4,8 @@ C CHANGE RECORD C READ IN SPATIALLY AND/OR TEMPORALLY VARYING ICS (UNIT INWQICI). C USE GLOBAL - CHARACTER TITLE(3)*79, ICICONT*3 + USE MPI + CHARACTER TITLE(3)*79 REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XWQV IF(.NOT.ALLOCATED(XWQV))THEN ALLOCATE(XWQV(NWQVM)) @@ -12,16 +13,18 @@ C ENDIF C OPEN(1,FILE=ICIFN,STATUS='UNKNOWN') + IF(MYRANK.EQ.0)THEN OPEN(2,FILE='WQ3D.OUT',STATUS='UNKNOWN',POSITION='APPEND') + ENDIF - WRITE(2,60)'* READING INITIAL CONDITIONS' + IF(MYRANK.EQ.0)WRITE(2,60)'* READING INITIAL CONDITIONS' READ(1,50) (TITLE(M),M=1,3) - WRITE(2,999) - WRITE(2,50) (TITLE(M),M=1,3) + IF(MYRANK.EQ.0)WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,50) (TITLE(M),M=1,3) READ(1,999) READ(1,50) TITLE(1) - WRITE(2,50) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,50) TITLE(1) DO M=2,LA READ(1,84) I,J,(XWQV(NW),NW=1,NWQV) IF(IJCT(I,J).LT.1 .OR. IJCT(I,J).GT.8)THEN @@ -34,7 +37,7 @@ C WQV(L,K,NW)=XWQV(NW) ENDDO ENDDO - WRITE(2,84) I,J,(WQV(L,1,NW),NW=1,NWQV) + IF(MYRANK.EQ.0)WRITE(2,84) I,J,(WQV(L,1,NW),NW=1,NWQV) ENDDO C C: WQCHLX=1/WQCHLX @@ -61,11 +64,11 @@ C IWQICI = 0 CLOSE(1) - CLOSE(2) + IF(MYRANK.EQ.0) CLOSE(2) 999 FORMAT(1X) 50 FORMAT(A79) - 52 FORMAT(I7, 1X, A3) +C 52 FORMAT(I7, 1X, A3) 60 FORMAT(/, A24, I5, A24) ! 84 FORMAT(3I5, 21E12.4) ! BUG -> EDITED BY GEOSR : JGCHO 2010.11.11 84 FORMAT(2I5,21E12.4) ! EDITED BY GEOSR : JGCHO 2010.11.11 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQPSL.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQPSL.for index 9fe23b228..c4711a3bd 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQPSL.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQPSL.for @@ -9,6 +9,7 @@ C C CHANGE RECORD C USE GLOBAL + USE MPI DIMENSION RLDTMP(NTSWQVM) C IF(ITNWQ.GT.0) GOTO 1000 @@ -77,12 +78,12 @@ C ENDIF GOTO 901 900 CONTINUE - WRITE(6,601)NS,M + IF(MYRANK.EQ.0) WRITE(6,601)NS,M STOP 901 CONTINUE 1 FORMAT(120X) 601 FORMAT(' READ ERROR WQPS TIME SERIES, NSER,MDATA = ',2I5) - 602 FORMAT(' READ OF FILE WQPSL.INP SUCCESSFUL'/) +C 602 FORMAT(' READ OF FILE WQPSL.INP SUCCESSFUL'/) 1000 CONTINUE C C ** INITIALIZE NULL SERIES LOADING TO ZERO @@ -120,7 +121,7 @@ C ENDDO ENDDO C - IF(ITNWQ.EQ.0.AND.DEBUG)THEN + IF(ITNWQ.EQ.0.AND.DEBUG.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='WQPSLT.DIA',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='WQPSLT.DIA',STATUS='UNKNOWN') @@ -136,7 +137,7 @@ C M.R. MORTON 02/20/1999 C MODIFIED SO MULTIPLE POINT SOURCES CAN BE ADDED TO ANY GRID CELL C AND ANY LAYER (HAD TO CHANGE WQWPSL ARRAY FROM 2D TO 3D). C - IF(ITNWQ.EQ.0)THEN + IF(ITNWQ.EQ.0.AND.MYRANK.EQ.0)THEN DO NW=1,NWQV DO K=1,KC DO L=2,LA @@ -175,7 +176,8 @@ C *** LOOP OVER THE WQ BOUNDARY CELLS L = LIJ(ICPSL(NS), JCPSL(NS)) K = KCPSL(NS) ITMP = MVPSL(NS) - IF(ITNWQ.EQ.0) WRITE(1,121)NS,L,ICPSL(NS),JCPSL(NS),K,ITMP + IF(ITNWQ.EQ.0.AND.MYRANK.EQ.0) + & WRITE(1,121)NS,L,ICPSL(NS),JCPSL(NS),K,ITMP IF(K.GE.1)THEN ! *** K>0, ASSIGN A SPECIFIC LAYER DO NW=1,NWQV @@ -194,7 +196,7 @@ C *** LOOP OVER THE WQ BOUNDARY CELLS ENDIF ENDDO - IF(ITNWQ.EQ.0)THEN + IF(ITNWQ.EQ.0.AND.MYRANK.EQ.0)THEN DO L=2,LA ITMP=IWQPSC(L,1) IF(ITMP.GT.0)THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQRST.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQRST.for index 3c790e556..4387f28d1 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQRST.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQRST.for @@ -4,6 +4,7 @@ C CHANGE RECORD C READ ICS FROM RESTART FILE FROM INWQRST. C USE GLOBAL + USE MPI LOGICAL FEXIST C C CHECK FIRST TO SEE IF BINARY RESTART FILE EXISTS. IF NOT, USE @@ -12,7 +13,7 @@ C LK=(LA-1)*KC INQUIRE(FILE='WQWCRST.BIN', EXIST=FEXIST) IF(.NOT. FEXIST)THEN - PRINT *,'WQ: RESTART: WQWCRST.INP' + IF(MYRANK.EQ.0)PRINT *,'WQ: RESTART: WQWCRST.INP' OPEN(1,FILE='WQWCRST.INP',STATUS='UNKNOWN') READ(1,999) READ(1,999) @@ -23,12 +24,12 @@ C ENDDO CLOSE(1) ELSE - PRINT *,'WQ: RESTART: WQWCRST.BIN' + IF(MYRANK.EQ.0)PRINT *,'WQ: RESTART: WQWCRST.BIN' OPEN(UNIT=1, FILE='WQWCRST.BIN', & FORM='UNFORMATTED', STATUS='UNKNOWN') READ(1) NN_, XTIME XTIME=XTIME - WRITE(0,911) NN_, XTIME + IF(MYRANK.EQ.0)WRITE(0,911) NN_, XTIME 911 FORMAT(' READING BINARY WQWCRST.BIN FILE ... NN, TIME = ', & I7, F11.5) NWQV0=NWQV @@ -53,7 +54,7 @@ C ENDDO ENDIF ENDIF - 90 FORMAT(2I5, 21E12.4) +C 90 FORMAT(2I5, 21E12.4) 999 FORMAT(1X) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQSTL.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQSTL.for index 40b4bfec0..28299ce40 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQSTL.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQSTL.for @@ -17,48 +17,59 @@ C *** WQWSM = Settling velocity for macroalgae (m/day = 0.0) C *** WQWSM = Reaeration adjustment factor (NOT SAVED) C USE GLOBAL + USE MPI C CHARACTER TITLE(3)*79, STLCONT*3 C OPEN(7892,FILE=STLFN,STATUS='UNKNOWN') + IF(MYRANK.EQ.0) THEN OPEN(2,FILE='WQ3D.OUT',STATUS='UNKNOWN',POSITION='APPEND') + ENDIF IF(STLDAY.EQ.0) THEN READ(7892,50) (TITLE(M),M=1,3) - WRITE(2,999) - WRITE(2,50) (TITLE(M),M=1,3) + IF(MYRANK.EQ.0) WRITE(2,999) + IF(MYRANK.EQ.0) WRITE(2,50) (TITLE(M),M=1,3) ENDIF - WRITE(2,60)'* SETTLING VELOCITY AT ', TIMTMP, +! WRITE(2,60)'* SETTLING VELOCITY AT ', IWQTSTL, ! GEOSR DAY read jgcho 2016.10.06 + IF(MYRANK.EQ.0) THEN + WRITE(2,60)'* SETTLING VELOCITY AT ', TIMTMP, ! GEOSR DAY read jgcho 2016.10.06 & ' TH DAY FROM MODEL START' + ENDIF READ(7892,999) READ(7892,50) TITLE(1) - WRITE(2,50) TITLE(1) + IF(MYRANK.EQ.0) WRITE(2,50) TITLE(1) IF(NXSP.EQ.0)THEN DO I=1,IWQZ READ(7892,*) MM,WQWSC(I),WQWSD(I),WQWSG(I),WQWSRP(I), & WQWSLP(I),WQWSS(I), WQWSM + IF(MYRANK.EQ.0) THEN WRITE(2,51) MM,WQWSC(I),WQWSD(I),WQWSG(I),WQWSRP(I),WQWSLP(I), & WQWSS(I), WQWSM + ENDIF ENDDO ELSE ! x-species require more variables to be exchanged DO I=1,IWQZ READ(7892,*) MM,WQWSC(I),WQWSD(I),WQWSG(I),WQWSRP(I), & WQWSLP(I),WQWSS(I), WQWSM,(WQWSX(I,NSP),NSP=1,NXSP) + IF(MYRANK.EQ.0) THEN WRITE(2,51) MM,WQWSC(I),WQWSD(I),WQWSG(I),WQWSRP(I),WQWSLP(I), & WQWSS(I), WQWSM,(WQWSX(I,NSP),NSP=1,NXSP) + ENDIF ENDDO ENDIF READ(7892,*) STLDAY, STLCONT + IF(MYRANK.EQ.0) WRITE(2,*) STLDAY, STLCONT WRITE(2,*) STLDAY, STLCONT IF(STLCONT.EQ.'END')THEN CLOSE(7892) IWQSTL = 0 ENDIF - CLOSE(2) + IF(MYRANK.EQ.0)CLOSE(2) 999 FORMAT(1X) 50 FORMAT(A79) 51 FORMAT(I3, 50F8.3) - 52 FORMAT(I7, 1X, A3) +C 52 FORMAT(I7, 1X, A3) 60 FORMAT(/, A24, F5.1, A24) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQSUN.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQSUN.for index 6ff82c8b7..cfa15f877 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQSUN.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/RWQSUN.for @@ -10,11 +10,12 @@ C ** READS AND INTERPOLATES DAILY AVERAGE SOLAR RADIATION AND C ** DAYLIGHT FRACTION C USE GLOBAL + USE MPI IF(ITNWQ.GT.0) GOTO 1000 C C ** READ IN DAILY AVERAGE SOLAR SW RAD SERIES FROM FILE 'SUNDAY.INP' C - PRINT *,'WQ: SUNDAY.INP' + IF(MYRANK.EQ.0)PRINT *,'WQ: SUNDAY.INP' OPEN(1,FILE='SUNDAY.INP',STATUS='UNKNOWN') C C ** SKIP OVER TITLE AND AND HEADER LINES @@ -39,7 +40,7 @@ C CLOSE(1) GOTO 901 900 CONTINUE - WRITE(6,601)M + IF(MYRANK.EQ.0)WRITE(6,601)M STOP 901 CONTINUE 1 FORMAT(120X) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALPLTH.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALPLTH.for index f8f99603b..c306a1cb2 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALPLTH.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALPLTH.for @@ -10,6 +10,8 @@ C CHARACTER*80 TITLE DIMENSION CONC(LCM,KCM) REAL,ALLOCATABLE,DIMENSION(:)::DBSB + INTEGER LUN + LUN=0 IF(.NOT.ALLOCATED(DBSB)) ALLOCATE(DBSB(0:NSTM)) DBSB=0. @@ -560,9 +562,9 @@ C 100 FORMAT(I10,F12.4) 101 FORMAT(2I10) 200 FORMAT(2I5,1X,8E14.6) - 220 FORMAT(2I5,1X,13E11.3) +C 220 FORMAT(2I5,1X,13E11.3) 400 FORMAT(1X,8E14.6) - 420 FORMAT(1X,13E12.4) +C 420 FORMAT(1X,13E12.4) 250 FORMAT(12E12.4) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALPLTH_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALPLTH_mpi.for new file mode 100644 index 000000000..34effde9c --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALPLTH_mpi.for @@ -0,0 +1,589 @@ + SUBROUTINE SALPLTH_mpi (ICON,CONC) +C +C CHANGE RECORD +C ** SUBROUTINE SALPLTH WRITES FILES FOR INSTANTANEOUS SCALAR FIELD +C ** CONTOURING IN HORIZONTAL PLANES +C + USE GLOBAL + USE MPI + + DIMENSION DBS(10) + CHARACTER*80 TITLE + DIMENSION CONC(LCM,KCM) + REAL,ALLOCATABLE,DIMENSION(:)::DBSB + INTEGER LUN + LUN=0 + + S1TIME=MPI_TIC() + ALLOCATE(DBSB(0:NSTM)) + DBSB=0. + MPI_WTIMES(881)=MPI_WTIMES(881)+MPI_TOC(S1TIME) +C + IF(JSSPH(ICON).NE.1) GOTO 300 + S1TIME=MPI_TIC() + LINES=LA-1 + LEVELS=2 + LEVELSS=3 + DBS(1)=0. + DBS(2)=99. + DBS(3)=-99. + LSEDCL=NSED+NSND + DO L=0,LSEDCL + DBSB(L)=FLOAT(L) + ENDDO + IF(ICON.EQ.1.AND.ISPHXY(1).LE.2.AND.MYRANK.EQ.0)THEN + TITLE='INSTANTANEOUS HORIZONTAL SALINITY CONTOURS' + LUN=11 + OPEN(LUN,FILE='SALCONH.OUT') + CLOSE(LUN,STATUS='DELETE') + OPEN(LUN,FILE='SALCONH.OUT') + WRITE (LUN,99) TITLE + WRITE (LUN,101)LINES,LEVELS + WRITE (LUN,250)(DBS(L),L=1,LEVELS) + CLOSE(LUN) + ENDIF + IF(ICON.EQ.2.AND.ISPHXY(2).LE.2.AND.MYRANK.EQ.0)THEN + TITLE='INSTANTANEOUS HORIZONTAL TEMPERATURE CONTOURS' + LUN=12 + OPEN(LUN,FILE='TEMCONH.OUT') + CLOSE(LUN,STATUS='DELETE') + OPEN(LUN,FILE='TEMCONH.OUT') + WRITE (LUN,99) TITLE + WRITE (LUN,101)LINES,LEVELS + WRITE (LUN,250)(DBS(L),L=1,LEVELS) + CLOSE(LUN) + ENDIF + IF(ICON.EQ.3.AND.ISPHXY(3).LE.2.AND.MYRANK.EQ.0)THEN + TITLE='INSTANTANEOUS HORIZONTAL DYE CONC CONTOURS' + LUN=13 + OPEN(LUN,FILE='DYECONH.OUT') + CLOSE(LUN,STATUS='DELETE') + OPEN(LUN,FILE='DYECONH.OUT') + WRITE (LUN,99) TITLE + WRITE (LUN,101)LINES,LEVELS + WRITE (LUN,250)(DBS(L),L=1,LEVELS) + CLOSE(LUN) + ENDIF + IF(ICON.EQ.6.AND.ISPHXY(6).LE.2.AND.MYRANK.EQ.0)THEN + TITLE='INSTANTANEOUS HORIZ COHESIVE SEDIMENT CONC CONTOURS' + LUN=14 + OPEN(LUN,FILE='SEDCONH.OUT') + CLOSE(LUN,STATUS='DELETE') + OPEN(LUN,FILE='SEDCONH.OUT') + WRITE (LUN,99) TITLE + WRITE (LUN,101)LINES,LEVELSS + WRITE (LUN,250)(DBS(L),L=1,LEVELSS) + CLOSE(LUN) + ENDIF +C +C TITLE='INSTANTANEOUS BED SED DEPOSITED CONTOURS GM/M**2' +C LUN=15 +C + IF(ICON.EQ.7.AND.ISPHXY(7).LE.2.AND.MYRANK.EQ.0)THEN + IF(NSND.GE.1)THEN + TITLE='INSTANTANEOUS HORIZ NONCOH SEDIMENT CONC CONTOURS' + LUN=15 + OPEN(LUN,FILE='SNDCONH.OUT') + CLOSE(LUN,STATUS='DELETE') + OPEN(LUN,FILE='SNDCONH.OUT') + WRITE (LUN,99) TITLE + WRITE (LUN,101)LINES,LEVELSS + WRITE (LUN,250)(DBS(L),L=1,LEVELSS) + CLOSE(LUN) + ENDIF + IF(NSND.GE.2.AND.MYRANK.EQ.0)THEN + TITLE='INSTANTANEOUS HORIZ NONCOH SEDIMENT CONC CONTOURS' + LUN=15 + OPEN(LUN,FILE='SNDCONH01.OUT') + CLOSE(LUN,STATUS='DELETE') + OPEN(LUN,FILE='SNDCONH01.OUT') + WRITE (LUN,99) TITLE + WRITE (LUN,101)LINES,LEVELSS + WRITE (LUN,250)(DBS(L),L=1,LEVELSS) + CLOSE(LUN) + OPEN(LUN,FILE='SNDCONH02.OUT') + CLOSE(LUN,STATUS='DELETE') + OPEN(LUN,FILE='SNDCONH02.OUT') + WRITE (LUN,99) TITLE + WRITE (LUN,101)LINES,LEVELSS + WRITE (LUN,250)(DBS(L),L=1,LEVELSS) + CLOSE(LUN) + ENDIF + IF(NSND.GE.3.AND.MYRANK.EQ.0)THEN + TITLE='INSTANTANEOUS HORIZ NONCOH SEDIMENT CONC CONTOURS' + LUN=15 + OPEN(LUN,FILE='SNDCONH03.OUT') + CLOSE(LUN,STATUS='DELETE') + OPEN(LUN,FILE='SNDCONH03.OUT') + WRITE (LUN,99) TITLE + WRITE (LUN,101)LINES,LEVELSS + WRITE (LUN,250)(DBS(L),L=1,LEVELSS) + CLOSE(LUN) + ENDIF + ENDIF +C +C TITLE='INSTANTANEOUS BED SED DEPOSITED CONTOURS GM/M**2' +C LUN=15 +C + IF(ICON.EQ.5.AND.ISPHXY(5).LE.2.AND.MYRANK.EQ.0)THEN + TITLE='INSTANTANEOUS HORIZ TOXIC CONTAM. CONC CONTOURS' + LUN=16 + OPEN(LUN,FILE='TOXCONH.OUT') + CLOSE(LUN,STATUS='DELETE') + OPEN(LUN,FILE='TOXCONH.OUT') + WRITE (LUN,99) TITLE + WRITE (LUN,101)LINES,LEVELSS + WRITE (LUN,250)(DBS(L),L=1,LEVELSS) + CLOSE(LUN) + TITLE='INSTANTANEOUS HORIZ TOXIC PART FRAC CONTOURS' + LUNF=26 + OPEN(LUNF,FILE='TXPCONH.OUT') + CLOSE(LUNF,STATUS='DELETE') + OPEN(LUNF,FILE='TXPCONH.OUT') + WRITE (LUNF,99) TITLE + WRITE (LUNF,101)LINES,LEVELSS + WRITE (LUNF,250)(DBS(L),L=1,LEVELSS) + CLOSE(LUNF) + ENDIF + IF(ICON.EQ.4.AND.ISPHXY(4).LE.2.AND.MYRANK.EQ.0)THEN + TITLE='INSTANTANEOUS HORIZONTAL SFL CONC CONTOURS' + LUN=17 + OPEN(LUN,FILE='SFLCONH.OUT') + CLOSE(LUN,STATUS='DELETE') + OPEN(LUN,FILE='SFLCONH.OUT') + WRITE (LUN,99) TITLE + WRITE (LUN,101)LINES,LEVELSS + WRITE (LUN,250)(DBS(L),L=1,LEVELSS) + CLOSE(LUN) + ENDIF + JSSPH(ICON)=0 + MPI_WTIMES(882)=MPI_WTIMES(882)+MPI_TOC(S1TIME) + 300 CONTINUE + S1TIME=MPI_TIC() + IF(ICON.EQ.1.AND.ISPHXY(1).LE.2.AND.MYRANK.EQ.0)THEN + LUN=11 + OPEN(LUN,FILE='SALCONH.OUT',POSITION='APPEND') + ENDIF + IF(ICON.EQ.2.AND.ISPHXY(2).LE.2.AND.MYRANK.EQ.0)THEN + LUN=12 + OPEN(LUN,FILE='TEMCONH.OUT',POSITION='APPEND') + ENDIF + IF(ICON.EQ.3.AND.ISPHXY(3).LE.2.AND.MYRANK.EQ.0)THEN + LUN=13 + OPEN(LUN,FILE='DYECONH.OUT',POSITION='APPEND') + ENDIF + IF(ICON.EQ.6.AND.ISPHXY(6).LE.2.AND.MYRANK.EQ.0)THEN + LUN=14 + OPEN(LUN,FILE='SEDCONH.OUT',POSITION='APPEND') + ENDIF + IF(ICON.EQ.7.AND.ISPHXY(7).LE.2.AND.MYRANK.EQ.0)THEN + LUN=15 + OPEN(LUN,FILE='SNDCONH.OUT',POSITION='APPEND') + IF(NSND.GE.2)THEN + LUN1=25 + OPEN(LUN1,FILE='SNDCONH01.OUT',POSITION='APPEND') + LUN2=35 + OPEN(LUN2,FILE='SNDCONH02.OUT',POSITION='APPEND') + ENDIF + IF(NSND.GE.3)THEN + LUN3=45 + OPEN(LUN3,FILE='SNDCONH03.OUT',POSITION='APPEND') + ENDIF + ENDIF + IF(ICON.EQ.5.AND.ISPHXY(5).LE.2.AND.MYRANK.EQ.0)THEN + LUN=16 + OPEN(LUN,FILE='TOXCONH.OUT',POSITION='APPEND') + LUNF=26 + OPEN(LUNF,FILE='TXPCONH.OUT',POSITION='APPEND') + ENDIF + IF(ICON.EQ.4.AND.ISPHXY(4).LE.2.AND.MYRANK.EQ.0)THEN + LUN=17 + OPEN(LUN,FILE='SFLCONH.OUT',POSITION='APPEND') + ENDIF + MPI_WTIMES(883)=MPI_WTIMES(883)+MPI_TOC(S1TIME) +C +C LUB=18 +C LUB=18 +C + S1TIME=MPI_TIC() + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N)+TCON*TBEGIN + TIME=TIME/TCON + ELSE + TIME=TIMESEC/TCON + ENDIF + IF(ISPHXY(ICON).LE.2.AND.MYRANK.EQ.0)THEN + WRITE (LUN,100)N,TIME + IF(ICON.EQ.5)THEN + WRITE (LUNF,100)N,TIME + ENDIF + IF(ICON.EQ.7)THEN + IF(NSND.GE.2)THEN + WRITE (LUN1,100)N,TIME + WRITE (LUN2,100)N,TIME + ENDIF + IF(NSND.GE.3)THEN + WRITE (LUN3,100)N,TIME + ENDIF + ENDIF + ENDIF + IF(ISPHXY(ICON).EQ.0.AND.MYRANK.EQ.0)THEN + IF(ICON.LE.3)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,400)CONC(L,1) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,400)CONC(L,KC),CONC(L,1) + ENDDO + ENDIF + ENDIF + IF(ICON.GE.8)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,400)CONC(L,1) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,400)CONC(L,KC),CONC(L,1) + ENDDO + ENDIF + ENDIF + IF(ICON.EQ.6)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,400)CONC(L,1),SEDBT(L,KBT(L)),SEDF(L,0,1) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,400)CONC(L,KC),CONC(L,1),SEDBT(L,KBT(L)), + & SEDF(L,0,1) + ENDDO + ENDIF + ENDIF + IF(ICON.EQ.7)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,400)CONC(L,1),SNDBT(L,KBT(L)) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,400)CONC(L,KC),CONC(L,1),SNDBT(L,KBT(L)) + ENDDO + ENDIF + IF(NSND.GE.2)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN1,400)SND(L,1,1),SNDB(L,KBT(L),1), + & SNDF(L,0,1),SNDFBL(L,1),CQBEDLOADX(L,1) + WRITE(LUN2,400)SND(L,1,2),SNDB(L,KBT(L),2), + & SNDF(L,0,2),SNDFBL(L,2),CQBEDLOADX(L,2) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN1,400)SND(L,KC,1),SND(L,1,1),SNDB(L,KBT(L),1), + & SNDF(L,0,1),SNDFBL(L,1),CQBEDLOADX(L,1) + WRITE(LUN2,400)SND(L,KC,2),SND(L,1,2),SNDB(L,KBT(L),2), + & SNDF(L,0,2),SNDFBL(L,2),CQBEDLOADX(L,2) + ENDDO + ENDIF + ENDIF + IF(NSND.GE.3)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN3,400)SND(L,1,NSND),SNDB(L,KBT(L),NSND), + & SNDF(L,0,NSND),SNDFBL(L,NSND),CQBEDLOADX(L,NSND) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN3,400)SND(L,KC,NSND),SND(L,1,NSND), + & SNDB(L,KBT(L),NSND),SNDF(L,0,NSND),SNDFBL(L,NSND), + & CQBEDLOADX(L,NSND) + ENDDO + ENDIF + ENDIF + ENDIF + IF(ICON.EQ.5)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,400)TOX(L,1,1),TOXB(L,KBT(L),1), + & TOXF(L,0,1),TOXFB(L,KBT(L),1) + WRITE(LUNF,400)TOXPFTW(L,1,1),TOXPFTB(L,KBT(L),1) + ENDDO + ENDIF + IF(KC.GT.1)THEN + DO L=2,LA + WRITE(LUN,400)TOX(L,KC,1),TOX(L,1,1),TOXB(L,KBT(L),1), + & TOXB(L,1,1) + WRITE(LUNF,400)TOXPFTW(L,KC,1),TOXPFTW(L,1,1), + & TOXPFTB(L,KBT(L),1),TOXPFTB(L,1,1) + ENDDO + ENDIF + CLOSE(LUNF) + ENDIF + IF(ICON.EQ.4)THEN + DO L=2,LA + WRITE(LUN,400)CONC(L,KC),CONC(L,1), + & SFLSBOT(L) + ENDDO + ENDIF + ENDIF + MPI_WTIMES(884)=MPI_WTIMES(884)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(ISPHXY(ICON).EQ.1.AND.MYRANK.EQ.0)THEN + IF(ICON.LE.3)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),CONC(L,1) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),CONC(L,KC),CONC(L,1) + ENDDO + ENDIF + ENDIF + IF(ICON.GE.8)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),CONC(L,1) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),CONC(L,KC),CONC(L,1) + ENDDO + ENDIF + ENDIF + IF(ICON.EQ.6)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),CONC(L,1),SEDBT(L,KBT(L)), + & SEDF(L,0,1) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),CONC(L,KC),CONC(L,1), + & SEDBT(L,KBT(L)),SEDF(L,0,1) + ENDDO + ENDIF + ENDIF + IF(ICON.EQ.7)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),CONC(L,1),SNDBT(L,KBT(L)) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),CONC(L,KC),CONC(L,1), + & SNDBT(L,KBT(L)) + ENDDO + ENDIF + IF(NSND.GE.2)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN1,200)IL(L),JL(L),SND(L,1,1),SNDB(L,KBT(L),1), + & SNDF(L,0,1),SNDFBL(L,1),CQBEDLOADX(L,1) + WRITE(LUN2,200)IL(L),JL(L),SND(L,1,2),SNDB(L,KBT(L),2), + & SNDF(L,0,2),SNDFBL(L,2),CQBEDLOADX(L,2) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN1,200)IL(L),JL(L),SND(L,KC,1),SND(L,1,1), + & SNDB(L,KBT(L),1),SNDF(L,0,1),SNDFBL(L,1) + & ,CQBEDLOADX(L,1) + WRITE(LUN2,200)IL(L),JL(L),SND(L,KC,2),SND(L,1,2), + & SNDB(L,KBT(L),2),SNDF(L,0,2),SNDFBL(L,2) + & ,CQBEDLOADX(L,2) + ENDDO + ENDIF + ENDIF + IF(NSND.GE.3)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN3,200)IL(L),JL(L),SND(L,1,NSND),SNDB(L,KBT(L) + & ,NSND),SNDF(L,0,NSND),SNDFBL(L,NSND) + & ,CQBEDLOADX(L,NSND) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN3,200)IL(L),JL(L),SND(L,KC,NSND),SND(L,1,NSND), + & SNDB(L,KBT(L),NSND),SNDF(L,0,NSND),SNDFBL(L,NSND), + & CQBEDLOADX(L,NSND) + ENDDO + ENDIF + ENDIF + ENDIF + IF(ICON.EQ.5)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),TOX(L,1,1),TOXB(L,KBT(L),1), + & TOXF(L,0,1),TOXFB(L,KBT(L),1) + WRITE(LUNF,200)IL(L),JL(L),TOXPFTW(L,1,1),TOXPFTB(L, + & KBT(L),1) + ENDDO + ENDIF + IF(KC.GT.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),TOX(L,KC,1),TOX(L,1,1), + & TOXB(L,KBT(L),1),TOXB(L,1,1) + WRITE(LUNF,200)IL(L),JL(L),TOXPFTW(L,KC,1),TOXPFTW(L,1,1), + & TOXPFTB(L,KBT(L),1),TOXPFTB(L,1,1) + ENDDO + ENDIF + CLOSE(LUNF) + ENDIF + IF(ICON.EQ.4)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),CONC(L,KC),CONC(L,1), + & SFLSBOT(L) + ENDDO + ENDIF + ENDIF + MPI_WTIMES(885)=MPI_WTIMES(885)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(ISPHXY(ICON).EQ.2.AND.MYRANK.EQ.0)THEN + IF(ICON.LE.3)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),CONC(L,1) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),CONC(L,KC) + & ,CONC(L,1) + ENDDO + ENDIF + ENDIF + IF(ICON.GE.8)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),CONC(L,1) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),CONC(L,KC) + & ,CONC(L,1) + ENDDO + ENDIF + ENDIF + IF(ICON.EQ.6)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),CONC(L,1), + & SEDBT(L,KBT(L)),SEDF(L,0,1) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),CONC(L,KC) + & ,CONC(L,1),SEDBT(L,KBT(L)),SEDF(L,0,1) + ENDDO + ENDIF + ENDIF + IF(ICON.EQ.7)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),CONC(L,1), + & SNDBT(L,KBT(L)) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),CONC(L,KC) + & ,CONC(L,1),SNDBT(L,KBT(L)) + ENDDO + ENDIF + IF(NSND.GE.2)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN1,200)IL(L),JL(L),DLON(L),DLAT(L),SND(L,1,1), + & SNDB(L,KBT(L),1),SNDF(L,0,1),SNDFBL(L,1) + & ,CQBEDLOADX(L,1) + WRITE(LUN2,200)IL(L),JL(L),DLON(L),DLAT(L),SND(L,1,2), + & SNDB(L,KBT(L),2),SNDF(L,0,2),SNDFBL(L,2) + & ,CQBEDLOADX(L,2) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN1,200)IL(L),JL(L),DLON(L),DLAT(L),SND(L,KC,1), + & SND(L,1,1),SNDB(L,KBT(L),1),SNDF(L,0,1),SNDFBL(L,1), + & CQBEDLOADX(L,1) + WRITE(LUN2,200)IL(L),JL(L),DLON(L),DLAT(L),SND(L,KC,2), + & SND(L,1,2),SNDB(L,KBT(L),2),SNDF(L,0,2),SNDFBL(L,2), + & CQBEDLOADX(L,2) + ENDDO + ENDIF + ENDIF + IF(NSND.GE.3)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN3,200)IL(L),JL(L),DLON(L),DLAT(L),SND(L,1,NSND), + & SNDB(L,KBT(L),NSND),SNDF(L,0,NSND),SNDFBL(L,NSND), + & CQBEDLOADX(L,NSND) + ENDDO + ELSE + DO L=2,LA + WRITE(LUN3,200)IL(L),JL(L),DLON(L),DLAT(L),SND(L,KC,NSND), + & SND(L,1,NSND),SNDB(L,KBT(L),NSND), + & SNDF(L,0,NSND),SNDFBL(L,NSND),CQBEDLOADX(L,NSND) + ENDDO + ENDIF + ENDIF + ENDIF + IF(ICON.EQ.5)THEN + IF(KC.EQ.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),TOX(L,1,1), + & TOXB(L,KBT(L),1), + & TOXF(L,0,1),TOXFB(L,KBT(L),1) + WRITE(LUNF,200)IL(L),JL(L),DLON(L),DLAT(L),TOXPFTW(L,1,1), + & TOXPFTB(L,KBT(L),1) + ENDDO + ENDIF + IF(KC.GT.1)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),TOX(L,KC,1), + & TOX(L,1,1),TOXB(L,KBT(L),1),TOXB(L,1,1) + WRITE(LUNF,200)IL(L),JL(L),DLON(L),DLAT(L),TOXPFTW(L,KC,1), + & TOXPFTW(L,1,1),TOXPFTB(L,KBT(L),1),TOXPFTB(L,1,1) + ENDDO + ENDIF + CLOSE(LUNF) + ENDIF + IF(ICON.EQ.4)THEN + DO L=2,LA + WRITE(LUN,200)IL(L),JL(L),DLON(L),DLAT(L),CONC(L,KC), + & CONC(L,1),SFLSBOT(L) + ENDDO + ENDIF + ENDIF + MPI_WTIMES(886)=MPI_WTIMES(886)+MPI_TOC(S1TIME) + + S1TIME=MPI_TIC() + IF(ISPHXY(ICON).LE.2.AND.MYRANK.EQ.0)THEN + CLOSE(LUN) + IF(ICON.EQ.5)THEN + CLOSE(LUNF) + ENDIF + IF(ICON.EQ.7)THEN + IF(NSND.GE.2)THEN + CLOSE(LUN1) + CLOSE(LUN2) + ENDIF + IF(NSND.GE.3)THEN + CLOSE(LUN3) + ENDIF + ENDIF + ENDIF + MPI_WTIMES(887)=MPI_WTIMES(887)+MPI_TOC(S1TIME) + 99 FORMAT(A80) + 100 FORMAT(I10,F12.4) + 101 FORMAT(2I10) + 200 FORMAT(2I5,1X,8E14.6) +C 220 FORMAT(2I5,1X,13E11.3) + 400 FORMAT(1X,8E14.6) +C 420 FORMAT(1X,13E12.4) + 250 FORMAT(12E12.4) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALTSMTH.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALTSMTH.for index 6d66a6375..272475c9b 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALTSMTH.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALTSMTH.for @@ -80,7 +80,7 @@ C WRITE(1,9102)L,IL(L),JL(L),(SAL(L,K),K=1,KC) ENDDO CLOSE(1) - 6000 FORMAT(' COMPLE V1 SMOOTHING LAYER ',I5,' NSM = ',I5/) +C6000 FORMAT(' COMPLE V1 SMOOTHING LAYER ',I5,' NSM = ',I5/) 6001 FORMAT(' COMPLE V2 SMOOTHING LAYER ',I5,' NSM = ',I5/) 9101 FORMAT(I5) 9102 FORMAT(3I5,12F6.2) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALTSMTH_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALTSMTH_mpi.for new file mode 100644 index 000000000..241a83db4 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SALTSMTH_mpi.for @@ -0,0 +1,93 @@ + SUBROUTINE SALTSMTH_mpi +C +C CHANGE RECORD +C + USE GLOBAL + USE MPI + IF(NSBMAX.GT.10) GOTO 1001 +C +C ELSE +C GOTO 1001 +C + DO K=1,KC + DO L=2,LA + TVAR3S(L)=SAL(L,K) + ENDDO + DO NSM=1,NSBMAX + DO L=2,LA + IF(LCT(L).GT.0.AND.LCT(L).LT.9)THEN + I=IL(L) + J=JL(L) + HTN=TVAR3S(LNC(L)) + HTS=TVAR3S(LSC(L)) + HTE=TVAR3S(L+1) + HTW=TVAR3S(L-1) + IF(IJCT(I ,J+1).EQ.9) HTN=TVAR3S(L) + IF(IJCT(I ,J-1).EQ.9) HTS=TVAR3S(L) + IF(IJCT(I+1,J ).EQ.9) HTE=TVAR3S(L) + IF(IJCT(I-1,J ).EQ.9) HTW=TVAR3S(L) + TVAR3N(L)=(1.-WSMB)*TVAR3S(L)+0.25*WSMB*(HTN+HTS+HTE+HTW) + ENDIF + ENDDO + DO L=2,LA + TVAR3S(L)=TVAR3N(L) + ENDDO + ENDDO + DO L=2,LA + SAL(L,K)=TVAR3N(L) + SAL1(L,K)=TVAR3N(L) + ENDDO + ENDDO + GOTO 2000 +C +C ** IMPLEMENT SPECIAL SALINITY INITIALIZATION, VERSION 1 +C 1000 CONTINUE +C ** IMPLEMENT SPECIAL SALINITY INITIALIZATION, VERSION 2 +C + 1001 CONTINUE + DO K=1,KC + DO L=2,LA + TVAR3S(L)=SAL(L,K) + ENDDO + DO NSM=1,NSBMAX + DO L=2,LA + LN=LNC(L) + LS=LSC(L) + TVAR3N(L)=TVAR3S(L)+(WSMB/HMP(L)) + & *( HRU(L+1)*(TVAR3S(L+1)-TVAR3S(L )) + & -HRU(L )*(TVAR3S(L )-TVAR3S(L-1)) + & +HRV(LN )*(TVAR3S(LN )-TVAR3S(L )) + & -HRV(L )*(TVAR3S(L )-TVAR3S(LS )) ) + ENDDO + DO L=2,LA + IF(SALINIT(L,K).GT.0.0) TVAR3N(L)=SALINIT(L,K) + ENDDO + DO L=2,LA + TVAR3S(L)=TVAR3N(L) + ENDDO + ENDDO + DO L=2,LA + SAL(L,K)=TVAR3N(L) + SAL1(L,K)=TVAR3N(L) + ENDDO + IF(MYRANK.EQ.0) WRITE(6,6001)K,NSM + ENDDO + IF(MYRANK.EQ.0)THEN + OPEN(1,FILE='NEWSALT.INP',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='NEWSALT.INP',STATUS='UNKNOWN') + IONE=1 + WRITE(1,9101)IONE + DO L=2,LC-1 + WRITE(1,9102)L,IL(L),JL(L),(SAL(L,K),K=1,KC) + ENDDO + CLOSE(1) + ENDIF +C6000 FORMAT(' COMPLE V1 SMOOTHING LAYER ',I5,' NSM = ',I5/) + 6001 FORMAT(' COMPLE V2 SMOOTHING LAYER ',I5,' NSM = ',I5/) + 9101 FORMAT(I5) + 9102 FORMAT(3I5,12F6.2) + 2000 CONTINUE + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANASER.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANASER.for index 5daa22131..c59bfcd92 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANASER.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANASER.for @@ -1,8 +1,9 @@ SUBROUTINE SCANASER USE GLOBAL + USE MPI CHARACTER*120 LIN - WRITE(*,'(A)')'SCANNING INPUT FILE: ASER.INP' + IF(MYRANK.EQ.0) WRITE(*,'(A)')'SCANNING INPUT FILE: ASER.INP' OPEN(1,FILE='ASER.INP',STATUS='OLD') DO N=1,NASER 10 READ(1,*,ERR=10,END=40)M,R,R,I,R,R,R,R @@ -16,7 +17,8 @@ IF(ISTRAN(8).GT.0)THEN IF(IWQSUN.EQ.1)THEN - WRITE(*,'(A)')'SCANNING INPUT FILE: SUNDAY.INP' + IF(MYRANK.EQ.0) + & WRITE(*,'(A)')'SCANNING INPUT FILE: SUNDAY.INP' OPEN(1,FILE='SUNDAY.INP',STATUS='UNKNOWN') M=0 DO I = 1,7 @@ -30,12 +32,14 @@ RETURN - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANDSER.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANDSER.for index 27ac31e34..66ee2eb47 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANDSER.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANDSER.for @@ -1,6 +1,8 @@ SUBROUTINE SCANDSER(NCSER3) USE GLOBAL - WRITE(*,'(A)')'SCANNING INPUT FILE: DSER.INP' + USE MPI + INTEGER IOS + IF(MYRANK.EQ.0) WRITE(*,'(A)')'SCANNING INPUT FILE: DSER.INP' OPEN(1,FILE='DSER.INP',STATUS='OLD') DO NS=1,NCSER3 10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R @@ -18,12 +20,14 @@ ENDDO CLOSE(1) RETURN - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANEFDC.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANEFDC.for index be03a7a2e..29a7452c6 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANEFDC.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANEFDC.for @@ -1,9 +1,10 @@ SUBROUTINE SCANEFDC(NCSER1,NCSER2,NCSER3,NCSER4) USE GLOBAL + USE MPI CHARACTER*3 NCARD - WRITE(*,'(A)')'SCANNING INPUT FILE: EFDC.INP' + IF(MYRANK.EQ.0) WRITE(*,'(A)')'SCANNING INPUT FILE: EFDC.INP' OPEN(1,FILE='EFDC.INP',STATUS='OLD') CALL SEEK('C4') @@ -141,7 +142,9 @@ CALL SEEK('C40') READ(1,*,ERR=50)IWRSP(1) -50 WRITE(*,*)'NO COHESIVE SEDIMENT INFO IN INPUT FILE' +50 CONTINUE + IF(MYRANK.EQ.0) + & WRITE(*,*)'NO COHESIVE SEDIMENT INFO IN INPUT FILE' IF(NTOX.GT.0)THEN CALL SEEK('C45A') @@ -214,12 +217,14 @@ ENDIF RETURN - 10 WRITE(*,20) - WRITE(8,20) + 10 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,20) + IF(MYRANK.EQ.0) WRITE(8,20) 20 FORMAT('READ ERROR IN INPUT FILE') STOP - 30 WRITE(*,40) - WRITE(8,40) + 30 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,40) + IF(MYRANK.EQ.0) WRITE(8,40) 40 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGATECTL.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGATECTL.for index 9cd57973a..84e699f0f 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGATECTL.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGATECTL.for @@ -2,8 +2,9 @@ ! SUBROUTINE SCANGATECTL USE GLOBAL + USE MPI - WRITE(*,'(A)')'SCANNING INPUT FILE: GATECTL.INP' + IF(MYRANK.EQ.0) WRITE(*,'(A)')'SCANNING INPUT FILE: GATECTL.INP' OPEN(1,FILE='GATECTL.INP',STATUS='UNKNOWN') ! *** FINE MAXIMUM NUMBER OF GATE TYPES @@ -24,18 +25,23 @@ CLOSE(1) ! { GEOSR 2014.11.12 UNG Warning message writing + IF(MYRANK.EQ.0.AND.DEBUG)THEN OPEN(1,FILE='GateWarning.LOG',STATUS='UNKNOWN') ! GEOSR UNG 2014.11.12 Warning message writing CLOSE(1,STATUS='DELETE') ! GEOSR UNG 2014.11.12 Warning message writing - OPEN(713,FILE='GateWarning.LOG',STATUS='UNKNOWN') ! GEOSR UNG 2014.11.12 Warning message writing - WRITE(713,'(A)')'TIME N NCTL IQCTLU JQCTLU QSUM CellVOL' + OPEN(713,FILE='GateWarning.LOG',STATUS='UNKNOWN') ! GEOSR UNG 2014.11.12 Warning message writing + WRITE(713,'(A)') + & 'TIME N NCTL IQCTLU JQCTLU QSUM CellVOL' + CLOSE(1) + ENDIF ! } GEOSR 2014.11.12 UNG Warning message writing RETURN - 10 FORMAT(A80) - 20 WRITE(*,30)'GATECTL.INP' - WRITE(8,30)'GATECTL.INP' +C 10 FORMAT(A80) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30)'GATECTL.INP' + IF(MYRANK.EQ.0) WRITE(8,30)'GATECTL.INP' 30 FORMAT(' READ ERROR IN FILE: GATECTL.INP ') STOP - END \ No newline at end of file + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGSER.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGSER.for index 1978a078e..4e5c3a883 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGSER.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGSER.for @@ -2,10 +2,11 @@ ! SUBROUTINE SCANGSER USE GLOBAL + USE MPI CHARACTER*80 SKIP CHARACTER*11 INFILE - WRITE(*,'(A)')'SCANNING INPUT FILE: GATESER.INP' + IF(MYRANK.EQ.0) WRITE(*,'(A)')'SCANNING INPUT FILE: GATESER.INP' INFILE='GATESER.INP' OPEN(1,FILE='GATESER.INP',STATUS='UNKNOWN') @@ -29,9 +30,10 @@ RETURN 10 FORMAT(A80) - 20 WRITE(*,30)INFILE - WRITE(8,30)INFILE + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30)INFILE + IF(MYRANK.EQ.0) WRITE(8,30)INFILE 30 FORMAT(' READ ERROR IN FILE: ',A10) STOP - END \ No newline at end of file + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGTAB.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGTAB.for index 345f3d803..d9264a139 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGTAB.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGTAB.for @@ -2,11 +2,12 @@ ! SUBROUTINE SCANGTAB USE GLOBAL + USE MPI CHARACTER*11 INFILE INTEGER I,J INTEGER NOELE1,NOGELE1 - WRITE(*,'(A)')'SCANNING INPUT FILE: GATETAB.INP' + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: GATETAB.INP' INFILE='GATETAB.INP' OPEN(1,FILE='GATETAB.INP',STATUS='UNKNOWN') @@ -24,4 +25,4 @@ ENDDO CLOSE(1) RETURN - END SUBROUTINE \ No newline at end of file + END SUBROUTINE diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGWSR.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGWSR.for index 12ffef527..2c4268501 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGWSR.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANGWSR.for @@ -2,7 +2,9 @@ ! SUBROUTINE SCANGWSR USE GLOBAL - WRITE(*,'(A)')'SCANNING INPUT FILE: GWSER.INP' + USE MPI, ONLY: MYRANK + INTEGER IOS + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: GWSER.INP' OPEN(1,FILE='GWSER.INP',STATUS='OLD') 10 READ(1,*,ERR=10,END=40)NGWSER NGWSERM=MAX(1,NGWSER) @@ -15,12 +17,14 @@ ENDDO CLOSE(1) RETURN - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANMASK.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANMASK.for index 5ea46f4c4..8c23c0ee6 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANMASK.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANMASK.for @@ -1,7 +1,8 @@ SUBROUTINE SCANMASK USE GLOBAL + USE MPI - WRITE(*,'(A)')'SCANNING INPUT FILE: MASK.INP' + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: MASK.INP' OPEN(1,FILE='MASK.INP',STATUS='UNKNOWN') ! *** FINE MAXIMUM NUMBER OF MASK TYPE OVER 5 @@ -22,10 +23,11 @@ RETURN - 10 FORMAT(A80) - 20 WRITE(*,30)'MASK.INP' - WRITE(8,30)'MASK.INP' +C 10 FORMAT(A80) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30)'MASK.INP' + IF(MYRANK.EQ.0) WRITE(8,30)'MASK.INP' 30 FORMAT(' READ ERROR IN FILE: GATECTL.INP ') STOP - END \ No newline at end of file + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANMODC.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANMODC.for index a8ce8cced..71258cea2 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANMODC.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANMODC.for @@ -1,18 +1,22 @@ SUBROUTINE SCANMODC USE GLOBAL - WRITE(*,'(A)')'SCANNING INPUT FILE: MODCHAN.INP' + USE MPI + INTEGER IOS + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: MODCHAN.INP' OPEN(1,FILE='MODCHAN.INP',STATUS='OLD') 10 READ(1,*,ERR=10,END=40)M,I,I NCHANM=MAX(1,M) READ(1,*,ERR=20,END=40)I,I,R CLOSE(1) RETURN - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANPSER.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANPSER.for index 05e96fd67..00a138406 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANPSER.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANPSER.for @@ -1,6 +1,8 @@ SUBROUTINE SCANPSER USE GLOBAL - WRITE(*,'(A)')'SCANNING INPUT FILE: PSER.INP' + USE MPI + INTEGER IOS + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: PSER.INP' OPEN(1,FILE='PSER.INP',STATUS='OLD') DO NS=1,NPSER 10 READ(1,*,ERR=10,END=40)M,R,R,R,R @@ -12,12 +14,14 @@ CLOSE(1) RETURN C - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANQCTL.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANQCTL.for index 85845a0fe..4446368be 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANQCTL.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANQCTL.for @@ -1,9 +1,10 @@ SUBROUTINE SCANQCTL USE GLOBAL + USE MPI CHARACTER*80 SKIP CHARACTER*10 INFILE - WRITE(*,'(A)')'SCANNING INPUT FILE: QCTL.INP' + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: QCTL.INP' INFILE='QCTL.INP' OPEN(1,FILE='QCTL.INP',STATUS='UNKNOWN') @@ -32,9 +33,10 @@ RETURN 10 FORMAT(A80) - 20 WRITE(*,30)INFILE - WRITE(8,30)INFILE + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30)INFILE + IF(MYRANK.EQ.0) WRITE(8,30)INFILE 30 FORMAT(' READ ERROR IN FILE: ',A10) STOP - END \ No newline at end of file + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANQSER.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANQSER.for index 9584fc282..88750ef2e 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANQSER.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANQSER.for @@ -1,8 +1,9 @@ SUBROUTINE SCANQSER USE GLOBAL - INTEGER*4 NS, I, J, M - - WRITE(*,'(A)')'SCANNING INPUT FILE: QSER.INP' + USE MPI + INTEGER IOS + + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: QSER.INP' OPEN(1,FILE='QSER.INP',STATUS='OLD') DO NS=1,NQSER @@ -22,12 +23,14 @@ CLOSE(1) RETURN - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END @@ -36,12 +39,14 @@ C ***************************************************************************** SUBROUTINE SCANQWSER USE GLOBAL + USE MPI INTEGER*4 NTMP, I, J, M, NV NTMP=4+NSED+NSND+NTOX ! *** Handle Water Quality variables, if needed IF(ISTRAN(8).GT.0)THEN - WRITE(*,'(A)')'SCANNING INPUT FILE: WQ3DWC.INP (PRELIM)' + IF(MYRANK.EQ.0) + & WRITE(*,'(A)')'SCANNING INPUT FILE: WQ3DWC.INP (PRELIM)' OPEN(1,FILE='WQ3DWC.INP',STATUS='OLD') CALL SEEK('C02') @@ -52,7 +57,7 @@ C ***************************************************************************** NTMP=NTMP+NWQV ENDIF - WRITE(*,'(A)')'SCANNING INPUT FILE: QWRS.INP' + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: QWRS.INP' OPEN(1,FILE='QWRS.INP',STATUS='OLD') DO NS=1,NQWRSR @@ -73,12 +78,14 @@ C ***************************************************************************** CLOSE(1) RETURN - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSEDZLJ.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSEDZLJ.f90 index 80cea3c88..3b49c56cf 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSEDZLJ.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSEDZLJ.f90 @@ -4,33 +4,34 @@ SUBROUTINE SCANSEDZLJ ! Craig Jones and Scott James !*************************************************************** USE GLOBAL + USE MPI IMPLICIT NONE INTEGER::IDUMMY,ERROR ! - WRITE(*,'(A)')'SCANNING INPUT FILE: BED.SDF' + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: BED.SDF' OPEN(1,FILE='BED.SDF',STATUS='OLD') READ(1,*,IOSTAT=ERROR) !SKIP THIS LINE IF(ERROR==1)THEN - WRITE(*,'("READ ERROR IN SEDZLJ INPUT FILE")') - WRITE(8,'("READ ERROR IN SEDZLJ INPUT FILE")') + IF(MYRANK.EQ.0)WRITE(*,'("READ ERROR IN SEDZLJ INPUT FILE")') + IF(MYRANK.EQ.0)WRITE(8,'("READ ERROR IN SEDZLJ INPUT FILE")') STOP ENDIF READ(1,*,IOSTAT=ERROR) IDUMMY,IDUMMY,IDUMMY,KB IF(ERROR==1)THEN - WRITE(*,'("READ ERROR IN SEDZLJ INPUT FILE")') - WRITE(8,'("READ ERROR IN SEDZLJ INPUT FILE")') + IF(MYRANK.EQ.0)WRITE(*,'("READ ERROR IN SEDZLJ INPUT FILE")') + IF(MYRANK.EQ.0)WRITE(8,'("READ ERROR IN SEDZLJ INPUT FILE")') STOP ENDIF READ(1,*,IOSTAT=ERROR) !SKIP THIS LINE IF(ERROR==1)THEN - WRITE(*,'("READ ERROR IN SEDZLJ INPUT FILE")') - WRITE(8,'("READ ERROR IN SEDZLJ INPUT FILE")') + IF(MYRANK.EQ.0)WRITE(*,'("READ ERROR IN SEDZLJ INPUT FILE")') + IF(MYRANK.EQ.0)WRITE(8,'("READ ERROR IN SEDZLJ INPUT FILE")') STOP ENDIF READ(1,*,IOSTAT=ERROR) ITBM,NSICM IF(ERROR==1)THEN - WRITE(*,'("READ ERROR IN SEDZLJ INPUT FILE")') - WRITE(8,'("READ ERROR IN SEDZLJ INPUT FILE")') + IF(MYRANK.EQ.0)WRITE(*,'("READ ERROR IN SEDZLJ INPUT FILE")') + IF(MYRANK.EQ.0)WRITE(8,'("READ ERROR IN SEDZLJ INPUT FILE")') STOP ENDIF CLOSE(1) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSFSR.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSFSR.for index 19c72b481..012cb1cae 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSFSR.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSFSR.for @@ -1,6 +1,8 @@ SUBROUTINE SCANSFSR(NCSER4) USE GLOBAL - WRITE(*,'(A)')'SCANNING INPUT FILE: SFSER.INP' + USE MPI + INTEGER IOS + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: SFSER.INP' OPEN(1,FILE='SFSER.INP',STATUS='OLD') DO NS=1,NCSER4 10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R @@ -18,12 +20,14 @@ ENDDO CLOSE(1) RETURN - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSSER.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSSER.for index 04be283b1..7d82f6a9d 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSSER.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANSSER.for @@ -1,6 +1,8 @@ SUBROUTINE SCANSSER(NCSER1) USE GLOBAL - WRITE(*,'(A)')'SCANNING INPUT FILE: SSER.INP' + USE MPI + INTEGER IOS + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: SSER.INP' OPEN(1,FILE='SSER.INP',STATUS='OLD') DO NS=1,NCSER1 10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R @@ -18,12 +20,14 @@ ENDDO CLOSE(1) RETURN - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANTSER.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANTSER.for index 68348d259..dc2021b08 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANTSER.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANTSER.for @@ -1,6 +1,8 @@ SUBROUTINE SCANTSER(NCSER2) USE GLOBAL - WRITE(*,'(A)')'SCANNING INPUT FILE: TSER.INP' + USE MPI + INTEGER IOS + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: TSER.INP' OPEN(1,FILE='TSER.INP',STATUS='OLD') DO NS=1,NCSER2 10 READ(1,*,ERR=10,END=40)I,M,R,R,R,R @@ -18,12 +20,14 @@ ENDDO CLOSE(1) RETURN - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANWQ.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANWQ.for index 6291e507c..350101328 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANWQ.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANWQ.for @@ -3,6 +3,7 @@ ! *** Merged SNL & DS-INTL Codes USE GLOBAL + USE MPI CHARACTER*10 INFILE CHARACTER*2 SNUM @@ -13,7 +14,7 @@ REAL*4 XPSQ LOGICAL fileExists - WRITE(*,'(A)')'SCANNING INPUT FILE: WQ3DWC.INP' + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: WQ3DWC.INP' INFILE='WQ3DWC.INP' OPEN(1,FILE='WQ3DWC.INP',STATUS='UNKNOWN') @@ -79,7 +80,7 @@ C ! *** SCAN THE TIME SERIES IF(NPSTMSR.GE.1.AND.IWQPSL.NE.2)THEN - WRITE(*,'(A)')'SCANNING INPUT FILE: WQPSL.INP' + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: WQPSL.INP' OPEN(1,FILE='WQPSL.INP',STATUS='UNKNOWN') DO IS=1,13 READ(1,1) @@ -135,7 +136,7 @@ C ! For x-species WQ3DWC2 needs to be checked INQUIRE(FILE='WQ3DWC2.INP',EXIST=fileExists) if (fileExists) then - WRITE(*,'(A)')'SCANNING INPUT FILE: WQ3DWC2.INP' + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: WQ3DWC2.INP' OPEN(1,FILE='WQ3DWC2.INP',STATUS='UNKNOWN') CALL SEEK('C01') diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANWSER.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANWSER.for index ca431e270..0f9c7e4a2 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANWSER.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCANWSER.for @@ -1,6 +1,8 @@ SUBROUTINE SCANWSER USE GLOBAL - WRITE(*,'(A)')'SCANNING INPUT FILE: WSER.INP' + USE MPI + INTEGER IOS + IF(MYRANK.EQ.0)WRITE(*,'(A)')'SCANNING INPUT FILE: WSER.INP' OPEN(1,FILE='WSER.INP',STATUS='OLD') DO NS=1,NWSER 10 READ(1,*,ERR=10,END=40)M,R,R,R,I @@ -11,12 +13,14 @@ ENDDO CLOSE(1) RETURN - 20 WRITE(*,30) - WRITE(8,30) + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30) + IF(MYRANK.EQ.0) WRITE(8,30) 30 FORMAT('READ ERROR IN INPUT FILE') STOP - 40 WRITE(*,50) - WRITE(8,50) + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50) + IF(MYRANK.EQ.0) WRITE(8,50) 50 FORMAT('UNEXPECTED END OF INPUT FILE') STOP END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCNTXSED.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCNTXSED.for index 7bf368759..1ad84c19d 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCNTXSED.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SCNTXSED.for @@ -1,6 +1,7 @@ SUBROUTINE SCNTXSED USE GLOBAL + USE MPI CHARACTER*80 SKIP CHARACTER*10 INFILE @@ -10,7 +11,8 @@ IF(N.EQ.1)THEN NC=5 ! MSVTOX(1) IF(NTOX.GT.0.AND.NTOXSER.GT.0)THEN - WRITE(*,'(A)')'SCANNING INPUT FILE: TXSER.INP' + IF(MYRANK.EQ.0) + & WRITE(*,'(A)')'SCANNING INPUT FILE: TXSER.INP' INFILE='TXSER.INP' OPEN(1,FILE='TXSER.INP',STATUS='UNKNOWN') NLOOP=NTOX @@ -19,7 +21,8 @@ ELSEIF(N.EQ.2)THEN NC=NTOX+1 ! MSVSED(1) IF(NSED.GT.0.AND.NSEDSER.GT.0)THEN - WRITE(*,'(A)')'SCANNING INPUT FILE: SDSER.INP' + IF(MYRANK.EQ.0) + & WRITE(*,'(A)')'SCANNING INPUT FILE: SDSER.INP' INFILE='SDSER.INP' OPEN(1,FILE='SDSER.INP',STATUS='UNKNOWN') NLOOP=NSED @@ -28,7 +31,8 @@ ELSEIF(N.EQ.3)THEN NC=NTOX+NSED+1 ! MSVSND(1) IF(NSND.GT.0.AND.NSNDSER.GT.0)THEN - WRITE(*,'(A)')'SCANNING INPUT FILE: SNSER.INP' + IF(MYRANK.EQ.0) + & WRITE(*,'(A)')'SCANNING INPUT FILE: SNSER.INP' INFILE='SNSER.INP' OPEN(1,FILE='SNSER.INP',STATUS='UNKNOWN') NLOOP=NSND @@ -69,14 +73,16 @@ ENDDO RETURN - 20 WRITE(*,30)INFILE - WRITE(8,30)INFILE + 20 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,30)INFILE + IF(MYRANK.EQ.0) WRITE(8,30)INFILE 30 FORMAT(' READ ERROR IN FILE: ',A10) STOP - 40 WRITE(*,50)INFILE - WRITE(8,50)INFILE + 40 CONTINUE + IF(MYRANK.EQ.0) WRITE(*,50)INFILE + IF(MYRANK.EQ.0) WRITE(8,50)INFILE 50 FORMAT(' UNEXPECTED END OF FILE: ',A10) 60 FORMAT(A80) STOP - END \ No newline at end of file + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SEEK.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SEEK.for index c7802e187..ff50d9456 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SEEK.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SEEK.for @@ -1,5 +1,6 @@ SUBROUTINE SEEK(TAG) C + USE MPI CHARACTER TAG*(*) CHARACTER*80 TEXT C @@ -10,11 +11,11 @@ C TAG(I:I)=CHAR(J-32) ENDIF ENDDO - WRITE(7,'(A,A)')'SEEKING GROUP: ',TAG + IF(MYRANK.EQ.0) WRITE(7,'(A,A)')'SEEKING GROUP: ',TAG DO K=1,2 10 READ(1,'(A)',END=20)TEXT M=MAX(1,LEN_TRIM(TEXT)) - WRITE(7,'(A)')TEXT(1:M) + IF(MYRANK.EQ.0) WRITE(7,'(A)')TEXT(1:M) DO WHILE(M.GT.L.AND.TEXT(1:1).EQ.'') TEXT(1:M-1)=TEXT(2:M) TEXT(M:M)=' ' diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SETBCS_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SETBCS_mpi.for new file mode 100644 index 000000000..66708b34a --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SETBCS_mpi.for @@ -0,0 +1,866 @@ + SUBROUTINE SETBCS_mpi +C +C CHANGE RECORD +C MODIFIED BOUNDARY CONDITION FLAGS FOR TYPE 2 OPEN BOUNDARIES +C ADDED REAL FLAGS RSSBCE(L),RSSBCW(L),RSSBCN(L),RSSBCS(L) +C TO MODIFIED CALCULATION OF CELL CENTER BED STRESS (STORED AS QQ(L,0)) +C AND THE OUTPUTED CELL CENTER VELOCITY FOR CELLS HAVE SOURCE/SINKS +C ** SUBROUTINE SETBCS SETS BOUNDARY CONDITION SWITCHES +C + USE GLOBAL + USE MPI + + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SUBEW + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SVBNS + + IF(.NOT.ALLOCATED(SUBEW))THEN + ALLOCATE(SUBEW(LCM)) + ALLOCATE(SVBNS(LCM)) + SUBEW=0.0 + SVBNS=0.0 + ENDIF +C +C ** SET LAND-WATER BOUNDARY SWITCHES +C + ITRICELL=0 ! PMC + + DO L=2,LA + I=IL(L) + J=JL(L) + IF(LCT(L).EQ.1)THEN + STCUV(L)=0. + ITRICELL=1 + STCAP(L)=0.5 + IF(IJCT(I-1,J).EQ.1) SUB(L)=0. + IF(IJCT(I-1,J).EQ.2) SUB(L)=0. + IF(IJCT(I-1,J).EQ.3) SUB(L)=1. + IF(IJCT(I-1,J).EQ.4) SUB(L)=1. + IF(IJCT(I-1,J).EQ.5) SUB(L)=1. + IF(IJCT(I-1,J).EQ.9) SUB(L)=0. + IF(IJCT(I,J-1).EQ.1) SVB(L)=0. + IF(IJCT(I,J-1).EQ.2) SVB(L)=1. + IF(IJCT(I,J-1).EQ.3) SVB(L)=1. + IF(IJCT(I,J-1).EQ.4) SVB(L)=0. + IF(IJCT(I,J-1).EQ.5) SVB(L)=1. + IF(IJCT(I,J-1).EQ.9) SVB(L)=0. + ENDIF + IF(LCT(L).EQ.2)THEN + STCUV(L)=0. + ITRICELL=1 + STCAP(L)=0.5 + IF(IJCT(I-1,J).EQ.1) SUB(L)=0. + IF(IJCT(I-1,J).EQ.2) SUB(L)=0. + IF(IJCT(I-1,J).EQ.3) SUB(L)=1. + IF(IJCT(I-1,J).EQ.4) SUB(L)=1. + IF(IJCT(I-1,J).EQ.5) SUB(L)=1. + IF(IJCT(I-1,J).EQ.9) SUB(L)=0. + IF(IJCT(I,J-1).EQ.1) SVB(L)=0. + IF(IJCT(I,J-1).EQ.2) SVB(L)=0. + IF(IJCT(I,J-1).EQ.3) SVB(L)=0. + IF(IJCT(I,J-1).EQ.4) SVB(L)=0. + IF(IJCT(I,J-1).EQ.5) SVB(L)=0. + IF(IJCT(I,J-1).EQ.9) SVB(L)=0. + ENDIF + IF(LCT(L).EQ.3)THEN + STCUV(L)=0. + ITRICELL=1 + STCAP(L)=0.5 + IF(IJCT(I-1,J).EQ.1) SUB(L)=0. + IF(IJCT(I-1,J).EQ.2) SUB(L)=0. + IF(IJCT(I-1,J).EQ.3) SUB(L)=0. + IF(IJCT(I-1,J).EQ.4) SUB(L)=0. + IF(IJCT(I-1,J).EQ.9) SUB(L)=0. + IF(IJCT(I-1,J).EQ.5) SUB(L)=0. + IF(IJCT(I,J-1).EQ.1) SVB(L)=0. + IF(IJCT(I,J-1).EQ.2) SVB(L)=0. + IF(IJCT(I,J-1).EQ.3) SVB(L)=0. + IF(IJCT(I,J-1).EQ.4) SVB(L)=0. + IF(IJCT(I,J-1).EQ.5) SVB(L)=0. + IF(IJCT(I,J-1).EQ.9) SVB(L)=0. + ENDIF + IF(LCT(L).EQ.4)THEN + STCUV(L)=0. + ITRICELL=1 + STCAP(L)=0.5 + IF(IJCT(I-1,J).EQ.1) SUB(L)=0. + IF(IJCT(I-1,J).EQ.2) SUB(L)=0. + IF(IJCT(I-1,J).EQ.3) SUB(L)=0. + IF(IJCT(I-1,J).EQ.4) SUB(L)=0. + IF(IJCT(I-1,J).EQ.5) SUB(L)=0. + IF(IJCT(I-1,J).EQ.9) SUB(L)=0. + IF(IJCT(I,J-1).EQ.1) SVB(L)=0. + IF(IJCT(I,J-1).EQ.2) SVB(L)=1. + IF(IJCT(I,J-1).EQ.3) SVB(L)=1. + IF(IJCT(I,J-1).EQ.4) SVB(L)=0. + IF(IJCT(I,J-1).EQ.5) SVB(L)=1. + IF(IJCT(I,J-1).EQ.9) SVB(L)=0. + ENDIF + IF(LCT(L).EQ.5)THEN + IF(IJCT(I-1,J).EQ.1) SUB(L)=0. + IF(IJCT(I-1,J).EQ.2) SUB(L)=0. + IF(IJCT(I-1,J).EQ.3) SUB(L)=1. + IF(IJCT(I-1,J).EQ.4) SUB(L)=1. + IF(IJCT(I-1,J).EQ.5) SUB(L)=1. + IF(IJCT(I-1,J).EQ.9) SUB(L)=0. + IF(IJCT(I,J-1).EQ.1) SVB(L)=0. + IF(IJCT(I,J-1).EQ.2) SVB(L)=1. + IF(IJCT(I,J-1).EQ.3) SVB(L)=1. + IF(IJCT(I,J-1).EQ.4) SVB(L)=0. + IF(IJCT(I,J-1).EQ.5) SVB(L)=1. + IF(IJCT(I,J-1).EQ.9) SVB(L)=0. + ENDIF + IF(LCT(L).EQ.6)THEN + IF(IJCT(I-1,J).EQ.1) SUB(L)=0. + IF(IJCT(I-1,J).EQ.2) SUB(L)=0. + IF(IJCT(I-1,J).EQ.3) SUB(L)=1. + IF(IJCT(I-1,J).EQ.4) SUB(L)=1. + IF(IJCT(I-1,J).EQ.5) SUB(L)=1. + IF(IJCT(I-1,J).EQ.6) SUB(L)=1. + IF(IJCT(I-1,J).EQ.7) SUB(L)=1. + IF(IJCT(I-1,J).EQ.9) SUB(L)=0. + IF(IJCT(I,J-1).EQ.1) SVB(L)=0. + IF(IJCT(I,J-1).EQ.2) SVB(L)=1. + IF(IJCT(I,J-1).EQ.3) SVB(L)=1. + IF(IJCT(I,J-1).EQ.4) SVB(L)=0. + IF(IJCT(I,J-1).EQ.5) SVB(L)=1. + IF(IJCT(I,J-1).EQ.6) SVB(L)=1. + IF(IJCT(I,J-1).EQ.7) SVB(L)=1. + IF(IJCT(I,J-1).EQ.9) SVB(L)=0. + ENDIF + IF(LCT(L).EQ.7)THEN + IF(IJCT(I-1,J).EQ.1) SUB(L)=0. + IF(IJCT(I-1,J).EQ.2) SUB(L)=0. + IF(IJCT(I-1,J).EQ.3) SUB(L)=1. + IF(IJCT(I-1,J).EQ.4) SUB(L)=1. + IF(IJCT(I-1,J).EQ.5) SUB(L)=1. + IF(IJCT(I-1,J).EQ.6) SUB(L)=1. + IF(IJCT(I-1,J).EQ.7) SUB(L)=1. + IF(IJCT(I-1,J).EQ.9) SUB(L)=0. + IF(IJCT(I,J-1).EQ.1) SVB(L)=0. + IF(IJCT(I,J-1).EQ.2) SVB(L)=1. + IF(IJCT(I,J-1).EQ.3) SVB(L)=1. + IF(IJCT(I,J-1).EQ.4) SVB(L)=0. + IF(IJCT(I,J-1).EQ.5) SVB(L)=1. + IF(IJCT(I,J-1).EQ.6) SVB(L)=1. + IF(IJCT(I,J-1).EQ.7) SVB(L)=1. + IF(IJCT(I,J-1).EQ.9) SVB(L)=0. + ENDIF + ENDDO + SUB(1)=0. + SVB(1)=0. + SUB(LC)=0. + SVB(LC)=0. +C +C ** MODIFY LAND-WATER BNDRY CONDS FOR PERIOD GRID IN N-S DIRECTION +C + IF(ISPGNS.GE.1)THEN + DO NPN=1,NPNSBP + LS=LIJ(ISPNS(NPN),JSPNS(NPN)) + SVB(LS)=1. + SVBO(LS)=1. + ENDDO + ENDIF +C +C ** SET WATER-WATER (P OR SURFACE ELEVATION) BOUNDARY SWITCHES +C + DO LL=1,NPBW + I=IPBW(LL) + J=JPBW(LL) + L=LIJ(I,J) + LPBW(LL)=L + SPB(L)=0. ! *** Used for On/Off Rainfall/Evap + SUB(L)=0. + SVB(L)=0. + SWB(L)=0. ! *** Used for On/Off of Vertical Velocities + SAAX(L)=0. ! *** Used for On/Off of Horizontal Momentum Stresses (X Dir) PMC-Added + SAAY(L)=0. ! *** Used for On/Off of Horizontal Momentum Stresses (Y Dir) PMC-Added + IF(ISPBW(LL).LE.1) THEN + SVB(L+1)=0. + SWB(L+1)=0. + SCAX(L+1)=0. ! *** Used for On/Off of Coriolis & Curvature Stresses + END IF + SAAX(L+1)=0. ! *** Used for On/Off of Horizontal Momentum Stresses (X Dir) + SAAY(L+1)=0. ! *** Used for On/Off of Horizontal Momentum Stresses (Y Dir) PMC-Added + !SDX(L+1)=0. ! *** Used for On/Off of Horizontal Momentum Diffusion Stresses PMC-Disabled + ENDDO + DO LL=1,NPBE + I=IPBE(LL) + J=JPBE(LL) + L=LIJ(I,J) + LPBE(LL)=L + SPB(L)=0. + SVB(L)=0. + SWB(L)=0. + IF(ISPBE(LL).LE.1) THEN + SWB(L-1)=0. + SVB(L-1)=0. + SCAX(L)=0. + END IF + SAAY(L)=0. ! PMC + SAAX(L)=0. + !SDX(L)=0. + ENDDO + DO LL=1,NPBS + I=IPBS(LL) + J=JPBS(LL) + L=LIJ(I,J) + LPBS(LL)=L + LN=LNC(L) + SPB(L)=0. + SVB(L)=0. + SUB(L)=0. + SWB(L)=0. + IF(ISPBS(LL).LE.1) THEN + SUB(LN)=0. + SWB(LN)=0. + SCAY(LN)=0. + END IF + SAAX(L)=0. ! PMC + SAAY(L)=0. ! PMC + SAAX(LN)=0. ! PMC + SAAY(LN)=0. + !SDY(LN)=0. + ENDDO + DO LL=1,NPBN + I=IPBN(LL) + J=JPBN(LL) + L=LIJ(I,J) + LPBN(LL)=L + LS=LSC(L) + SPB(L)=0. + SUB(L)=0. + SWB(L)=0. + IF(ISPBN(LL).LE.1) THEN + SUB(LS)=0. + SWB(LS)=0. + SCAY(L)=0. + END IF + SAAX(L)=0. ! PMC + SAAY(L)=0. + !SDY(L)=0. + ENDDO +C +C ********************************************************************* +C *** SET THE CELL FACES SWITCHES FOR HEAD CONTROL STRUCTURES + ! *** UPSTREAM CONTROL + DO NCTL=1,NQCTL + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + L=LIJ(IU,JU) + + ! *** SET U FACE + LW=L-1 + DO IQ=1,NQCTL + IF(IQ.NE.NCTL)THEN + I=IQCTLU(IQ) + J=JQCTLU(IQ) + L1=LIJ(I,J) + IF(L1.EQ.LW)THEN + SUB(L)=0.0 + EXIT + ENDIF + ENDIF + ENDDO + + ! *** SET V FACE + LS=LSC(L) + DO IQ=1,NQCTL + IF(IQ.NE.NCTL)THEN + I=IQCTLU(IQ) + J=JQCTLU(IQ) + L1=LIJ(I,J) + IF(L1.EQ.LS)THEN + SVB(L)=0.0 + EXIT + ENDIF + ENDIF + ENDDO + ENDDO + + ! *** DOWNSTREAM CONTROL + DO NCTL=1,NQCTL + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + IF(ID.NE.0.AND.JD.NE.0)THEN + L=LIJ(ID,JD) + + ! *** SET U FACE + LW=L-1 + DO IQ=1,NQCTL + IF(IQ.NE.NCTL)THEN + I=IQCTLD(IQ) + J=JQCTLD(IQ) + IF(I.GT.0.AND.J.GT.0)THEN ! PMC + L1=LIJ(I,J) + IF(L1.EQ.LW)THEN + SUB(L)=0.0 + EXIT + ENDIF + ENDIF + ENDIF + ENDDO + + ! *** SET V FACE + LS=LSC(L) + DO IQ=1,NQCTL + IF(IQ.NE.NCTL)THEN + I=IQCTLD(IQ) + J=JQCTLD(IQ) + IF(I.GT.0.AND.J.GT.0)THEN ! PMC + L1=LIJ(I,J) + IF(L1.EQ.LS)THEN + SVB(L)=0.0 + EXIT + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO +C +C ** RESET DXU,DYU,DXV,DYV BASED ON BOUNDARY CONDITION SWITCHES +C + DO L=2,LA + IF(SUB(L).GT.0.5)THEN + DXU(L)=0.5*(DXP(L)+DXP(L-1)) + DYU(L)=0.5*(DYP(L)+DYP(L-1)) + ENDIF + IF(SUB(L).LT.0.5.AND.SUB(L+1).GT.0.5)THEN + DXU(L)=DXP(L) + DDYDDDX=2.*(DYP(L+1)-DYP(L))/(DXP(L)+DXP(L+1)) + DYU(L)=DYP(L)-0.5*DXP(L)*DDYDDDX + ENDIF + IF(SUB(L).LT.0.5.AND.SUB(L+1).LT.0.5)THEN + DXU(L)=DXP(L) + DYU(L)=DYP(L) + ENDIF + ENDDO + DO L=2,LA + LN=LNC(L) + LS=LSC(L) + IF(SVB(L).GT.0.5)THEN + DXV(L)=0.5*(DXP(L)+DXP(LS)) + DYV(L)=0.5*(DYP(L)+DYP(LS)) + ENDIF + IF(SVB(L).LT.0.5.AND.SVB(LN).GT.0.5)THEN + DDXDDDY=2.*(DXP(LN)-DXP(L))/(DYP(L)+DYP(LN)) + DXV(L)=DXP(L)-0.5*DYP(L)*DDXDDDY + DYV(L)=DYP(L) + ENDIF + IF(SVB(L).LT.0.5.AND.SVB(LN).LT.0.5)THEN + DXV(L)=DXP(L) + DYV(L)=DYP(L) + ENDIF + ENDDO +C +C ** SET THIN BARRIERS BY CALLING CELLMASK +C ** CALL MOVED FROM AAEFDC ON 23 JAN 2004 +C + IF(ISMASK.EQ.1) CALL CELLMASK +C +C ** SET VOLUMETRIC & CONCENTRATION SOURCE LOCATIONS AND BED STRESS +C ** AND CELL CENTER BED STRESS AND VELOCITY MODIFERS +C + DO LL=1,NQSIJ + I=IQS(LL) + J=JQS(LL) + LTMP=LIJ(I,J) + LQS(LL)=LTMP + IF(NQSMUL(LL).EQ.0)RQSMUL(LL)=1. + IF(NQSMUL(LL).EQ.1)RQSMUL(LL)=DYP(LTMP) + IF(NQSMUL(LL).EQ.2)RQSMUL(LL)=DXP(LTMP) + IF(NQSMUL(LL).EQ.3)RQSMUL(LL)=DXP(LTMP)+DYP(LTMP) + ENDDO + DO NCTL=1,NQCTL + RQDW=1. + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + LTMP=LIJ(IU,JU) + IF(NQCMUL(NCTL).EQ.0)RQCMUL(NCTL)=1. + IF(NQCMUL(NCTL).EQ.1)RQCMUL(NCTL)=DYP(LTMP) + IF(NQCMUL(NCTL).EQ.2)RQCMUL(NCTL)=DXP(LTMP) + IF(NQCMUL(NCTL).EQ.3)RQCMUL(NCTL)=DXP(LTMP)+DYP(LTMP) + ENDDO +C +C ********************************************************************* +C *** SET THE VELOCITY AVERAGING FACTORS + + ! *** DEFAULT CONDITION + DO L=2,LA + RSSBCE(L)=1.0 + RSSBCW(L)=1.0 + RSSBCN(L)=1.0 + RSSBCS(L)=1.0 + SUBEW(L)=SUB(L)+SUB(L+1) + SVBNS(L)=SVB(L)+SVB(LNC(L)) + ENDDO + + ! *** FLOW BOUNDARY CONDITIONS + DO LL=1,NQSIJ + L=LQS(LL) + LE=L+1 + LN=LNC(L) + IF(SUBEW(L).LT.1.5)THEN + IF(SUB(L).LT.0.5.AND.SUB(LE).GT.0.5)THEN + RSSBCW(L)=0.0 + RSSBCE(L)=2.0 + ENDIF + IF(SUB(L).GT.0.5.AND.SUB(LE).LT.0.5)THEN + RSSBCW(L)=2.0 + RSSBCE(L)=0.0 + ENDIF + ENDIF + IF(SVBNS(L).LT.1.5)THEN + IF(SVB(L).LT.0.5.AND.SVB(LN).GT.0.5)THEN + RSSBCS(L)=0.0 + RSSBCN(L)=2.0 + ENDIF + IF(SVB(L).GT.0.5.AND.SVB(LN).LT.0.5)THEN + RSSBCS(L)=2.0 + RSSBCN(L)=0.0 + ENDIF + ENDIF + ENDDO + + ! *** WEIR STRUCTURE: UPSTREAM + DO NCTL=1,NQCTL + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + L=LIJ(IU,JU) + LE=L+1 + LN=LNC(L) + IF(SUBEW(L).LT.1.5)THEN + IF(SUB(L).LT.0.5.AND.SUB(LE).GT.0.5)THEN + RSSBCW(L)=0.0 + RSSBCE(L)=2.0 + ENDIF + IF(SUB(L).GT.0.5.AND.SUB(LE).LT.0.5)THEN + RSSBCW(L)=2.0 + RSSBCE(L)=0.0 + ENDIF + ENDIF + IF(SVBNS(L).LT.1.5)THEN + IF(SVB(L).LT.0.5.AND.SVB(LN).GT.0.5)THEN + RSSBCS(L)=0.0 + RSSBCN(L)=2.0 + ENDIF + IF(SVB(L).GT.0.5.AND.SVB(LN).LT.0.5)THEN + RSSBCS(L)=2.0 + RSSBCN(L)=0.0 + ENDIF + ENDIF + ENDDO + + ! *** WEIR STRUCTURE: DOWNSTREAM + DO NCTL=1,NQCTL + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + IF(ID.NE.0.AND.JD.NE.0)THEN + L=LIJ(ID,JD) + LE=L+1 + LN=LNC(L) + IF(SUBEW(L).LT.1.5)THEN + IF(SUB(L).LT.0.5.AND.SUB(LE).GT.0.5)THEN + RSSBCW(L)=0.0 + RSSBCE(L)=2.0 + ENDIF + IF(SUB(L).GT.0.5.AND.SUB(LE).LT.0.5)THEN + RSSBCW(L)=2.0 + RSSBCE(L)=0.0 + ENDIF + ENDIF + IF(SVBNS(L).LT.1.5)THEN + IF(SVB(L).LT.0.5.AND.SVB(LN).GT.0.5)THEN + RSSBCS(L)=0.0 + RSSBCN(L)=2.0 + ENDIF + IF(SVB(L).GT.0.5.AND.SVB(LN).LT.0.5)THEN + RSSBCS(L)=2.0 + RSSBCN(L)=0.0 + ENDIF + ENDIF + END IF + ENDDO + + ! *** GLOBAL BOUNDARY CELL LIST + NBCS=0 + + ! *** WITHDRAWAL & RETURN BOUNDARY CONDITIONS: UPSTREAM + DO NWR=1,NQWR + IU=IQWRU(NWR) + JU=JQWRU(NWR) + L=LIJ(IU,JU) + NBCS=NBCS+1 + LBCS(NBCS)=L + LBERC(NBCS)=1 + LBNRC(NBCS)=1 + LE=L+1 + LN=LNC(L) + IF(SUBEW(L).LT.1.5)THEN + IF(SUB(L).LT.0.5.AND.SUB(LE).GT.0.5)THEN + RSSBCW(L)=0.0 + RSSBCE(L)=2.0 + ENDIF + IF(SUB(L).GT.0.5.AND.SUB(LE).LT.0.5)THEN + RSSBCW(L)=2.0 + RSSBCE(L)=0.0 + ENDIF + ENDIF + IF(SVBNS(L).LT.1.5)THEN + IF(SVB(L).LT.0.5.AND.SVB(LN).GT.0.5)THEN + RSSBCS(L)=0.0 + RSSBCN(L)=2.0 + ENDIF + IF(SVB(L).GT.0.5.AND.SVB(LN).LT.0.5)THEN + RSSBCS(L)=2.0 + RSSBCN(L)=0.0 + ENDIF + ENDIF + ENDDO + + ! *** WITHDRAWAL & RETURN BOUNDARY CONDITIONS: DOWNSTREAM + DO NWR=1,NQWR + ID=IQWRD(NWR) + JD=JQWRD(NWR) + L=LIJ(ID,JD) + NBCS=NBCS+1 + LBCS(NBCS)=L + LBERC(NBCS)=1 + LBNRC(NBCS)=1 + LE=L+1 + LN=LNC(L) + IF(SUBEW(L).LT.1.5)THEN + IF(SUB(L).LT.0.5.AND.SUB(LE).GT.0.5)THEN + RSSBCW(L)=0.0 + RSSBCE(L)=2.0 + ENDIF + IF(SUB(L).GT.0.5.AND.SUB(LE).LT.0.5)THEN + RSSBCW(L)=2.0 + RSSBCE(L)=0.0 + ENDIF + ENDIF + IF(SVBNS(L).LT.1.5)THEN + IF(SVB(L).LT.0.5.AND.SVB(LN).GT.0.5)THEN + RSSBCS(L)=0.0 + RSSBCN(L)=2.0 + ENDIF + IF(SVB(L).GT.0.5.AND.SVB(LN).LT.0.5)THEN + RSSBCS(L)=2.0 + RSSBCN(L)=0.0 + ENDIF + ENDIF + ENDDO + + ! *** SET BOUNDARY MOMENTUM SWITCHES FOR FLOW & HEAD CONTROL + + ! *** FLOW BC'S + DO LL=1,NQSIJ + I=IQS(LL) + J=JQS(LL) + L=LIJ(I,J) + NBCS=NBCS+1 + LBCS(NBCS)=L + + ! *** SET SAAX & SAAY FOR BOUNDARY MOMENTUM FLUXES + ! *** EAST/WEST MOMENTUM + LBERC(NBCS)=L + IF(SUB(L).LT.0.5)THEN + SAAX(L)=0. + SAAY(L)=0. + ENDIF + IF(L.LT.LA-2)THEN + IF(SUB(L).LT.0.5.AND.(SUB(L+1).GT.0.5.AND.SUB(L+2).GT.0.5)) + & THEN + LBERC(NBCS)=L+1 + SAAX(LBERC(NBCS))=0. + SAAY(LBERC(NBCS))=0. + ENDIF + ENDIF + IF(L.GT.2.AND.L.LT.LA)THEN + IF((SUB(L ).GT.0.5.AND.SUB(L+1).LT.0.5).AND. + & (SUB(L-1).GT.0.5.AND.SUB(L-2).GT.0.5))THEN + LBERC(NBCS)=L-1 + SAAX(LBERC(NBCS))=0. + SAAY(LBERC(NBCS))=0. + SAAX(L)=0. + SAAY(L)=0. + ENDIF + ENDIF + ! *** NORTH/SOUTH MOMENTUM + LBNRC(NBCS)=L + IF(SVB(L).LT.0.5)THEN + SAAX(L)=0. + SAAY(L)=0. + ENDIF + IF(SVB(L).LT.0.5.AND.(SVB(LNC(L)).GT.0.5.AND. + & SVB(LNC(LNC(L))).GT.0.5))THEN + LBNRC(NBCS)=LNC(L) + SAAX(LBNRC(NBCS))=0. + SAAY(LBNRC(NBCS))=0. + ENDIF + IF((SVB(L ).GT.0.5.AND.SVB(LNC(L)).LT.0.5).AND. + & (SVB(LSC(L)).GT.0.5.AND.SVB(LSC(LSC(L))).GT.0.5))THEN + LBNRC(NBCS)=LSC(L) + SAAX(LBNRC(NBCS))=0. + SAAY(LBNRC(NBCS))=0. + SAAX(L)=0. + SAAY(L)=0. + ENDIF + + ENDDO + + ! *** HEAD CONTROL: UPSTREAM + DO NCTL=1,NQCTL + RQDW=1. + IU=IQCTLU(NCTL) + JU=JQCTLU(NCTL) + L=LIJ(IU,JU) + NBCS=NBCS+1 + LBCS(NBCS)=L + + ! *** SET SAAX & SAAY FOR BOUNDARY MOMENTUM FLUXES + ! *** EAST/WEST MOMENTUM + LBERC(NBCS)=L + IF(SUB(L).LT.0.5)THEN + SAAX(L)=0. + SAAY(L)=0. ! PMC + ENDIF +c IF(SUB(L).LT.0.5.AND.(SUB(L+1).GT.0.5.AND.SUB(L+2).GT.0.5))THEN +c LBERC(NBCS)=L+1 +c SAAX(LBERC(NBCS))=0. +c SAAY(LBERC(NBCS))=0. +c ENDIF + if(L>=3)then ! added to avoid SUB(0) + IF((SUB(L ).GT.0.5.AND.SUB(L+1).LT.0.5).AND. + & (SUB(L-1).GT.0.5.AND.SUB(L-2).GT.0.5))THEN + LBERC(NBCS)=L-1 + SAAX(LBERC(NBCS))=0. + SAAY(LBERC(NBCS))=0. + SAAX(L)=0. + SAAY(L)=0. + ENDIF + endif + ! *** NORTH/SOUTH MOMENTUM + LBNRC(NBCS)=L + IF(SVB(L).LT.0.5)THEN + SAAX(L)=0. + SAAY(L)=0. + ENDIF +c IF(SVB(L).LT.0.5.AND.(SVB(LNC(L)).GT.0.5.AND. +c & SVB(LNC(LNC(L))).GT.0.5))THEN +c LBNRC(NBCS)=LNC(L) +c SAAX(LBNRC(NBCS))=0. +c SAAY(LBNRC(NBCS))=0. +c ENDIF + IF((SVB(L ).GT.0.5.AND.SVB(LNC(L)).LT.0.5).AND. + & (SVB(LSC(L)).GT.0.5.AND.SVB(LSC(LSC(L))).GT.0.5))THEN + LBNRC(NBCS)=LSC(L) + SAAX(LBNRC(NBCS))=0. + SAAY(LBNRC(NBCS))=0. + SAAX(L)=0. + SAAY(L)=0. + ENDIF + + ENDDO + + ! *** HEAD CONTROL: DOWNSTREAM + DO NCTL=1,NQCTL + ID=IQCTLD(NCTL) + JD=JQCTLD(NCTL) + IF(ID.NE.0.AND.JD.NE.0)THEN + L=LIJ(ID,JD) + NBCS=NBCS+1 + LBCS(NBCS)=L + LBERC(NBCS)=1 + LBNRC(NBCS)=1 + ENDIF + ENDDO + + ! *** SET BOUNDARY VELOCITY SWITCHES + ! *** OPEN BOUNDARIES + NBCSOP=0 + DO LL=1,NPBS + I=IPBS(LL) + J=JPBS(LL) + L=LIJ(I,J) + RSSBCS(L)=0.0 + RSSBCN(L)=2.0 + ! *** SAVE THE L'S + NBCSOP=NBCSOP+1 + LOBCS(NBCSOP)=L + NBCS=NBCS+1 + LBCS(NBCS)=L + LBERC(NBCS)=L ! PMC-CHANGE THE NAME OF LBERC TO LBCE + LBNRC(NBCS)=LNC(L) ! PMC-CHANGE THE NAME OF LBNRC TO LBCN + ENDDO + DO LL=1,NPBW + I=IPBW(LL) + J=JPBW(LL) + L=LIJ(I,J) + RSSBCW(L)=0.0 + RSSBCE(L)=2.0 + ! *** SAVE THE L'S + NBCSOP=NBCSOP+1 + LOBCS(NBCSOP)=L + NBCS=NBCS+1 + LBCS(NBCS)=L + LBERC(NBCS)=L+1 + LBNRC(NBCS)=L + ENDDO + DO LL=1,NPBE + I=IPBE(LL) + J=JPBE(LL) + L=LIJ(I,J) + RSSBCW(L)=2.0 + RSSBCE(L)=0.0 + ! *** SAVE THE L'S + NBCSOP=NBCSOP+1 + LOBCS(NBCSOP)=L + NBCS=NBCS+1 + LBCS(NBCS)=L + LBERC(NBCS)=L-1 + LBNRC(NBCS)=L + ENDDO + DO LL=1,NPBN + I=IPBN(LL) + J=JPBN(LL) + L=LIJ(I,J) + RSSBCS(L)=2.0 + RSSBCN(L)=0.0 + ! *** SAVE THE L'S + NBCSOP=NBCSOP+1 + LOBCS(NBCSOP)=L + NBCS=NBCS+1 + LBCS(NBCS)=L + LBERC(NBCS)=L + LBNRC(NBCS)=LSC(L) + ENDDO +C +C ********************************************************************* +C *** SET OPEN BOUNDARY FLAGS FOR CONSTITUENTS + DO LL=1,NCBS + I=ICBS(LL) + J=JCBS(LL) + LCBS(LL)=LIJ(I,J) + L=LIJ(I,J) + SCB(L)=0. + ENDDO + DO LL=1,NCBW + I=ICBW(LL) + J=JCBW(LL) + LCBW(LL)=LIJ(I,J) + L=LIJ(I,J) + SCB(L)=0. + ENDDO + DO LL=1,NCBE + I=ICBE(LL) + J=JCBE(LL) + LCBE(LL)=LIJ(I,J) + L=LIJ(I,J) + SCB(L)=0. + ENDDO + DO LL=1,NCBN + I=ICBN(LL) + J=JCBN(LL) + LCBN(LL)=LIJ(I,J) + L=LIJ(I,J) + SCB(L)=0. + ENDDO + +C ********************************************************************* +C *** SET JET-PLUME VOLUMES SOURCES + DO NJP=1,NQJPIJ + L=LIJ(IQJP(NJP),JQJP(NJP)) + NBCS=NBCS+1 + LBCS(NBCS)=L + LBERC(NBCS)=1 + LBNRC(NBCS)=1 + + IF(ICALJP(NJP).EQ.2)THEN + ! *** WITHDRAWAL CELL + L=LIJ(IUPCJP(NJP),JUPCJP(NJP)) + NBCS=NBCS+1 + LBCS(NBCS)=L + LBERC(NBCS)=1 + LBNRC(NBCS)=1 + ENDIF + ENDDO + +C +C ** SET CHANNEL HOST AND GUEST LOCATION MAPPINGS +C + IF(MDCHH.GE.1)THEN + DO NMD=1,MDCHH + L=LIJ(IMDCHH(NMD),JMDCHH(NMD)) + LMDCHH(NMD)=L + NBCS=NBCS+1 + LBCS(NBCS)=L + IF(IMDCHU(NMD).EQ.1.AND.JMDCHU(NMD).EQ.1)THEN + LMDCHU(NMD)=1 + ELSE + L=LIJ(IMDCHU(NMD),JMDCHU(NMD)) + LMDCHU(NMD)=L + ENDIF + IF(IMDCHV(NMD).EQ.1.AND.JMDCHV(NMD).EQ.1)THEN + LMDCHV(NMD)=1 + ELSE + L=LIJ(IMDCHV(NMD),JMDCHV(NMD)) + LMDCHV(NMD)=L + ENDIF + NBCS=NBCS+1 + LBCS(NBCS)=L + ENDDO + ENDIF +C +C ** SET CELL FACE WET DEPTHS +C + HUWET(1)=HWET + HUWET(LC)=HWET + HVWET(1)=HWET + HVWET(LC)=HWET + HUDRY(1)=HDRY + HUDRY(LC)=HDRY + HVDRY(1)=HDRY + HVDRY(LC)=HDRY + DO L=2,LA + LS=LSC(L) + HUDRY(L)=HDRY+0.5*ABS(BELV(L)-BELV(L-1)) + HVDRY(L)=HDRY+0.5*ABS(BELV(L)-BELV(LS)) + HUWET(L)=HWET+0.5*ABS(BELV(L)-BELV(L-1)) + HVWET(L)=HWET+0.5*ABS(BELV(L)-BELV(LS)) + ENDDO + IF(ISDRY.GT.0)THEN + NDRYTMP=MOD(ISDRY,2) + IF(NDRYTMP.NE.0)THEN + DO L=2,LA + HUWET(L)=HWET + HVWET(L)=HWET + HUDRY(L)=HDRY + HVDRY(L)=HDRY + ENDDO + ENDIF + ENDIF +C +C *** SET PERMANENT FACE SWITCHES +C + DO L=1,LC + SUBO(L)=SUB(L) + SVBO(L)=SVB(L) + ENDDO +C +C ** DIAGNOSTIC OUTPUT +C + IF(DEBUG.AND.MYRANK.EQ.0)THEN + OPEN(1,FILE='SETBC.DIA',STATUS='UNKNOWN') + CLOSE(1,STATUS='DELETE') + OPEN(1,FILE='SETBC.DIA') + DO L=2,LA + WRITE(1,1001)IL(L),JL(L),SUB(L),SUB(L+1),SVB(L),SVB(LNC(L)), + & SPB(L) + ENDDO + CLOSE(1) + ENDIF + 1001 FORMAT(2I5,8E13.4) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SETSTVEL.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SETSTVEL.for index bda3eafe7..d76559a22 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SETSTVEL.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SETSTVEL.for @@ -1,4 +1,6 @@ FUNCTION SETSTVEL(D,SSG) + REAL WSET + WSET=0.0 C C CHANGE RECORD C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SHOWVAL.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SHOWVAL.f90 index 98b85db5c..8506e8266 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SHOWVAL.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SHOWVAL.f90 @@ -3,6 +3,7 @@ SUBROUTINE SHOWVAL ! *** REWRITTEN BY PAUL M. CRAIG ON DEC 2006 USE GLOBAL + USE MPI CHARACTER BLANK,ASTER,CSURF(32),CSALS(20),CSALB(20) CHARACTER UNITS*3, PARM*3 SAVE INFODT, JSHPRT, UNITS, SCALE, PARM @@ -13,6 +14,10 @@ SUBROUTINE SHOWVAL DATA ISREAD/0/ DATA SCALE/1.0/,UNITS/'PPM'/ + REAL CKB,CKC + CKB=0.0 + CKC=0.0 + IF(ISDYNSTP.EQ.0)THEN DELT=DT ELSE @@ -77,7 +82,8 @@ SUBROUTINE SHOWVAL ! *** ESTIMATE COMPUTATIONAL TIME IF(N.GT.1)THEN - CALL CPU_TIME(TCGRS) +! CALL CPU_TIME(TCGRS) + TCGRS=REAL(MPI_WTIMES(1)) T1=TBEGIN*TCON T2=(TBEGIN*TCON+TIDALP*NTC) TSPEED=TCGRS/(TIMESEC-T1) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SMRIN1.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SMRIN1.for index 3be1e4fc4..f1e2a5ebe 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SMRIN1.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SMRIN1.for @@ -3,6 +3,7 @@ C C CHANGE RECORD C USE GLOBAL + USE MPI PARAMETER (SMCW2=2.739726E-5) ! *** cm/y to m/day CHARACTER TITLE(3)*79, CCMRM*1 @@ -28,9 +29,12 @@ C SMTHKP=0.0 ENDIF C - OPEN(2,FILE='WQ3D.OUT',STATUS='UNKNOWN',POSITION='APPEND') + IF(MYRANK.EQ.0) OPEN(2,FILE='WQ3D.OUT', + & STATUS='UNKNOWN',POSITION='APPEND') OPEN(1,FILE='WQ3DSD.INP',STATUS='UNKNOWN') + IF(MYRANK.EQ.0)THEN PRINT *,'WQ: SD READING WQ3DSD.INP - MAIN DIAGENESIS CONTROL FILE' + ENDIF C C READ FIRST LINE IN WQ3DSD.INP FILE. IF FIRST CHARACTER IS '#', THEN C THIS IS THE NEW VERSION WITH ANNOTATED COMMENTS ADDED (I.E., USES THE @@ -49,23 +53,26 @@ C01 READ MAIN TITLE CARDS: C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) (TITLE(M), M=1,3) - WRITE(2,999) - WRITE(2,5100) (TITLE(M), M=1,3) + IF(MYRANK.EQ.0)WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,5100) (TITLE(M), M=1,3) C C02 I/O CONTROL VARIABLES AND TEMPERATURE RELATED VARIABLES C - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) ISMZ,ISMICI,ISMRST,ISMHYST,ISMZB + IF(MYRANK.EQ.0)THEN WRITE(2,53)'* # OF ZONES FOR SPAT. VARY. PARAMETERS IN SPM =',ISMZ + ENDIF C *** PMC BEGIN BLOCK C IF(ISMZ.GT.NSMZ) STOP 'ERROR!! ISMZ SHOULD BE <= NSMZ' PMC NSMZ=ISMZ C *** PMC END BLOCK + IF(MYRANK.EQ.0)THEN IF(ISMICI.EQ.1)THEN WRITE(2,50)'* SPATIALLY/TEMPORALLY-VARYING ICS FROM WQSDICI.INP' ELSE IF(ISMICI.EQ.2)THEN @@ -93,6 +100,7 @@ C *** PMC END BLOCK ELSE WRITE(2,50)'* NO DIAGNOSTIC OUTPUT FOR FUNC ZBRENT ' ENDIF + ENDIF C C03 C @@ -100,9 +108,10 @@ C IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) ISMTS,TSMTSB,TSMTSE,SMTSDT, ISSDBIN IF(ISMTS.GT.NWQTS)THEN - WRITE(2,50)'** ISMTS SHOULD BE <= NWQTS ** ' + IF(MYRANK.EQ.0)WRITE(2,50)'** ISMTS SHOULD BE <= NWQTS ** ' ISMTS=NWQTS ENDIF + IF(MYRANK.EQ.0)THEN WRITE(2,84) & '* TIME-SERIES OUTPUT FROM ', TSMTSB, ' DAY ', & ' TO ', TSMTSE, ' DAY ', @@ -134,6 +143,7 @@ C & ' DFN3 DFP1 DFP2 DFP3', & ' DFC1 DFC2 DFC3') ENDIF + ENDIF C C ISSDBIN > 0 TURNS ON BINARY FILE OUTPUT FOR BENTHIC FLUX RATES C @@ -146,28 +156,31 @@ C04 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,50) TITLE(1) - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) IF(ISMTS.GE.1)THEN + IF(MYRANK.EQ.0)THEN WRITE(2,50)': ICSMTS(I)=1, TIME-SERIES OUTPUT FOR VARIABLE I' WRITE(2,50)': ICSMTS(I)\=1, NO TIME-SERIES OUTPUT FOR VAR. I' WRITE(2,999) WRITE(2,50) TITLE(1) + ENDIF C C04 C DO M=1,ISMTS READ(1,5101) II,JJ,(ICSMTS(NW,M),NW=1,NTSSMV) IF(IJCT(II,JJ).LT.1 .OR. IJCT(II,JJ).GT.8)THEN - PRINT*, 'I, J = ', II,JJ + IF(MYRANK.EQ.0)PRINT*, 'I, J = ', II,JJ STOP 'ERROR!! INVALID (I,J): TIME-SERIES LOCATION' ENDIF LSMTS(M)=LIJ(II,JJ) - WRITE(2,5101) II,JJ,(ICSMTS(NW,M),NW=1,NTSSMV) + IF(MYRANK.EQ.0)WRITE(2,5101) II,JJ,(ICSMTS(NW,M),NW=1,NTSSMV) ENDDO ENDIF ISMTSB = NINT(TSMTSB/DTD) ISMTSE = NINT(TSMTSE/DTD) ISMTSDT = NINT(SMTSDT*3600.0/DT) + IF(MYRANK.EQ.0)THEN WRITE(2,53)': TIME-SERIES STARTING TIME STEP (IN DT UNIT) = ', & ISMTSB WRITE(2,53)': TIME-SERIES ENDING TIME STEP (IN DT UNIT) = ', @@ -176,47 +189,52 @@ C & ISMTSDT C PMC IF(MOD(ISMTSDT,IWQDT).NE.0) C PMC & STOP 'ERROR!! ISMTSDT SHOULD BE MULTIPLE OF IWQDT' + ENDIF 999 FORMAT(1X) 5100 FORMAT(A79) 5101 FORMAT(10I8) 5103 FORMAT(10F8.4) - 5104 FORMAT(I8, 3F8.4) +C5104 FORMAT(I8, 3F8.4) 50 FORMAT(A50) 51 FORMAT(A27, 3(F8.4,2X)) - 52 FORMAT((A45, E10.4)) + 52 FORMAT((A45, E11.4)) 53 FORMAT((A48, I10)) - 55 FORMAT(A31, 2I5) +C 55 FORMAT(A31, 2I5) 84 FORMAT(3(A26,F10.4,A5,/), 2(A26,I8,A10,/)) C C05 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) READ(1,5103) SMDIFT + IF(MYRANK.EQ.0)THEN WRITE(2,52)'* DIFF COEFF (M^2/S) FOR SED TEMPERATURE = ',SMDIFT + ENDIF SMDIFT = SMDIFT*8.64E4 ! *** Convert to m^2/day C C06 SPATIALLY CONSTANT PARAMETERS FOR SPLITING DEPOSITIONAL FLUXES OF AL C - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) C C07 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) READ(1,*) SMFNBC(1),SMFNBC(2),SMFNBC(3),SMFNBD(1),SMFNBD(2), & SMFNBD(3),SMFNBG(1),SMFNBG(2),SMFNBG(3) + IF(MYRANK.EQ.0)THEN WRITE(2,50)'* CYANOBACTERIA-N SPLIT INTO G1, G2 & G3 CLASSES ' WRITE(2,51)' : (FNBC1, FNBC2, FNBC3) = ', (SMFNBC(M),M=1,3) WRITE(2,50)'* DIATOMS-N SPLIT INTO G1, G2 & G3 CLASSES ' WRITE(2,51)' : (FNBD1, FNBD2, FNBD3) = ', (SMFNBD(M),M=1,3) WRITE(2,50)'* BLUE-GREEN ALGAE-N SPLIT INTO G1, G2, G3 CLASSES' WRITE(2,51)' : (FNBG1, FNBG2, FNBG3) = ', (SMFNBG(M),M=1,3) + ENDIF SUMNBC=SMFNBC(1)+SMFNBC(2)+SMFNBC(3) SUMNBD=SMFNBD(1)+SMFNBD(2)+SMFNBD(3) SUMNBG=SMFNBG(1)+SMFNBG(2)+SMFNBG(3) @@ -231,15 +249,17 @@ C07 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) READ(1,*) SMFPBC(1),SMFPBC(2),SMFPBC(3),SMFPBD(1),SMFPBD(2), & SMFPBD(3),SMFPBG(1),SMFPBG(2),SMFPBG(3) + IF(MYRANK.EQ.0)THEN WRITE(2,50)'* CYANOBACTERIA-P SPLIT INTO G1, G2 & G3 CLASSES ' WRITE(2,51)' : (FPBC1, FPBC2, FPBC3) = ', (SMFPBC(M),M=1,3) WRITE(2,50)'* DIATOMS-P SPLIT INTO G1, G2 & G3 CLASSES ' WRITE(2,51)' : (FPBD1, FPBD2, FPBD3) = ', (SMFPBD(M),M=1,3) WRITE(2,50)'* BLUE-GREEN ALGAE-P SPLIT INTO G1, G2, G3 CLASSES' WRITE(2,51)' : (FPBG1, FPBG2, FPBG3) = ', (SMFPBG(M),M=1,3) + ENDIF SUMPBC=SMFPBC(1)+SMFPBC(2)+SMFPBC(3) SUMPBD=SMFPBD(1)+SMFPBD(2)+SMFPBD(3) SUMPBG=SMFPBG(1)+SMFPBG(2)+SMFPBG(3) @@ -254,15 +274,17 @@ C08 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) READ(1,*) SMFCBC(1),SMFCBC(2),SMFCBC(3),SMFCBD(1),SMFCBD(2), & SMFCBD(3),SMFCBG(1),SMFCBG(2),SMFCBG(3) + IF(MYRANK.EQ.0)THEN WRITE(2,50)'* CYANOBACTERIA-C SPLIT INTO G1, G2 & G3 CLASSES ' WRITE(2,51)' : (FCBC1, FCBC2, FCBC3) = ', (SMFCBC(M),M=1,3) WRITE(2,50)'* DIATOMS-C SPLIT INTO G1, G2 & G3 CLASSES ' WRITE(2,51)' : (FCBD1, FCBD2, FCBD3) = ', (SMFCBD(M),M=1,3) WRITE(2,50)'* BLUE-GREEN ALGAE-C SPLIT INTO G1, G2, G3 CLASSES' WRITE(2,51)' : (FCBG1, FCBG2, FCBG3) = ', (SMFCBG(M),M=1,3) + ENDIF SUMCBC=SMFCBC(1)+SMFCBC(2)+SMFCBC(3) SUMCBD=SMFCBD(1)+SMFCBD(2)+SMFCBD(3) SUMCBG=SMFCBG(1)+SMFCBG(2)+SMFCBG(3) @@ -275,18 +297,20 @@ C C C09 SPATIALLY CONSTANT PARAMETERS FOR DIAGENESIS C - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) SMKPON(1),SMKPON(2),SMKPON(3),SMKPOP(1),SMKPOP(2), & SMKPOP(3),SMKPOC(1),SMKPOC(2),SMKPOC(3) + IF(MYRANK.EQ.0)THEN WRITE(2,50)'* DIAGENESIS RATE AT 20OC IN LAYER 2 (/DAY) ' WRITE(2,51)' : (KPON1,KPON2,KPON3) = ', (SMKPON(M),M=1,3) WRITE(2,51)' : (KPOP1,KPOP2,KPOP3) = ', (SMKPOP(M),M=1,3) WRITE(2,51)' : (KPOC1,KPOC2,KPOC3) = ', (SMKPOC(M),M=1,3) + ENDIF C C10 C @@ -294,17 +318,19 @@ C IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) SMTHKN(1),SMTHKN(2),SMTHKN(3),SMTHKP(1),SMTHKP(2), & SMTHKP(3),SMTHKC(1),SMTHKC(2),SMTHKC(3) + IF(MYRANK.EQ.0)THEN WRITE(2,50)'* TEMPERATURE EFFECT ON DIAGENESIS RATE ' WRITE(2,51)' : (THKN1,THKN2,THKN3) = ', (SMTHKN(M),M=1,3) WRITE(2,51)' : (THKP1,THKP2,THKP3) = ', (SMTHKP(M),M=1,3) WRITE(2,51)' : (THKC1,THKC2,THKC3) = ', (SMTHKC(M),M=1,3) WRITE(2,999) + ENDIF C C11 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) SMM1,SMM2,SMTHDD,SMTHDP,SMPOCR,SMKMDP,SMKBST, @@ -315,6 +341,7 @@ C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) SMO2BS,SMTDMBS,SMTCMBS + IF(MYRANK.EQ.0)THEN WRITE(2,50)'* SOLID CONCENTRATIONS (KG/L) IN LAYERS 1 AND 2 ' WRITE(2,51)' : (RM1, RM2) = ', SMM1,SMM2 WRITE(2,50)'* TEMP EFFECT ON MIXING IN DISSOLVED & PARTICULATE' @@ -327,21 +354,23 @@ C & ,'* CRITICAL O2 (G/M^3) FOR BENTH. HYSTERESIS= ',SMO2BS & ,': TIME LAG (DAYS) FOR MAX STRESS TO BE KEPT= ',SMTDMBS & ,': TIME DURATION (D) ABOVE WHICH HYSTERESIS = ',SMTCMBS + ENDIF ISMTDMBS = NINT(SMTDMBS/DTWQ) ISMTCMBS = NINT(SMTCMBS/DTWQ) SM1OKMDP = 1.0/SMKMDP SMBST1 = 1.0 / (1.0 + SMKBST*DTWQ) - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) C C13 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) SMP1NH4,SMP2NH4,SMKMNH4,SMKMO2N,SMTHNH4,SMTHNO3, & SMP2PO4,SMCO2PO4 + IF(MYRANK.EQ.0)THEN WRITE(2,50)'* PARTITION COEFF BET/ DISSOLVED AND SORBED NH4 ' WRITE(2,51)' : (P1NH4, P2NH4) = ', SMP1NH4,SMP2NH4 WRITE(2,50)'* HALF-SAT. CONST FOR NITRI. (GN/M^3, GO2/M^3) ' @@ -351,6 +380,7 @@ C WRITE(2,52)'* ANAEROBIC (LAY1) PARTITION COEF FOR PO4 (L/KG) = ' & ,SMP2PO4 & ,': CRITICAL DO (MG/L) FOR PO4 SORPTION = ',SMCO2PO4 + ENDIF SMFD1NH4 = 1.0 / (1.0 + SMM1*SMP1NH4) SMFP1NH4 = 1.0 - SMFD1NH4 SMFD2NH4 = 1.0 / (1.0 + SMM2*SMP2NH4) @@ -358,17 +388,18 @@ C SMKMO2N = SMKMO2N * 2.0 SMFD2PO4 = 1.0 / (1.0 + SMM2*SMP2PO4) SMFP2PO4 = 1.0 - SMFD2PO4 - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) C C14 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) SMP1H2S,SMP2H2S,SMKD1HS,SMKP1HS,SMTHH2S,SMKMH2S, & SMKCH4,SMTHCH4,SMCSHSCH + IF(MYRANK.EQ.0)THEN WRITE(2,50)'* PARTITION COEFF FOR H2S IN LAYER 1 (L/KG) ' WRITE(2,51)' : (P1H2S, P2H2S) = ', SMP1H2S,SMP2H2S WRITE(2,50)'* REACTION VEL (M/D) FOR DISSOL & PART. IN LAYER 1' @@ -379,6 +410,7 @@ C & ,': OXYGEN EFFECT (MG/L) ON H2S OXIDATION = ',SMKMH2S WRITE(2,52)'* METHANE OXIDATION REACTION VELOCITY (M/D)= ',SMKCH4 & ,': TEMPERATURE EFFECT ON CH4 OXIDATION RATE = ',SMTHCH4 + ENDIF SMFD1H2S = 1.0 / (1.0 + SMM1*SMP1H2S) SMFP1H2S = 1.0 - SMFD1H2S SMFD2H2S = 1.0 / (1.0 + SMM2*SMP2H2S) @@ -391,20 +423,23 @@ C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) SMO2C,SMO2NO3,SMO2NH4 + IF(MYRANK.EQ.0)THEN WRITE(2,52)'* STOICHI COEF FOR C USED BY H2S OX (GO2/GC)=',SMO2C & ,': STOICHI COEF FOR C USED BY DENITR (GO2/GN)=',SMO2NO3 & ,': STOICHI COEF FOR O2 USED BY NITRI (GO2/GN)=',SMO2NH4 WRITE(2,999) + ENDIF C C16 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) IF(ISSKIP .EQ. 0) READ(1,999) READ(1,*) SMKSI,SMTHSI,SMKMPSI,SMSISAT,SMP2SI,SMDP1SI,SMCO2SI, & SMJDSI + IF(MYRANK.EQ.0)THEN WRITE(2,52)'* PSI DISSOL. RATE AT 20C IN LAYER 2 (/D) = ',SMKSI & ,': TEMPERATURE EFFECT ON PSI DISSOLUTION = ',SMTHSI & ,': SAT. CONC. IN PORE WATER (G SI/M^3) = ',SMSISAT @@ -413,6 +448,7 @@ C & ,': CRITICAL DO (MG/L) FOR SI SORPTION = ',SMCO2SI & ,'* DETRITAL FLUX (G/M^2/D) EXCEPT DIATOMS = ',SMJDSI & ,'* DISSOLUTION HALF-SAT CONSTANT (G SI/M^3) = ',SMKMPSI + ENDIF SMFD2SI = 1.0 / (1.0 + SMM2*SMP2SI) SMFP2SI = 1.0 - SMFD2SI C @@ -446,29 +482,33 @@ C C C17 C - WRITE(2,998) + IF(MYRANK.EQ.0)WRITE(2,998) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) READ(1,*) SMPON(1,1),SMPON(1,2),SMPON(1,3),SMPOP(1,1), & SMPOP(1,2),SMPOP(1,3),SMPOC(1,1),SMPOC(1,2),SMPOC(1,3) + IF(MYRANK.EQ.0)THEN IF(ISMICI.NE.1 .AND. ISMICI.NE.2) & WRITE(2,5105) SMPON(1,1),SMPON(1,2),SMPON(1,3),SMPOP(1,1), & SMPOP(1,2),SMPOP(1,3),SMPOC(1,1),SMPOC(1,2),SMPOC(1,3) + ENDIF C C18 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) READ(1,*) SM1NH4(1),SM2NH4(1),SM2NO3(1),SM2PO4(1),SM2H2S(1), & SMPSI(1),SM2SI(1),SMBST(1),SMT(1) IF(ISMICI.NE.1 .AND. ISMICI.NE.2)THEN + IF(MYRANK.EQ.0)THEN WRITE(2,5105) SM1NH4(1),SM2NH4(1),SM2NO3(1),SM2PO4(1),SM2H2S(1), & SMPSI(1),SM2SI(1),SMBST(1),SMT(1) + ENDIF DO L=2,LA DO M=1,NSMG SMPON(L,M)=SMPON(1,M) @@ -489,18 +529,20 @@ C C C19 SMDIFT IN M^2/D C - WRITE(2,998) + IF(MYRANK.EQ.0)WRITE(2,998) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) DO I=1,ISMZ READ(1,*) MM,SMHSED(I),SMW2(I),SMDD(I),SMDP(I),SMKNH4(I), & SMK1NO3(I),SMK2NO3(I),SMDP1PO4(I), SODMULT(I) + IF(MYRANK.EQ.0)THEN WRITE(2,56) MM,SMHSED(I),SMW2(I),SMDD(I),SMDP(I),SMKNH4(I), & SMK1NO3(I),SMK2NO3(I),SMDP1PO4(I), SODMULT(I) + ENDIF SMW2(I) = SMW2(I)*SMCW2 ! *** M/Day SMDTOH(I) = DTWQ/SMHSED(I) SMHODT(I) = SMHSED(I)/DTWQ ! *** pmc - won't work for variable DT @@ -514,21 +556,23 @@ C SMW2PHODT(I) = SMW2(I) + SMHODT(I) SMDPMIN(I) = XSMDPMIN / (SMHSED(I)+ 1.E-18) ENDDO - WRITE(2,998) + IF(MYRANK.EQ.0)WRITE(2,998) C C20 C IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) IF(ISSKIP .GT. 0) CALL SKIPCOMM(1,CCMRM) READ(1,5100) TITLE(1) - WRITE(2,5100) TITLE(1) + IF(MYRANK.EQ.0)WRITE(2,5100) TITLE(1) DO I=1,ISMZ READ(1,*) MM,SMFNR(I,1),SMFNR(I,2),SMFNR(I,3),SMFPR(I,1), & SMFPR(I,2),SMFPR(I,3),SMFCR(I,1),SMFCR(I,2),SMFCR(I,3) + IF(MYRANK.EQ.0)THEN WRITE(2,54) MM,SMFNR(I,1),SMFNR(I,2),SMFNR(I,3),SMFPR(I,1), & SMFPR(I,2),SMFPR(I,3),SMFCR(I,1),SMFCR(I,2),SMFCR(I,3) + ENDIF SUMNBC=SMFNR(I,1)+SMFNR(I,2)+SMFNR(I,3) SUMNBD=SMFPR(I,1)+SMFPR(I,2)+SMFPR(I,3) SUMNBG=SMFCR(I,1)+SMFCR(I,2)+SMFCR(I,3) @@ -540,7 +584,7 @@ C & STOP 'ERROR!! SMFCR(I,1)+SMFCR(I,2)+SMFCR(I,3) SHOULD BE 1' ENDDO CLOSE(1) - 6666 FORMAT(A30) +C6666 FORMAT(A30) 998 FORMAT(80X) 5105 FORMAT(10F8.2) 54 FORMAT(I8, 10F8.3) @@ -553,36 +597,38 @@ C ENDDO IF(ISMZ .GT. 1)THEN OPEN(1,FILE='WQSDMAP.INP',STATUS='UNKNOWN') - WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,999) READ(1,90) (TITLE(M), M=1,3) - WRITE(2,90) (TITLE(M), M=1,3) + IF(MYRANK.EQ.0)WRITE(2,90) (TITLE(M), M=1,3) C C READ(1,999) C READ(1,999) - WRITE(2,999) - WRITE(2,92) + IF(MYRANK.EQ.0)WRITE(2,999) + IF(MYRANK.EQ.0)WRITE(2,92) IN=0 IJC=IC*JC DO M=1,IJC READ(1,*,END=1111) I,J,ISMZX IN=IN+1 IF(IJCT(I,J).LT.1 .OR. IJCT(I,J).GT.8.OR.ISMZX.GT.ISMZ)THEN ! *** PMC - PRINT*, 'I, J, IJCT(I,J) = ', I,J,IJCT(I,J) + IF(MYRANK.EQ.0)PRINT*, 'I, J, IJCT(I,J) = ', I,J,IJCT(I,J) STOP 'ERROR!! INVALID (I,J) IN FILE WQSDMAP.INP' ENDIF L = LIJ(I,J) ISMZMAP(L)=ISMZX - WRITE(2,91) L,I,J,ISMZMAP(L) + IF(MYRANK.EQ.0)WRITE(2,91) L,I,J,ISMZMAP(L) ENDDO 1111 CONTINUE IF(IN.NE.(LA-1))THEN + IF(MYRANK.EQ.0)THEN PRINT*, 'ALL ACTIVE SED. CELLS SHOULD BE MAPPED FOR SED PAR.' + ENDIF STOP 'ERROR!! NUMBER OF LINES IN FILE WQSDMAP.INP =\ (LA-1)' ENDIF CLOSE(1) ENDIF - CLOSE(2) + IF(MYRANK.EQ.0) CLOSE(2) 90 FORMAT(A79) 91 FORMAT(15I5) 92 FORMAT(' L I J ISMZMAP') diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SSEDTOX.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SSEDTOX.for index 8ed31c079..11db6ddd6 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SSEDTOX.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SSEDTOX.for @@ -56,6 +56,7 @@ C ** SUBROUTINE SSEDTOX CALCULATES SETTLING AND WATER COLUMN-BED C ** EXCHANGE OF SEDIMENT AND SORBED TOXIC CONTAMINANTS C USE GLOBAL + USE MPI ! *** EE BEGIN BLOCK IMPLICIT NONE @@ -402,7 +403,7 @@ C ** DIAGNOSTICS OF INITIALIZATION C TMP1=-999. C TMP2=-999. C - 2222 FORMAT(2I5,7E13.4) +C2222 FORMAT(2I5,7E13.4) C C ** SAVE OLD VALUES C @@ -730,7 +731,7 @@ C ENDIF C C**********************************************************************C - 869 FORMAT(' I,J,HGDH = ',2I5,F10.3) +C 869 FORMAT(' I,J,HGDH = ',2I5,F10.3) IF(IWRSP(1).LT.98)THEN !do not recalculate bed when SEDZLJ dynamics are active DO L=2,LA HBEDA(L)=0.0 @@ -831,7 +832,7 @@ C ENDDO ENDIF ENDIF - 8669 FORMAT('PA ERR ',I10,F10.5,8E14.6) +C8669 FORMAT('PA ERR ',I10,F10.5,8E14.6) C C ** UPDATE TOP BED LAYER THICKNESS AND VOID RATIO C ** FOR DEPOSITION-RESUSPENSION STEP @@ -995,14 +996,18 @@ C DO L=2,LA IF(HP(L).LT.0.0)THEN IF(ABS(H1P(L)).GT.HWET)THEN + IF(MYRANK.EQ.0)THEN WRITE(8,2348)TIMEDAY,IL(L),JL(L),HBED1(L,KBT(L)), & HBED(L,KBT(L)),BELV1(L),BELV(L),DELT + ENDIF ENDIF IF(ABS(H1P(L)).GE.HADJ)THEN ! PMC-WAS HWET ITMP=1 + IF(MYRANK.EQ.0)THEN WRITE(8,2345)IL(L),JL(L),HBED1(L,KBT(L)),HBED(L,KBT(L)), & BELV1(L),BELV(L),DELT,QSBDTOP(L),QWBDTOP(L),HBEDA(L) WRITE(8,2347)L,KBT(L),(HBED(L,K),K=1,KBT(L)) + ENDIF ELSE HP(L)=0.9*HDRY ENDIF @@ -1010,7 +1015,7 @@ C ENDDO IF(ITMP.EQ.1)THEN CALL RESTOUT(1) - IF(NDRYSTP.LT.0.AND.DEBUG) THEN + IF(NDRYSTP.LT.0.AND.DEBUG.AND.MYRANK.EQ.0) THEN OPEN(1,FILE='DRYLOSS.OUT') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='DRYLOSS.OUT') @@ -1028,7 +1033,7 @@ C 2345 FORMAT('NEG DEPTH DUE TO MORPH CHANGE', 2I5,12F12.5) 2347 FORMAT(' ', 2I5,12F12.5) 2348 FORMAT('WITHIN TOLERANCE MORPH CHANGE NEG DEPTH',F10.5,2I5,5F12.5) - 2346 FORMAT('MORP ERR ',2I5,6E15.6) +C2346 FORMAT('MORP ERR ',2I5,6E15.6) 1993 FORMAT(2I6,4E14.6) C C ++ ADJUST CONCENTRATIONS OF TRANSPORT VARIABLES IN RESPONSE TO @@ -1115,7 +1120,7 @@ C C C**********************************************************************C C - 8800 FORMAT(I5,8E14.5) +C8800 FORMAT(I5,8E14.5) CLOSE(1) CLOSE(11) CLOSE(21) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SUBCHAN.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SUBCHAN.for index 5a233a149..e2b7aea7c 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SUBCHAN.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SUBCHAN.for @@ -6,7 +6,11 @@ C ** SUBROUTINE SUBCHAN CALCULATES SUBGRID CHANNEL INTERACTIONS AND IS C ** CALLED FROM CALPUV2TC C USE GLOBAL + USE MPI DIMENSION IACTIVE(NCHANM),QCHANUT(NCHANM),QCHANVT(NCHANM) + REAL HCHNMX,HCHNMN + HCHNMX=0.0 + HCHNMN=0.0 C IF(MDCHH.GE.1)THEN IACTALL=0 @@ -128,10 +132,10 @@ C FP(LCHNV)=FP(LCHNV)-TMPVAL ENDIF ENDDO - WRITE(8,1949)N,IACTALL + IF(MYRANK.EQ.0) WRITE(8,1949)N,IACTALL ENDIF 1949 FORMAT(' N, # ACTIVE 2 GRID FLOWS = ',2I8) - 1948 FORMAT(I5,3E12.4) +C1948 FORMAT(I5,3E12.4) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SURFPLT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SURFPLT.for index fb9a09d09..f7e480859 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SURFPLT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SURFPLT.for @@ -5,6 +5,7 @@ C ** SUBROUTINE SURFPLT WRITES FILES TO CONTOUR FREE SURFACE C ** ELEVATION C USE GLOBAL + USE MPI CHARACTER*80 TITLE C C *** EE BEGIN BLOCK @@ -13,6 +14,8 @@ C C C *** EE END BLOCK C + call collect_in_zero(HP) + IF(MYRANK.EQ.0)THEN IF(IPPHXY.LE.2)THEN IF(JSPPH.NE.1) GOTO 300 OPEN(10,FILE='SURFCON.OUT') @@ -119,7 +122,7 @@ C WRITE (10)N,TIME,DELT IF(IBIN_TYPE.EQ.1)THEN DO L=2,LA - WRITE(10) HP(L) + WRITE(10) HP(L) ENDDO ENDIF IF(IBIN_TYPE.EQ.0)THEN @@ -129,6 +132,7 @@ C CLOSE(10) ENDIF + ENDIF ! MYRANK.EQ.0 C C *** EE END BLOCK C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SVDCMP.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SVDCMP.for index da3cc10d9..9635d490f 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SVDCMP.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/SVDCMP.for @@ -5,6 +5,9 @@ C CHANGE RECORD C DIMENSION A(MP,NP),W(NP),V(NP,NP) REAL,ALLOCATABLE,DIMENSION(:)::RV1 + INTEGER NM,L + NM=0 + L=0 ALLOCATE(RV1(N)) G=0.0 SCALE=0.0 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Sub_spore.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Sub_spore.for index f42bb16fb..52eef1e7c 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Sub_spore.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Sub_spore.for @@ -7,6 +7,8 @@ C USE GLOBAL INTEGER ICYAM + REAL WQKESS1 + WQKESS1=0.0 ! ITM=(NAT*3600)/(DT*NWQKDPT) @@ -58,7 +60,7 @@ C Average temperature LightAVG(L)=WQ_Light(L) ENDIF - ICYAM = ICYAMAP(L) + ICYAM = INT(ICYAMAP(L),KIND(ICYAM)) GER0(L) = CUM_GER(L) IF(TEMAVG(L).GE.CYA_TEM.AND.WQV(L,1,10).GE.CYA_P4D.AND. & WQV(L,1,15).GE.CYA_NO3.AND.LightAVG(L).GE.CYA_Light) THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/TMSR.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/TMSR.for index a0feda36e..bdfc549f8 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/TMSR.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/TMSR.for @@ -7,6 +7,7 @@ C ** VELOCITY, CONCENTRATION, AND VOLUME SOURCES AT SPECIFIED C ** (I,J) POINTS C USE GLOBAL + USE MPI CHARACTER*80 TITLE1,TITLE2,TITLE3,TITLE4,TITLE5,TITLE6,TITLE7, & TITLE11,TITLE12,TITLE13,TITLE14,TITLE15,TITLE16,TITLE17, @@ -259,6 +260,7 @@ C IF(MTMSRC(MLTM).EQ.1)THEN IF(ISTRAN(1).GE.1)THEN FNSAL(MLTM)='SALTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(11,FILE=FNSAL(MLTM),STATUS='UNKNOWN') CLOSE(11,STATUS='DELETE') OPEN(11,FILE=FNSAL(MLTM),STATUS='UNKNOWN') @@ -268,8 +270,10 @@ C WRITE (11,102) CTUNIT CLOSE(11) ENDIF + ENDIF IF(ISTRAN(2).GE.1)THEN FNTEM(MLTM)='TEMTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(21,FILE=FNTEM(MLTM),STATUS='UNKNOWN') CLOSE(21,STATUS='DELETE') OPEN(21,FILE=FNTEM(MLTM),STATUS='UNKNOWN') @@ -279,8 +283,10 @@ C WRITE (21,102) CTUNIT CLOSE(21) ENDIF + ENDIF IF(ISTRAN(3).GE.1)THEN FNDYE(MLTM)='DYETS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(31,FILE=FNDYE(MLTM),STATUS='UNKNOWN') CLOSE(31,STATUS='DELETE') OPEN(31,FILE=FNDYE(MLTM),STATUS='UNKNOWN') @@ -290,8 +296,10 @@ C WRITE (31,102) CTUNIT CLOSE(31) ENDIF + ENDIF IF(ISTRAN(4).GE.1)THEN FNDYE(MLTM)='SFLTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(31,FILE=FNSFL(MLTM),STATUS='UNKNOWN') CLOSE(31,STATUS='DELETE') OPEN(31,FILE=FNSFL(MLTM),STATUS='UNKNOWN') @@ -301,8 +309,10 @@ C WRITE (31,102) CTUNIT CLOSE(31) ENDIF + ENDIF IF(ISTRAN(6).GE.1)THEN FNSED(MLTM)='SEDTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(41,FILE=FNSED(MLTM),STATUS='UNKNOWN') CLOSE(41,STATUS='DELETE') OPEN(41,FILE=FNSED(MLTM),STATUS='UNKNOWN') @@ -312,10 +322,12 @@ C WRITE (41,102) CTUNIT CLOSE(41) ENDIF + ENDIF IF(ISTRAN(7).GE.1)THEN DO NX=1,NSND FNSND(MLTM,NX)='SND'// CNSND(NX) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(41,FILE=FNSND(MLTM,NX),STATUS='UNKNOWN') CLOSE(41,STATUS='DELETE') OPEN(41,FILE=FNSND(MLTM,NX),STATUS='UNKNOWN') @@ -324,10 +336,12 @@ C WRITE (41,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (41,102) CTUNIT CLOSE(41) + ENDIF ENDDO DO NX=1,NSND FNSBL(MLTM,NX)='SBL'// CNSBL(NX) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(41,FILE=FNSBL(MLTM,NX),STATUS='UNKNOWN') CLOSE(41,STATUS='DELETE') OPEN(41,FILE=FNSBL(MLTM,NX),STATUS='UNKNOWN') @@ -336,19 +350,12 @@ C WRITE (41,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (41,102) CTUNIT CLOSE(41) + ENDIF ENDDO -C FNSND(MLTM)='SNDTS' // CNTMSR(MLTM) // '.OUT' -C OPEN(41,FILE=FNSND(MLTM),STATUS='UNKNOWN') -C CLOSE(41,STATUS='DELETE') -C OPEN(41,FILE=FNSND(MLTM),STATUS='UNKNOWN') -C WRITE (41,100) TITLE4 -C WRITE (41,101) CLTMSR(MLTM) -C WRITE (41,103)ILTMSR(MLTM),JLTMSR(MLTM) -C WRITE (41,102) CTUNIT -C CLOSE(41) ENDIF IF(ISTRAN(6).GE.1.OR.ISTRAN(7).GE.1)THEN FNBED(MLTM)='BEDTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(41,FILE=FNBED(MLTM),STATUS='UNKNOWN') CLOSE(41,STATUS='DELETE') OPEN(41,FILE=FNBED(MLTM),STATUS='UNKNOWN') @@ -358,8 +365,10 @@ C CLOSE(41) WRITE (41,102) CTUNIT CLOSE(41) ENDIF + ENDIF IF(ISTRAN(8).GE.1)THEN FNDOX(MLTM)='DOXTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(41,FILE=FNDOX(MLTM),STATUS='UNKNOWN') CLOSE(41,STATUS='DELETE') OPEN(41,FILE=FNDOX(MLTM),STATUS='UNKNOWN') @@ -368,7 +377,9 @@ C CLOSE(41) WRITE (41,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (41,102) CTUNIT CLOSE(41) + ENDIF FNTOC(MLTM)='TOCTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(42,FILE=FNTOC(MLTM),STATUS='UNKNOWN') CLOSE(42,STATUS='DELETE') OPEN(42,FILE=FNTOC(MLTM),STATUS='UNKNOWN') @@ -377,7 +388,9 @@ C CLOSE(41) WRITE (42,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (42,102) CTUNIT CLOSE(42) + ENDIF FNNHX(MLTM)='NHXTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(43,FILE=FNNHX(MLTM),STATUS='UNKNOWN') CLOSE(43,STATUS='DELETE') OPEN(43,FILE=FNNHX(MLTM),STATUS='UNKNOWN') @@ -387,10 +400,12 @@ C CLOSE(41) WRITE (43,102) CTUNIT CLOSE(43) ENDIF + ENDIF IF(ISTRAN(5).GE.1)THEN DO NT=1,NTOX FNTOX(MLTM,NT)='TOX' // CNTOX(NT) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(51,FILE=FNTOX(MLTM,NT),STATUS='UNKNOWN') CLOSE(51,STATUS='DELETE') OPEN(51,FILE=FNTOX(MLTM,NT),STATUS='UNKNOWN') @@ -399,8 +414,10 @@ C CLOSE(41) WRITE (51,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (51,102) CTUNIT CLOSE(51) + ENDIF FNTXWT(MLTM,NT)='TXWT' // CNTOX(NT) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(51,FILE=FNTXWT(MLTM,NT),STATUS='UNKNOWN') CLOSE(51,STATUS='DELETE') OPEN(51,FILE=FNTXWT(MLTM,NT),STATUS='UNKNOWN') @@ -409,8 +426,10 @@ C CLOSE(41) WRITE (51,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (51,102) CTUNIT CLOSE(51) + ENDIF FNTXWF(MLTM,NT)='TXWF' // CNTOX(NT) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(51,FILE=FNTXWF(MLTM,NT),STATUS='UNKNOWN') CLOSE(51,STATUS='DELETE') OPEN(51,FILE=FNTXWF(MLTM,NT),STATUS='UNKNOWN') @@ -419,8 +438,10 @@ C CLOSE(41) WRITE (51,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (51,102) CTUNIT CLOSE(51) + ENDIF FNTXWC(MLTM,NT)='TXWC' // CNTOX(NT) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(51,FILE=FNTXWC(MLTM,NT),STATUS='UNKNOWN') CLOSE(51,STATUS='DELETE') OPEN(51,FILE=FNTXWC(MLTM,NT),STATUS='UNKNOWN') @@ -429,8 +450,10 @@ C CLOSE(41) WRITE (51,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (51,102) CTUNIT CLOSE(51) + ENDIF FNTXWP(MLTM,NT)='TXWP' // CNTOX(NT) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(51,FILE=FNTXWP(MLTM,NT),STATUS='UNKNOWN') CLOSE(51,STATUS='DELETE') OPEN(51,FILE=FNTXWP(MLTM,NT),STATUS='UNKNOWN') @@ -439,8 +462,10 @@ C CLOSE(41) WRITE (51,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (51,102) CTUNIT CLOSE(51) + ENDIF FNTXBT(MLTM,NT)='TXBT' // CNTOX(NT) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(51,FILE=FNTXBT(MLTM,NT),STATUS='UNKNOWN') CLOSE(51,STATUS='DELETE') OPEN(51,FILE=FNTXBT(MLTM,NT),STATUS='UNKNOWN') @@ -449,8 +474,10 @@ C CLOSE(41) WRITE (51,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (51,102) CTUNIT CLOSE(51) + ENDIF FNTXBF(MLTM,NT)='TXBF' // CNTOX(NT) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(51,FILE=FNTXBF(MLTM,NT),STATUS='UNKNOWN') CLOSE(51,STATUS='DELETE') OPEN(51,FILE=FNTXBF(MLTM,NT),STATUS='UNKNOWN') @@ -459,8 +486,10 @@ C CLOSE(41) WRITE (51,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (51,102) CTUNIT CLOSE(51) + ENDIF FNTXBC(MLTM,NT)='TXBC' // CNTOX(NT) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(51,FILE=FNTXBC(MLTM,NT),STATUS='UNKNOWN') CLOSE(51,STATUS='DELETE') OPEN(51,FILE=FNTXBC(MLTM,NT),STATUS='UNKNOWN') @@ -469,8 +498,10 @@ C CLOSE(41) WRITE (51,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (51,102) CTUNIT CLOSE(51) + ENDIF FNTXBP(MLTM,NT)='TXBP' // CNTOX(NT) // 'TS' // & CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(51,FILE=FNTXBP(MLTM,NT),STATUS='UNKNOWN') CLOSE(51,STATUS='DELETE') OPEN(51,FILE=FNTXBP(MLTM,NT),STATUS='UNKNOWN') @@ -479,11 +510,13 @@ C CLOSE(41) WRITE (51,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (51,102) CTUNIT CLOSE(51) + ENDIF ENDDO ENDIF ENDIF IF(MTMSRA(MLTM).EQ.1)THEN FNAVV(MLTM)='AVVTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(61,FILE=FNAVV(MLTM),STATUS='UNKNOWN') CLOSE(61,STATUS='DELETE') OPEN(61,FILE=FNAVV(MLTM),STATUS='UNKNOWN') @@ -492,7 +525,9 @@ C CLOSE(41) WRITE (61,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (61,102) CTUNIT CLOSE(61) + ENDIF FNAVB(MLTM)='AVBTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(71,FILE=FNAVB(MLTM),STATUS='UNKNOWN') CLOSE(71,STATUS='DELETE') OPEN(71,FILE=FNAVB(MLTM),STATUS='UNKNOWN') @@ -502,8 +537,10 @@ C CLOSE(41) WRITE (71,102) CTUNIT CLOSE(71) ENDIF + ENDIF IF(MTMSRP(MLTM).EQ.1)THEN FNSEL(MLTM)='SELTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(11,FILE=FNSEL(MLTM),STATUS='UNKNOWN') CLOSE(11,STATUS='DELETE') OPEN(11,FILE=FNSEL(MLTM),STATUS='UNKNOWN') @@ -513,8 +550,10 @@ C CLOSE(41) WRITE (11,102) CTUNIT CLOSE(11) ENDIF + ENDIF IF(MTMSRUE(MLTM).EQ.1)THEN FNUVE(MLTM)='UVETS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(21,FILE=FNUVE(MLTM),STATUS='UNKNOWN') CLOSE(21,STATUS='DELETE') OPEN(21,FILE=FNUVE(MLTM),STATUS='UNKNOWN') @@ -524,8 +563,10 @@ C CLOSE(41) WRITE (21,102) CTUNIT CLOSE(21) ENDIF + ENDIF IF(MTMSRUT(MLTM).EQ.1)THEN FNUVT(MLTM)='UVTTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(31,FILE=FNUVT(MLTM),STATUS='UNKNOWN') CLOSE(31,STATUS='DELETE') OPEN(31,FILE=FNUVT(MLTM),STATUS='UNKNOWN') @@ -535,8 +576,10 @@ C CLOSE(41) WRITE (31,102) CTUNIT CLOSE(31) ENDIF + ENDIF IF(MTMSRU(MLTM).EQ.1)THEN FNU3D(MLTM)='U3DTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(41,FILE=FNU3D(MLTM),STATUS='UNKNOWN') CLOSE(41,STATUS='DELETE') OPEN(41,FILE=FNU3D(MLTM),STATUS='UNKNOWN') @@ -545,7 +588,9 @@ C CLOSE(41) WRITE (41,103)ILTMSR(MLTM),JLTMSR(MLTM) WRITE (41,102) CTUNIT CLOSE(41) + ENDIF FNV3D(MLTM)='V3DTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(51,FILE=FNV3D(MLTM),STATUS='UNKNOWN') CLOSE(51,STATUS='DELETE') OPEN(51,FILE=FNV3D(MLTM),STATUS='UNKNOWN') @@ -555,8 +600,10 @@ C CLOSE(41) WRITE (51,102) CTUNIT CLOSE(51) ENDIF + ENDIF IF(MTMSRQE(MLTM).EQ.1)THEN FNQQE(MLTM)='QQETS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(61,FILE=FNQQE(MLTM),STATUS='UNKNOWN') CLOSE(61,STATUS='DELETE') OPEN(61,FILE=FNQQE(MLTM),STATUS='UNKNOWN') @@ -566,8 +613,10 @@ C CLOSE(41) WRITE (61,102) CTUNIT CLOSE(61) ENDIF + ENDIF IF(MTMSRQ(MLTM).EQ.1)THEN FNQ3D(MLTM)='Q3DTS' // CNTMSR(MLTM) // '.OUT' + IF(MYRANK.EQ.0)THEN OPEN(71,FILE=FNQ3D(MLTM),STATUS='UNKNOWN') CLOSE(71,STATUS='DELETE') OPEN(71,FILE=FNQ3D(MLTM),STATUS='UNKNOWN') @@ -577,9 +626,11 @@ C CLOSE(41) WRITE (71,102) CTUNIT CLOSE(71) ENDIF + ENDIF ENDDO C JSTMSR=0 + CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) C C----------------------------------------------------------------------C C @@ -642,6 +693,7 @@ C J=JLTMSR(MLTM) L=LIJ(I,J) LN=LNC(L) + IF(ISDOMAIN(L))THEN IF(MTMSRC(MLTM).EQ.1)THEN IF(ISTRAN(1).GE.1)THEN OPEN(11,FILE=FNSAL(MLTM),POSITION='APPEND') @@ -925,6 +977,7 @@ c IF(VHDXE(L).NE.0.0)CQBEDLOADY=QBEDLOADY/VHDXE(L) WRITE (71,201)TIME,(QSUM(L,K),K=1,KC) CLOSE(71) ENDIF + ENDIF ! ISDOMAIN(L) ENDIF ENDIF ENDDO diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/TOXCHEM.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/TOXCHEM.for index ecd98da09..65b346bd4 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/TOXCHEM.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/TOXCHEM.for @@ -12,7 +12,10 @@ C USE GLOBAL !{GeoSR, 2014.09.16. YSSONG - INTEGER::L,K,NS,NT + INTEGER::L,K,NT + REAL TXKL,TXKLL + TXKL=0.0 + TXKLL=0.0 !} IF(ISTRAN(5).GE.1)THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VALKH.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VALKH.for index 624d64259..06125d248 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VALKH.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VALKH.for @@ -3,6 +3,8 @@ C C CHANGE RECORD C USE GLOBAL + USE MPI + VALKH=0.0 IF(HFFDG.LE.0.02)THEN VALKH=HFFDG*HFFDG RETURN @@ -20,7 +22,7 @@ C RETURN ENDIF ENDDO - IF(NTAB.EQ.1001)THEN + IF(NTAB.EQ.1001.AND.MYRANK.EQ.0)THEN WRITE(6,600) RKHTAB(1001) WRITE(8,600) RKHTAB(1001) STOP diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARALLOC1.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARALLOC1.for index fc709d166..ace41014d 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARALLOC1.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARALLOC1.for @@ -2,6 +2,28 @@ USE GLOBAL C + ALLOCATE(DZCB_2D(LCM,KCM)) + ALLOCATE(BK_2D(LCM,KCM)) + ALLOCATE(DBK_1D(LCM)) + ALLOCATE(SHEAR_1D(LCM)) + ALLOCATE(HBED_1D(LCM)) + ALLOCATE(BDENBED_1D(LCM)) + ALLOCATE(PORBED_1D(LCM)) + ALLOCATE(N1_1D(LCM)) + ALLOCATE(CLOE_TMP(NBBEM,KCM,NSTVM)) + ALLOCATE(CLON_TMP(NBBNM,KCM,NSTVM)) + ALLOCATE(CLOS_TMP(NBBSM,KCM,NSTVM)) + ALLOCATE(CLOW_TMP(NBBWM,KCM,NSTVM)) + + ALLOCATE(NLOE_TMP(NBBEM,KCM,NSTVM)) + ALLOCATE(NLON_TMP(NBBNM,KCM,NSTVM)) + ALLOCATE(NLOS_TMP(NBBSM,KCM,NSTVM)) + ALLOCATE(NLOW_TMP(NBBWM,KCM,NSTVM)) + ALLOCATE(CSERT_TMP(KCM,0:NCSERM,NSTVM)) + ALLOCATE(CSERT_SUM(KCM,0:NCSERM,NSTVM)) + + + ALLOCATE(AAU(LCM)) ALLOCATE(AAV(LCM)) ALLOCATE(AB(LCM,KSM)) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARINIT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARINIT.for index 13197069e..f4feffcf2 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARINIT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARINIT.for @@ -30,7 +30,8 @@ C NWQPSRM=1 C NWQTDM=1 NOT USED NWQZM=1 - NXYSDATM=1 + NXYSDATM=1 + TIMESEC=0.0 C CALL SCANEFDC(NCSER1,NCSER2,NCSER3,NCSER4) IF(IWRSP(1)==98.OR.IWRSP(1)==99)CALL SCANSEDZLJ @@ -50,7 +51,7 @@ C GEOSR 2010.5.7 IF(NQCTL.GE.1 .AND. NQCTYP1.GE.3) THEN CALL SCANGATECTL CALL SCANGSER ! GEOSR 2011.10.27 - IF(NQCTYPM .GE. 13) THEN + IF(NQCTYPM .ge. 13) THEN CALL SCANGTAB ! GEOSR 2014.09. UNG ENDIF ENDIF @@ -90,7 +91,7 @@ C IF(ISTRAN(8).GT.0)THEN LCMWQ=LCM ELSE - LCMWQ=1 + LCMWQ=LCM ENDIF NQINFLM=MAX(1,NQSIJ+NQCTL+NQWR+2*MDCHH) C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARZEROInt.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARZEROInt.f90 index e40486a20..dd8287fd2 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARZEROInt.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARZEROInt.f90 @@ -4,8 +4,9 @@ SUBROUTINE VARZEROInt ! *** USE GLOBAL + USE MPI ! - WRITE(*,'(A)')'ZEROING Integer ARRAYS' + IF(MYRANK.EQ.0) WRITE(*,'(A)')'ZEROING Integer ARRAYS' ! ! *** INTEGER ARRAYS ! @@ -443,7 +444,15 @@ SUBROUTINE VARZEROInt !} GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. ISICE=0 !{GeoSR, 2015.01.15 JHLEE, NEGATIVE WATER TEMPERATURE PROBLEM ! x-species + NNN=0 IWQBENOX=0 TIME_NUM=0 IBIN_TYPE=0 + + N1_1D =0 + NLOE_TMP =0 + NLON_TMP =0 + NLOS_TMP =0 + NLOW_TMP =0 + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARZEROReal.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARZEROReal.f90 index b0e8854f8..46505053a 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARZEROReal.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VARZEROReal.f90 @@ -4,8 +4,9 @@ SUBROUTINE VARZEROReal !C *** USE GLOBAL + USE MPI !C - WRITE(*,'(A)')'ZEROING REAL ARRAYS' + IF(MYRANK.EQ.0) WRITE(*,'(A)')'ZEROING REAL ARRAYS' !C !C *** REAL ARRAYS @@ -1287,6 +1288,7 @@ SUBROUTINE VARZEROReal WC=0.0 WC2=0.0 WINDD=0.0 + WINDH=0.0 WINDS=0.0 WINDST=0.0 WINDSTKA=0.0 @@ -1747,6 +1749,21 @@ SUBROUTINE VARZEROReal LightAVG=0. LightAVG1=0. LightAVG0=0. + + CLOE_TMP =0. + CLON_TMP =0. + CLOS_TMP =0. + CLOW_TMP =0. + + CSERT_TMP =0. + CSERT_SUM =0. + DZCB_2D =0. + BK_2D =0. + DBK_1D =0. + SHEAR_1D =0. + HBED_1D =0. + BDENBED_1D =0. + PORBED_1D =0. END SUBROUTINE VARZEROReal diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VELPLTH_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VELPLTH_mpi.for new file mode 100644 index 000000000..bdf70efdd --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VELPLTH_mpi.for @@ -0,0 +1,402 @@ + SUBROUTINE VELPLTH_mpi +C +C CHANGE RECORD +C ADDED REAL FLAGS RSSBCE(L),RSSBCW(L),RSSBCN(L),RSSBCS(L) +C TO MODIFIED THE OUTPUTED CELL CENTER VELOCITY FOR CELLS HAVE SOURCE/ +C ** SUBROUTINE VELPLTH WRITES A HORIZONTAL INSTANTANEOUS VELOCITY +C ** VECTOR FILE +C + USE GLOBAL + USE MPI + INTEGER*4 VER + DIMENSION DBS(10) + CHARACTER*80 TITLE1,TITLE2,TITLE3,TITLE4,TITLE5,TITLE6,TITLE7 +C + call collect_in_zero_array(U) + call collect_in_zero_array(V) + call collect_in_zero_array(W) +C + IF(MYRANK.EQ.0)THEN + IF(IVPHXY.LE.2)THEN + IF(JSVPH.NE.1)GOTO 300 +C +C ** WRITE HEADINGS +C + TITLE1='INSTANTANEOUS HORIZ VELOCITY CM/S ' + TITLE2='INSTANTANEOUS BOTTOM STRESS CM2/S2' + TITLE3='BEDLOAD TRANSPORT KG/S' + TITLE4='DEPTH INTEGRAED SED TRANS KG/S' + TITLE5='EFFECTIVE BOTTOM ROUGHNESS CM' + TITLE6='CURRENT SHEAR VELOCITY CM/S' + TITLE7='WAVE-CURRENT SHEAR VELOCITY CM/S' + IF(ISVPH.EQ.1) LINES1=LA-1 + IF(ISVPH.EQ.2) LINES1=NRC + IF(ISVPH.EQ.3) LINES1=NBC + LEVELS=2 + LEVELT=1 + DBS(1)=0. + DBS(2)=99. + OPEN(10,FILE='VELVECH.OUT',STATUS='UNKNOWN') + CLOSE(10,STATUS='DELETE') + OPEN(10,FILE='VELVECH.OUT',STATUS='UNKNOWN') + WRITE (10,99) TITLE1 + WRITE (10,101)LINES1,LEVELS + WRITE (10,250)(DBS(L),L=1,LEVELS) + CLOSE(10) + OPEN(11,FILE='VELVECH.COC',STATUS='UNKNOWN') + CLOSE(11,STATUS='DELETE') + OPEN(11,FILE='VELVECH.COC',STATUS='UNKNOWN') + WRITE (11,99) TITLE1 + WRITE (11,101)LINES1,LEVELS + WRITE (11,250)(DBS(L),L=1,LEVELS) + CLOSE(11) + OPEN(10,FILE='TAUVECH.OUT',STATUS='UNKNOWN') + CLOSE(10,STATUS='DELETE') + OPEN(10,FILE='TAUVECH.OUT',STATUS='UNKNOWN') + WRITE (10,99) TITLE2 + WRITE (10,101)LINES1,LEVELT + WRITE (10,250)(DBS(L),L=1,LEVELT) + CLOSE(10) + IF(ISTRAN(7).GT.0)THEN + OPEN(10,FILE='SBLVECH.OUT',STATUS='UNKNOWN') + CLOSE(10,STATUS='DELETE') + OPEN(10,FILE='SBLVECH.OUT',STATUS='UNKNOWN') + WRITE (10,99) TITLE3 + WRITE (10,101)LINES1,LEVELS + WRITE (10,250)(DBS(L),L=1,LEVELS) + CLOSE(10) + ENDIF + IF(ISWAVE.GE.1)THEN + OPEN(10,FILE='ZBREFFH.OUT',STATUS='UNKNOWN') + CLOSE(10,STATUS='DELETE') + OPEN(10,FILE='ZBREFFH.OUT',STATUS='UNKNOWN') + WRITE (10,99) TITLE5 + WRITE (10,101)LINES1,LEVELT + WRITE (10,250)(DBS(L),L=1,LEVELT) + CLOSE(10) + ENDIF + IF(ISWAVE.GE.1)THEN + OPEN(10,FILE='CCUSTRH.OUT',STATUS='UNKNOWN') + CLOSE(10,STATUS='DELETE') + OPEN(10,FILE='CCUSTRH.OUT',STATUS='UNKNOWN') + WRITE (10,99) TITLE6 + WRITE (10,101)LINES1,LEVELT + WRITE (10,250)(DBS(L),L=1,LEVELT) + CLOSE(10) + ENDIF + IF(ISWAVE.GE.1)THEN + OPEN(10,FILE='WCUSTRH.OUT',STATUS='UNKNOWN') + CLOSE(10,STATUS='DELETE') + OPEN(10,FILE='WCUSTRH.OUT',STATUS='UNKNOWN') + WRITE (10,99) TITLE7 + WRITE (10,101)LINES1,LEVELT + WRITE (10,250)(DBS(L),L=1,LEVELT) + CLOSE(10) + ENDIF + JSVPH=0 + 300 CONTINUE + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N)+TCON*TBEGIN + TIME=TIME/TCON + ELSE + TIME=TIMESEC/TCON + ENDIF + OPEN(10,FILE='VELVECH.OUT',POSITION='APPEND') + WRITE (10,100)N,TIME + OPEN(11,FILE='TAUVECH.OUT',POSITION='APPEND') + WRITE (11,100)N,TIME + IF(ISTRAN(7).GT.0)THEN + OPEN(12,FILE='SBLVECH.OUT',POSITION='APPEND') + WRITE (12,100)N,TIME + ENDIF + IF(ISWAVE.GE.1)THEN + OPEN(14,FILE='ZBREFFH.OUT',POSITION='APPEND') + WRITE (14,100)N,TIME + OPEN(15,FILE='CCUSTRH.OUT',POSITION='APPEND') + WRITE (15,100)N,TIME + OPEN(16,FILE='WCUSTRH.OUT',POSITION='APPEND') + WRITE (16,100)N,TIME + ENDIF + OPEN(20,FILE='VELVECH.COC',POSITION='APPEND') + WRITE (20,100)N,TIME + QBOTTMP=100./CTURB3 + IF(IVPHXY.EQ.0)THEN + DO L=2,LA + LN=LNC(L) + UTMPS=50.*STCUV(L)*(RSSBCE(L)*U(L+1,KC)+RSSBCW(L)*U(L,KC)) + VTMPS=50.*STCUV(L)*(RSSBCN(L)*V(LN ,KC)+RSSBCS(L)*V(L,KC)) + VELEKC=CUE(L)*UTMPS+CVE(L)*VTMPS + VELNKC=CUN(L)*UTMPS+CVN(L)*VTMPS + UTMPB=50.*STCUV(L)*(RSSBCE(L)*U(L+1,1)+RSSBCW(L)*U(L,1)) + VTMPB=50.*STCUV(L)*(RSSBCN(L)*V(LN ,1)+RSSBCS(L)*V(L,1)) + VELEKB=CUE(L)*UTMPB+CVE(L)*VTMPB + VELNKB=CUN(L)*UTMPB+CVN(L)*VTMPB + UTMPA=50.*STCUV(L)*(RSSBCE(L)*UHE(L+1)*HUI(L+1) + & +RSSBCW(L)*UHE(L)*HUI(L)) + VTMPA=50.*STCUV(L)*(RSSBCN(L)*VHE(LN )*HVI(LN ) + & +RSSBCS(L)*VHE(L)*HVI(L)) + TUTMP=5000.*STCUV(L)*(RSSBCE(L)*TBX(L+1)+RSSBCW(L)*TBX(L)) + TVTMP=5000.*STCUV(L)*(RSSBCN(L)*TBY(LN )+RSSBCS(L)*TBY(L)) + VELEAV=CUE(L)*UTMPA+CVE(L)*VTMPA + VELNAV=CUN(L)*UTMPA+CVN(L)*VTMPA +C +C WRITE VELVECH.OUT +C + IF(KC.GT.1)WRITE(10,201) + & VELEKC,VELNKC,VELEKB,VELNKB,VELEAV,VELNAV + IF(KC.EQ.1)WRITE(10,200)IL(L),JL(L),VELEKB,VELNKB +C +C WRITE VELVECH.COC +C + IF(KC.GT.1)WRITE(20,201) + & UTMPS,VTMPS,UTMPB,VTMPB,UTMPA,VTMPA,TUTMP,TVTMP + IF(KC.EQ.1)WRITE(20,200)IL(L),JL(L),UTMPS,VTMPS,TUTMP,TVTMP + UTMP=5000.*STCUV(L)*(RSSBCE(L)*TBX(L+1)+RSSBCW(L)*TBX(L)) + VTMP=5000.*STCUV(L)*(RSSBCN(L)*TBY(LN )+RSSBCS(L)*TBY(L)) + VELEKC=CUE(L)*UTMP+CVE(L)*VTMP + VELNKC=CUN(L)*UTMP+CVN(L)*VTMP + TMPV1=10000.*TAUB(L) + TMPV2=10000.*TAUBSED(L) + TMPV3=10000.*TAUBSND(L) +C +C WRITE TAUVECH.OUT +C + WRITE(11,201)VELEKC,VELNKC,TMPV1,TMPV2,TMPV3 + IF(ISTRAN(7).GE.1) THEN + UTMP=0.0005*STCUV(L)*(RSSBCE(L)*QSBDLDX(L+1,1) + & +RSSBCW(L)*QSBDLDX(L ,1)) + VTMP=0.0005*STCUV(L)*(RSSBCN(L)*QSBDLDY(LN ,1) + & +RSSBCS(L)*QSBDLDY(L ,1)) + VELEKC=CUE(L)*UTMP+CVE(L)*VTMP + VELNKC=CUN(L)*UTMP+CVN(L)*VTMP + UTMP=0.0005*STCUV(L)*(RSSBCE(L)*QSBDLDX(L+1,2) + & +RSSBCW(L)*QSBDLDX(L,2)) + VTMP=0.0005*STCUV(L)*(RSSBCN(L)*QSBDLDY(LN ,2) + & +RSSBCS(L)*QSBDLDY(L,2)) + VELEKB=CUE(L)*UTMP+CVE(L)*VTMP + VELNKB=CUN(L)*UTMP+CVN(L)*VTMP + WRITE(12,200)VELEKC,VELNKC, + & VELEKB,VELNKB + END IF + IF(ISWAVE.EQ.2)THEN + ZBREFF=100.*ZBRE(L) + WRITE(14,201)ZBREFF + QTURBC=QBOTTMP*QQSQR(L,0) + WRITE(15,201)QTURBC + QTURBC=QBOTTMP*QQWV2(L) + WRITE(16,201)QTURBC + ENDIF + ENDDO + ENDIF + IF(IVPHXY.EQ.1)THEN + DO L=2,LA + LN=LNC(L) + UTMPS=50.*STCUV(L)*(RSSBCE(L)*U(L+1,KC)+RSSBCW(L)*U(L,KC)) + VTMPS=50.*STCUV(L)*(RSSBCN(L)*V(LN ,KC)+RSSBCS(L)*V(L,KC)) + VELEKC=CUE(L)*UTMPS+CVE(L)*VTMPS + VELNKC=CUN(L)*UTMPS+CVN(L)*VTMPS + UTMPB=50.*STCUV(L)*(RSSBCE(L)*U(L+1,1)+RSSBCW(L)*U(L,1)) + VTMPB=50.*STCUV(L)*(RSSBCN(L)*V(LN ,1)+RSSBCS(L)*V(L,1)) + VELEKB=CUE(L)*UTMPB+CVE(L)*VTMPB + VELNKB=CUN(L)*UTMPB+CVN(L)*VTMPB + UTMPA=50.*STCUV(L)*(RSSBCE(L)*UHE(L+1)*HUI(L+1) + & +RSSBCW(L)*UHE(L)*HUI(L)) + VTMPA=50.*STCUV(L)*(RSSBCN(L)*VHE(LN )*HVI(LN ) + & +RSSBCS(L)*VHE(L)*HVI(L)) + TUTMP=5000.*STCUV(L)*(RSSBCE(L)*TBX(L+1)+RSSBCW(L)*TBX(L)) + TVTMP=5000.*STCUV(L)*(RSSBCN(L)*TBY(LN )+RSSBCS(L)*TBY(L)) + VELEAV=CUE(L)*UTMPA+CVE(L)*VTMPA + VELNAV=CUN(L)*UTMPA+CVN(L)*VTMPA +C +C WRITE VELVECH.OUT +C + IF(KC.GT.1)WRITE(10,200)IL(L),JL(L), + & VELEKC,VELNKC,VELEKB,VELNKB,VELEAV,VELNAV + IF(KC.EQ.1)WRITE(10,200)IL(L),JL(L),VELEKB,VELNKB +C +C WRITE VELVECH.COC +C + IF(KC.GT.1)WRITE(20,200)IL(L),JL(L), + & UTMPS,VTMPS,UTMPB,VTMPB,UTMPA,VTMPA,TUTMP,TVTMP + IF(KC.EQ.1)WRITE(20,200)IL(L),JL(L),UTMPS,VTMPS,TUTMP,TVTMP + UTMP=5000.*STCUV(L)*(RSSBCE(L)*TBX(L+1)+RSSBCW(L)*TBX(L)) + VTMP=5000.*STCUV(L)*(RSSBCN(L)*TBY(LN )+RSSBCS(L)*TBY(L)) + VELEKC=CUE(L)*UTMP+CVE(L)*VTMP + VELNKC=CUN(L)*UTMP+CVN(L)*VTMP + TMPV1=10000.*TAUB(L) + TMPV2=10000.*TAUBSED(L) + TMPV3=10000.*TAUBSND(L) +C +C WRITE TAUVECH.OUT +C + WRITE(11,200)IL(L),JL(L),VELEKC,VELNKC,TMPV1,TMPV2,TMPV3 + IF(ISTRAN(7).GE.1) THEN + UTMP=0.0005*STCUV(L)*(RSSBCE(L)*QSBDLDX(L+1,1) + & +RSSBCW(L)*QSBDLDX(L ,1)) + VTMP=0.0005*STCUV(L)*(RSSBCN(L)*QSBDLDY(LN ,1) + & +RSSBCS(L)*QSBDLDY(L ,1)) + VELEKC=CUE(L)*UTMP+CVE(L)*VTMP + VELNKC=CUN(L)*UTMP+CVN(L)*VTMP + UTMP=0.0005*STCUV(L)*(RSSBCE(L)*QSBDLDX(L+1,2) + & +RSSBCW(L)*QSBDLDX(L,2)) + VTMP=0.0005*STCUV(L)*(RSSBCN(L)*QSBDLDY(LN ,2) + & +RSSBCS(L)*QSBDLDY(L,2)) + VELEKB=CUE(L)*UTMP+CVE(L)*VTMP + VELNKB=CUN(L)*UTMP+CVN(L)*VTMP + WRITE(12,200)IL(L),JL(L),VELEKC,VELNKC, + & VELEKB,VELNKB + END IF + IF(ISWAVE.EQ.2)THEN + ZBREFF=100.*ZBRE(L) + WRITE(14,200)IL(L),JL(L),DLON(L),DLAT(L),ZBREFF + QTURBC=QBOTTMP*QQSQR(L,0) + WRITE(15,200)IL(L),JL(L),DLON(L),DLAT(L),QTURBC + QTURBC=QBOTTMP*QQWV2(L) + WRITE(16,200)IL(L),JL(L),DLON(L),DLAT(L),QTURBC + ENDIF + ENDDO + ENDIF + !IF(IVPHXY.EQ.2)THEN + !END IF +![ykchoi(10.05.10.) for IVPHXY==2 + IF(IVPHXY.EQ.2)THEN + DO L=2,LA + LN=LNC(L) + UTMPS=50.*STCUV(L)*(RSSBCE(L)*U(L+1,KC)+RSSBCW(L)*U(L,KC)) + VTMPS=50.*STCUV(L)*(RSSBCN(L)*V(LN ,KC)+RSSBCS(L)*V(L,KC)) + VELEKC=CUE(L)*UTMPS+CVE(L)*VTMPS + VELNKC=CUN(L)*UTMPS+CVN(L)*VTMPS + UTMPB=50.*STCUV(L)*(RSSBCE(L)*U(L+1,1)+RSSBCW(L)*U(L,1)) + VTMPB=50.*STCUV(L)*(RSSBCN(L)*V(LN ,1)+RSSBCS(L)*V(L,1)) + VELEKB=CUE(L)*UTMPB+CVE(L)*VTMPB + VELNKB=CUN(L)*UTMPB+CVN(L)*VTMPB + UTMPA=50.*STCUV(L)*(RSSBCE(L)*UHE(L+1)*HUI(L+1) + & +RSSBCW(L)*UHE(L)*HUI(L)) + VTMPA=50.*STCUV(L)*(RSSBCN(L)*VHE(LN )*HVI(LN ) + & +RSSBCS(L)*VHE(L)*HVI(L)) + TUTMP=5000.*STCUV(L)*(RSSBCE(L)*TBX(L+1)+RSSBCW(L)*TBX(L)) + TVTMP=5000.*STCUV(L)*(RSSBCN(L)*TBY(LN )+RSSBCS(L)*TBY(L)) + VELEAV=CUE(L)*UTMPA+CVE(L)*VTMPA + VELNAV=CUN(L)*UTMPA+CVN(L)*VTMPA +C +C WRITE VELVECH.OUT +C + IF(KC.GT.1)WRITE(10,200)IL(L),JL(L),DLON(L), + & DLAT(L),VELEKC,VELNKC,VELEKB,VELNKB,VELEAV,VELNAV + IF(KC.EQ.1)WRITE(10,200)IL(L),JL(L),DLON(L),DLAT(L), + & VELEKB,VELNKB +C +C WRITE VELVECH.COC +C + IF(KC.GT.1)WRITE(20,'(2I5,1X,10E14.6)')IL(L),JL(L),DLON(L), + & DLAT(L),UTMPS,VTMPS,UTMPB,VTMPB,UTMPA,VTMPA,TUTMP,TVTMP + IF(KC.EQ.1)WRITE(20,200)IL(L),JL(L),DLON(L),DLAT(L), + & UTMPS,VTMPS,TUTMP,TVTMP + UTMP=5000.*STCUV(L)*(RSSBCE(L)*TBX(L+1)+RSSBCW(L)*TBX(L)) + VTMP=5000.*STCUV(L)*(RSSBCN(L)*TBY(LN )+RSSBCS(L)*TBY(L)) + VELEKC=CUE(L)*UTMP+CVE(L)*VTMP + VELNKC=CUN(L)*UTMP+CVN(L)*VTMP + TMPV1=10000.*TAUB(L) + TMPV2=10000.*TAUBSED(L) + TMPV3=10000.*TAUBSND(L) +C +C WRITE TAUVECH.OUT +C + WRITE(11,200)IL(L),JL(L),DLON(L),DLAT(L),VELEKC, + & VELNKC,TMPV1,TMPV2,TMPV3 + IF(ISTRAN(7).GE.1) THEN + UTMP=0.0005*STCUV(L)*(RSSBCE(L)*QSBDLDX(L+1,1) + & +RSSBCW(L)*QSBDLDX(L ,1)) + VTMP=0.0005*STCUV(L)*(RSSBCN(L)*QSBDLDY(LN ,1) + & +RSSBCS(L)*QSBDLDY(L ,1)) + VELEKC=CUE(L)*UTMP+CVE(L)*VTMP + VELNKC=CUN(L)*UTMP+CVN(L)*VTMP + UTMP=0.0005*STCUV(L)*(RSSBCE(L)*QSBDLDX(L+1,2) + & +RSSBCW(L)*QSBDLDX(L,2)) + VTMP=0.0005*STCUV(L)*(RSSBCN(L)*QSBDLDY(LN ,2) + & +RSSBCS(L)*QSBDLDY(L,2)) + VELEKB=CUE(L)*UTMP+CVE(L)*VTMP + VELNKB=CUN(L)*UTMP+CVN(L)*VTMP + WRITE(12,200)IL(L),JL(L),DLON(L),DLAT(L),VELEKC,VELNKC, + & VELEKB,VELNKB + END IF + IF(ISWAVE.EQ.2)THEN + ZBREFF=100.*ZBRE(L) + WRITE(14,200)IL(L),JL(L),DLON(L),DLAT(L),ZBREFF + QTURBC=QBOTTMP*QQSQR(L,0) + WRITE(15,200)IL(L),JL(L),DLON(L),DLAT(L),QTURBC + QTURBC=QBOTTMP*QQWV2(L) + WRITE(16,200)IL(L),JL(L),DLON(L),DLAT(L),QTURBC + ENDIF + ENDDO + ENDIF +!ykchoi] + CLOSE(10) + CLOSE(11) + IF(ISTRAN(7).GT.0)CLOSE(12) + CLOSE(13) + CLOSE(14) + CLOSE(15) + CLOSE(16) + CLOSE(20) + ENDIF +C +C *** EE BEGIN BLOCK +C *** OUTPUT EFDC EXPLORER FORMAT. DO NOT CHANGE OUTPUTS! +C *** MUST EXACTLY MATCH EFDC_EXPLORER INP +C + IF(IVPHXY.EQ.3)THEN + IF(JSVPH.EQ.1)THEN + LINES=LA-1 + OPEN(10,FILE='EE_VEL.OUT',STATUS='UNKNOWN', + & ACCESS='SEQUENTIAL',FORM='UNFORMATTED') + VER=103 + WRITE(10)VER,IC,JC,KC,LINES + WRITE(10)RSSBCE,RSSBCW,RSSBCS,RSSBCN + + CLOSE(10) + JSVPH=0 + ENDIF + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N)+TCON*TBEGIN + ELSE + TIME=TIMESEC + ENDIF + TIME=TIME/86400. + IF(ISDYNSTP.EQ.0)THEN + DELT=DT + ELSE + DELT=DTDYN + ENDIF + + OPEN(10,FILE='EE_VEL.OUT',POSITION='APPEND',STATUS='OLD', + & FORM='UNFORMATTED') + WRITE (10)N,TIME,DELT + + ! *** Write the UVW Instantaneous Velocity Field (Unrotated) + IF(IBIN_TYPE.EQ.1)THEN + DO L=2,LA + WRITE(10)(U(L,K),V(L,K),W(L,K),K=1,KC) + ENDDO + ENDIF + IF(IBIN_TYPE.EQ.0)THEN + WRITE(10)U + WRITE(10)V + WRITE(10)W + ENDIF + CALL FLUSH(10) + CLOSE(10) + ENDIF + ENDIF +C +C *** EE END BLOCK +C + 99 FORMAT(A80) + 100 FORMAT(I10,F12.4) + 101 FORMAT(2I10) + 200 FORMAT(2I5,1X,8E14.6) + 201 FORMAT(8E14.6) + 250 FORMAT(12E12.4) + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VSFP.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VSFP.for index d854b9ebb..8bdc7e0a0 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VSFP.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/VSFP.for @@ -271,7 +271,7 @@ C CLOSE(1) ENDIF ENDDO - 101 FORMAT(' INSTANTANEOUS VERTICAL SCALAR FIELD PROFILES') +C 101 FORMAT(' INSTANTANEOUS VERTICAL SCALAR FIELD PROFILES') 102 FORMAT(/) 103 FORMAT(' TIME = ',F12.4,' N = ',I8,' I,J = ',2I4, & ' H = ',F10.2) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Var_Global_Mod.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Var_Global_Mod.f90 index ce0a93b04..9595ee3d2 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Var_Global_Mod.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/Var_Global_Mod.f90 @@ -22,7 +22,7 @@ ! ** MODULE GLOBAL ! - Integer, PARAMETER :: NTSWQVM=23 !VB NTSWQVM CHANGED FROM 22 TO 23 TO ACCOMODATE CO2 + INTEGER, PARAMETER :: NTSWQVM=23 !VB NTSWQVM CHANGED FROM 22 TO 23 TO ACCOMODATE CO2 REAL, PARAMETER :: EPS=1e-8 ! CHARACTER*50 AGRFN @@ -3793,7 +3793,7 @@ MODULE GLOBAL INTEGER(4) ::maxprocs,maxprocs1 parameter(maxprocs=64,maxprocs1=maxprocs-1) - INTEGER(4) ::nthds, jse(2,0:maxprocs1),jse_LC(2,0:maxprocs1),jse_2_LC(2,0:maxprocs1),jse_LC1(2,0:maxprocs1) + INTEGER(4) ::nthds, jse(2,0:maxprocs1),jse_LC(2,0:maxprocs1),jse_2_LC(2,0:maxprocs1) !{GeoSR, 2014.07.04 YSSONG, WIND DRAG COEFF. INTEGER::ISWIND @@ -3925,5 +3925,55 @@ MODULE GLOBAL REAL,ALLOCATABLE::WQSALAX(:) REAL,ALLOCATABLE::WQSALBX(:) !} GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 + + REAL*8,ALLOCATABLE,DIMENSION(:)::APCG_R8 + REAL*8,ALLOCATABLE,DIMENSION(:)::PCG_R8 + REAL*8,ALLOCATABLE,DIMENSION(:)::RCG_R8 + + REAL,ALLOCATABLE,DIMENSION(:,:)::FQCPAD + REAL,ALLOCATABLE,DIMENSION(:,:)::QSUMNAD + REAL,ALLOCATABLE,DIMENSION(:,:)::QSUMPAD + + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::CLOUDTT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::EVAPTT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PATMTT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RAINTT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RHAT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SOLSWRTT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SVPAT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TATMTT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TWETTT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::VPAT + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDE + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDN + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSXX + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSXY + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSYX + REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSYY + + REAL*4,SAVE,ALLOCATABLE,DIMENSION(:,:) :: DZCB_2D + REAL*4,SAVE,ALLOCATABLE,DIMENSION(:,:) :: BK_2D + REAL*4,SAVE,ALLOCATABLE,DIMENSION(:) :: DBK_1D + + REAL*4,SAVE,ALLOCATABLE,DIMENSION(:) :: SHEAR_1D,HBED_1D,BDENBED_1D,PORBED_1D + REAL*4,SAVE,ALLOCATABLE,DIMENSION(:,:) :: SEDB_1D,SED_VFRBED_1D + REAL*4,SAVE,ALLOCATABLE,DIMENSION(:,:) :: SNDB_1D,SND_VFRBED_1D + INTEGER*4,SAVE,ALLOCATABLE,DIMENSION(:):: N1_1D + INTEGER :: ITIMING,IBIN_TYPE + REAL*4 :: SOLARAVG + REAL*8 :: SOLARAVG_R8 + + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:,:) :: CLOE_TMP + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:,:) :: CLON_TMP + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:,:) :: CLOS_TMP + REAL,SAVE,ALLOCATABLE,DIMENSION(:,:,:) :: CLOW_TMP + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:,:,:) :: NLOE_TMP + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:,:,:) :: NLON_TMP + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:,:,:) :: NLOS_TMP + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:,:,:) :: NLOW_TMP + + REAL,ALLOCATABLE,DIMENSION(:,:,:)::CSERT_TMP,CSERT_SUM + LOGICAL :: PRINT_SUM + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP4.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP4.for index 6edeaff75..b40f2fcea 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP4.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP4.for @@ -266,7 +266,7 @@ C 1014 FORMAT(2E10.3,2I5) 1015 FORMAT(I5) 1016 FORMAT(4(2F10.5)) - 1017 FORMAT(16I5) +C1017 FORMAT(16I5) C C ** WRITE ADVECTIVE TRANSPORT FILE WASPD.OUT C ** FILE WASPD.OUT IS CONSISTENT WITH DATA GROUP D.1 SPECIFICATIONS @@ -598,13 +598,13 @@ C CLOSE(95) 901 FORMAT(2I5,E12.4,4I5,E12.4) 902 FORMAT(I5,2X,3E12.4,2I5) - 903 FORMAT(3E12.4,2I5) +C 903 FORMAT(3E12.4,2I5) 904 FORMAT(I5,2X,E12.4,10I5) - 905 FORMAT(I5) - 906 FORMAT(5E12.4) +C 905 FORMAT(I5) +C 906 FORMAT(5E12.4) 941 FORMAT(2I5,E12.4,4I5,E12.4) 942 FORMAT(3E12.4,2I5) - 943 FORMAT(3E12.4,2I5) +C 943 FORMAT(3E12.4,2I5) 944 FORMAT(E12.4,10I5) 945 FORMAT(I5) 946 FORMAT(5E12.4) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP5.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP5.for index 5ae8c1f16..ecaf49a57 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP5.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP5.for @@ -11,6 +11,8 @@ C INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LDTMP INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LUTMP REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QTMP + INTEGER L + L = 0 IF(.NOT.ALLOCATED(LDTMP))THEN ALLOCATE(LDTMP(KCM*LCM)) @@ -785,18 +787,18 @@ C ENDDO CLOSE(90) CLOSE(94) - 901 FORMAT(2I5,E12.4,4I5,E12.4) +C 901 FORMAT(2I5,E12.4,4I5,E12.4) 902 FORMAT(I5,2X,3F20.8,3I5) - 903 FORMAT(3E12.4,2I5) +C 903 FORMAT(3E12.4,2I5) 904 FORMAT(I5,2X,F20.8,10I5) - 905 FORMAT(I5) - 906 FORMAT(5E12.4) +C 905 FORMAT(I5) +C 906 FORMAT(5E12.4) 941 FORMAT(2I5,3F20.8,I5) - 942 FORMAT(3E12.4,2I5) - 943 FORMAT(3E12.4,2I5) +C 942 FORMAT(3E12.4,2I5) +C 943 FORMAT(3E12.4,2I5) 944 FORMAT(I5,2X,F20.8,10I5) 9440 FORMAT(4F20.8) - 945 FORMAT(I5) +C 945 FORMAT(I5) 946 FORMAT(4F20.8) JSWASP=0 RETURN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP6.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP6.for index 1cf653d3e..eff8683e7 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP6.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP6.for @@ -21,6 +21,9 @@ C INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LDTMP INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LUTMP REAL,SAVE,ALLOCATABLE,DIMENSION(:)::QTMP + INTEGER LCLTM2, L + L = 0 + LCLTM2 = 0 IF(.NOT.ALLOCATED(LDTMP))THEN ALLOCATE(LDTMP((KCM+1)*LCM)) @@ -601,7 +604,7 @@ C CLOSE(92) ENDIF 2020 FORMAT(2I5,A12,' DATA GROUP D: FLOWS') - 2021 FORMAT(I5,2E10.3,' DATA BLOCK D.1 ADVECTIVE FLOWS') +C2021 FORMAT(I5,2E10.3,' DATA BLOCK D.1 ADVECTIVE FLOWS') 2022 FORMAT(I5,2E10.3,' DATA BLOCK D.2 PORE WATER FLOWS') 2023 FORMAT(I5,2E10.3,' DATA BLOCK D.3 SEDIMENT #1 TRANSPORT FIELD') 2024 FORMAT(I5,2E10.3,' DATA BLOCK D.4 SEDIMENT #2 TRANSPORT FIELD') @@ -1040,16 +1043,16 @@ C IF(IQOPT.EQ.4) CLOSE(95) 901 FORMAT(2I5,E12.4,4I5,E12.4) 902 FORMAT(I5,2X,3F20.8,3I5) - 903 FORMAT(3E12.4,2I5) +C 903 FORMAT(3E12.4,2I5) 904 FORMAT(I5,2X,F20.8,10I5) 905 FORMAT(I5) - 906 FORMAT(5E12.4) +C 906 FORMAT(5E12.4) 941 FORMAT(2I5,3F20.8,I5) - 942 FORMAT(3E12.4,2I5) - 943 FORMAT(3E12.4,2I5) +C 942 FORMAT(3E12.4,2I5) +C 943 FORMAT(3E12.4,2I5) 944 FORMAT(I5,2X,F20.8,10I5) 9440 FORMAT(4F20.8) - 945 FORMAT(I5) +C 945 FORMAT(I5) 946 FORMAT(4E17.9) JSWASP=0 RETURN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP7.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP7.for index 592002243..9d6a32028 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP7.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP7.for @@ -22,6 +22,8 @@ C C INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LDTMP INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LUTMP + INTEGER LCLTM2 + LCLTM2 = 0 C IF(.NOT.ALLOCATED(LDTMP))THEN ALLOCATE(LDTMP((KCM+1)*LCM)) @@ -576,8 +578,8 @@ C C C C - 6999 FORMAT(9I5,F5.1) - 6996 FORMAT(9I5,F5.1) +C6999 FORMAT(9I5,F5.1) +C6996 FORMAT(9I5,F5.1) WRITE(92,2030) LL DO L=1,LL,4 WRITE(92,1024) QTMP(L), LUTMP(L), LDTMP(L), @@ -634,7 +636,7 @@ C CLOSE(92) ENDIF 2020 FORMAT(2I5,A12,' DATA GROUP D: FLOWS') - 2021 FORMAT(1P,I5,2E10.3,' DATA BLOCK D.1 ADVECTIVE FLOWS') +C2021 FORMAT(1P,I5,2E10.3,' DATA BLOCK D.1 ADVECTIVE FLOWS') 2022 FORMAT(1P,I5,2E10.3,' DATA BLOCK D.2 PORE WATER FLOWS') 2023 FORMAT(1P,I5,2E10.3,' DATA BLOCK D.3 SED. #1 TRANSPORT FIELD') 2024 FORMAT(1P,I5,2E10.3,' DATA BLOCK D.4 SED. #2 TRANSPORT FIELD') @@ -1106,16 +1108,16 @@ C IF(IQOPT.EQ.4) CLOSE(95) 901 FORMAT(2I5,E12.5,4I5,E12.5) 902 FORMAT(I5,2X,3F20.8,3I5) - 903 FORMAT(3E12.5,2I5) +C 903 FORMAT(3E12.5,2I5) 904 FORMAT(I5,2X,F20.8,10I5) 905 FORMAT(I5) - 906 FORMAT(5E12.5) +C 906 FORMAT(5E12.5) 941 FORMAT(2I5,3F20.8,I5) - 942 FORMAT(3E12.5,2I5) - 943 FORMAT(3E12.5,2I5) +C 942 FORMAT(3E12.5,2I5) +C 943 FORMAT(3E12.5,2I5) 944 FORMAT(I5,2X,F20.8,10I5) 9440 FORMAT(4F20.8) - 945 FORMAT(I5) +C 945 FORMAT(I5) 946 FORMAT(4E17.9) 9946 FORMAT(3E17.9,I5) 9941 FORMAT(2I5,' !',3I5,3X,A3) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP7EPA.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP7EPA.for index 6869fb9b4..3ad8cc88a 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP7EPA.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WASP7EPA.for @@ -52,11 +52,12 @@ C CHARACTER*50 TITLEB,TITLEC CHARACTER*20 HYDFIL REAL*8 AUX,AUX1 - CHARACTER*20 SEGFIL ! 7-1-2005 A Stoddard C INTEGER,SAVE,ALLOCATABLE,DIMENSION(:,:,:)::LAUX INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LDTMP INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)::LUTMP + INTEGER LCLTM2 + LCLTM2 = 0 C IF(.NOT.ALLOCATED(LDTMP))THEN ALLOCATE(LDTMP((KCM+1)*LCM)) @@ -645,8 +646,8 @@ C qtmp array holds the horizontal area of each cell: END DO END IF C - 6999 format(9i5,f5.1) - 6996 format(9i5,f5.1) +C6999 format(9i5,f5.1) +C6996 format(9i5,f5.1) C WRITE(92,2030) LL DO L=1,LL,4 @@ -693,7 +694,7 @@ C add system bypass array to bottom of data group D: CLOSE(92) END IF 2020 format(2i5,a12,' Data Group D: Flows') - 2021 FORMAT(1p,I5,2e10.3,' Data Block D.1 Advective Flows') +C2021 FORMAT(1p,I5,2e10.3,' Data Block D.1 Advective Flows') 2022 FORMAT(1p,I5,2e10.3,' Data Block D.2 Pore Water Flows') 2023 FORMAT(1p,I5,2e10.3,' Data Block D.3 Sed. #1 Transport Field') 2024 FORMAT(1p,I5,2e10.3,' Data Block D.4 Sed. #2 Transport Field') @@ -1276,16 +1277,16 @@ C----------------------------------------------------------------------C C 901 FORMAT(2I5,E12.5,4I5,E12.5) 902 FORMAT(I5,2X,3F20.8,3I5) - 903 FORMAT(3E12.5,2I5) +C 903 FORMAT(3E12.5,2I5) 904 FORMAT(I5,2X,F20.8,10I5) 905 FORMAT(I5) - 906 FORMAT(5E12.5) +C 906 FORMAT(5E12.5) 941 FORMAT(3I5,3F20.5,I5) - 942 FORMAT(3E12.5,2I5) - 943 FORMAT(3E12.5,2I5) +C 942 FORMAT(3E12.5,2I5) +C 943 FORMAT(3E12.5,2I5) 944 FORMAT(I5,2X,F20.8,10I5) 9440 FORMAT(4F20.8) - 945 FORMAT(I5) +C 945 FORMAT(I5) 946 FORMAT(4E17.9) 9946 FORMAT(3e17.9,I5) 9941 FORMAT(2I5,' !',3i5,3x,a3) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WAVEBL.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WAVEBL.for index a9688751e..48c9104e0 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WAVEBL.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WAVEBL.for @@ -3,6 +3,7 @@ C C CHANGE RECORD C USE GLOBAL + USE MPI CHARACTER*9 FNWAVE CHARACTER*1 CFNWAVE(0:9) C @@ -83,11 +84,13 @@ C WVFRQL(L)=2.*PI/WVFRQL(L) ENDDO CLOSE(1) + IF(MYRANK.EQ.0)THEN OPEN(1,FILE='WAVEBL.DIA',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') + ENDIF NTMP=0 - WRITE(6,666)NTMP,FNWAVE - WRITE(8,666)NTMP,FNWAVE + IF(MYRANK.EQ.0) WRITE(6,666)NTMP,FNWAVE + IF(MYRANK.EQ.0) WRITE(8,666)NTMP,FNWAVE JSWAVE=1 ITWCBL1=1 ITWCBL2=0 @@ -145,8 +148,8 @@ C WVFRQL(L)=2.*PI/WVFRQL(L) ENDDO CLOSE(1) - WRITE(6,666)N,FNWAVE - WRITE(8,666)N,FNWAVE + IF(MYRANK.EQ.0) WRITE(6,666)N,FNWAVE + IF(MYRANK.EQ.0) WRITE(8,666)N,FNWAVE 666 FORMAT(' UPDATED WAVE FIELD N,FNWAVE = ',I12,A12) C C ** GENERATE WAVE TABLE @@ -179,7 +182,7 @@ C WVKHP(L)=1. IF(WVWHA(L).GT.0.) WVKHP(L)=VALKH(HFFDG) ENDDO - IF(JSWRPH.EQ.1)THEN + IF(JSWRPH.EQ.1.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='WVTAB.OUT',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='WVTAB.OUT',STATUS='UNKNOWN') @@ -195,13 +198,13 @@ C STOP 1083 WRITE(6,1093) NWVDAT STOP - 1084 WRITE(6,1094) IWVH +C1084 WRITE(6,1094) IWVH STOP 1 FORMAT(120X) 1091 FORMAT(' READ ERROR ON FILE WAVE.INP , HEADER') 1092 FORMAT(' READ ERROR ON FILE WAVE.INP , 1ST DATA') 1093 FORMAT(' READ ERROR ON FILE WAVE.INP , 2ND DATA, NWV = ',I5) - 1094 FORMAT(' READ ERROR ON FILE WAVE.INP , 3RD DATA, NWV = ',I5) +C1094 FORMAT(' READ ERROR ON FILE WAVE.INP , 3RD DATA, NWV = ',I5) 111 FORMAT(2E14.4) 400 CONTINUE DO L=2,LA @@ -221,9 +224,11 @@ C ** INITIALIZE WAVE-CURRENT BOUNDARY LAYER MODEL CALCULATING C ** THE WAVE TURBULENT INTENSITY, QQWV C ** AND SQUARED HORIZONTAL WAVE OBRITAL VELOCITY MAGNITUDE C + IF(MYRANK.EQ.0)THEN OPEN(1,FILE='WAVEBL.DIA') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='WAVEBL.DIA') + ENDIF DO L=2,LA AEXTMP=0.5*WVWHA(L)/SINH(WVKHP(L)) UWORBIT=AEXTMP*WVFRQL(L) @@ -262,8 +267,10 @@ C ZBRE(L)=ZBR(L)*(1.+0.19*TMPVAL) ENDIF ENDIF + IF(MYRANK.EQ.0)THEN WRITE(1,600)L,IL(L),JL(L),WVWHA(L),WVFRQL(L),AEXTMP,UWORBIT, & VISMUDD,REYWAVE,CDTMP,QQWV1(L),QQWV2(L),ZBR(L),ZBRE(L) + ENDIF ENDDO CLOSE(1) 600 FORMAT(3I5,11E12.4) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WAVESXY.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WAVESXY.for index d635a9f4e..f4a74a22e 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WAVESXY.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WAVESXY.for @@ -165,13 +165,13 @@ C STOP 1083 WRITE(6,1093) NWV STOP - 1084 WRITE(6,1094) NWV +C1084 WRITE(6,1094) NWV STOP 1 FORMAT(120X) 1091 FORMAT(' READ ERROR ON FILE WAVE.INP , HEADER') 1092 FORMAT(' READ ERROR ON FILE WAVE.INP , 1ST DATA') 1093 FORMAT(' READ ERROR ON FILE WAVE.INP , 2ND DATA, NWV = ',I5) - 1094 FORMAT(' READ ERROR ON FILE WAVE.INP , 3RD DATA, NWV = ',I5) +C1094 FORMAT(' READ ERROR ON FILE WAVE.INP , 3RD DATA, NWV = ',I5) 111 FORMAT(2E14.4) C C ** INITIALIZE OR UPDATE WAVE FIELD diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WINDWAVE.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WINDWAVE.f90 index 6a3469b25..8bcac3a39 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WINDWAVE.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WINDWAVE.f90 @@ -35,7 +35,7 @@ SUBROUTINE WINDWAVETUR !** GENERATE WAVE TABLE: IT IS NOT USED BY WIND WAVE DO L=2,LA WVKHP(L)=1. - IF(WVWHA(L).GE.WHMI) WVKHP(L)=2*PI/WV%RLS(L)*HP(L) + IF(WVWHA(L).GE.WHMI) WVKHP(L)=REAL(2*PI/WV%RLS(L)*HP(L),KIND(WVKHP)) ENDDO ! *** ADJUST WAVE HEIGHTS DEPENDING ON VEGETATION @@ -62,8 +62,8 @@ SUBROUTINE WINDWAVETUR DO L=2,LA IF(WVWHA(L).GE.WHMI)THEN - UWORBIT=WV%UDEL(L) - AEXTMP=MAX(KSW,UWORBIT/WVFRQL(L)) !TO CONTROL FW + UWORBIT=REAL(WV%UDEL(L),KIND(UWORBIT)) + AEXTMP=REAL(MAX(KSW,UWORBIT/WVFRQL(L)),KIND(AEXTMP)) !TO CONTROL FW UWVSQ(L)=UWORBIT*UWORBIT IF (UWVSQ(L)<1.E-6) UWVSQ(L)=0. ! PMC @@ -76,9 +76,9 @@ SUBROUTINE WINDWAVETUR QQWV1(L)=CDTMP*UWORBIT*UWORBIT ELSE !** TURBULENT ROUGH WAVE BOUNDARY LAYER - RA= AEXTMP/KSW + RA=REAL(AEXTMP/KSW,KIND(RA)) WV%FW = EXP(5.5*RA**(-0.2)-6.3) ! *** Nielsen (1992) for all RA's - CDTMP=0.5*WV%FW + CDTMP=REAL(0.5*WV%FW,KIND(CDTMP)) QQWV1(L)=CDTMP*UWORBIT*UWORBIT ENDIF ELSE @@ -88,8 +88,8 @@ SUBROUTINE WINDWAVETUR WVFRQL(L)=0. ENDIF - WV%TWX(L)=RHO*QQWV1(L)*WV%TWX(L) - WV%TWY(L)=RHO*QQWV1(L)*WV%TWY(L) + WV%TWX(L)=REAL(RHO*QQWV1(L)*WV%TWX(L),KIND(WV%TWX)) + WV%TWY(L)=REAL(RHO*QQWV1(L)*WV%TWY(L),KIND(WV%TWY)) ENDDO IF (TIMEDAY>=SNAPSHOTS(NSNAPSHOTS)) THEN @@ -114,7 +114,7 @@ SUBROUTINE WINDWAVECAL ! WVFRQL(L) - WAVE FREQENCY (SEC) ! WV%TWX(L),WV%TWY(L) INTEGER(4) ::L,ZONE - REAL(RKD) ::FW,WB,TAUW,TP + REAL(RKD) ::TP REAL(RKD) ::AVEDEP,WVEL2,FC1,FC2,FC3 REAL(RKD) ::WDIR ! WIND DIRECTION IN DEG [0,360] REAL(RKD) ::WINX,WINY !IN CURVI-LINEAR SYS @@ -132,8 +132,8 @@ SUBROUTINE WINDWAVECAL WVEL = SQRT(WVEL2) IF (HP(L)>HDRY.AND.WVEL>1D-6) THEN - WV%TWX(L)=WINX/WVEL - WV%TWY(L)=WINY/WVEL + WV%TWX(L)=REAL(WINX/WVEL,KIND(WV%TWX)) + WV%TWY(L)=REAL(WINY/WVEL,KIND(WV%TWY)) !AVEDEP=HP(L) IF(WINX>=0) THEN WDIR = ACOS(WV%TWY(L))*180./PI !DEG. (NORTH,WIND TO) @@ -146,14 +146,14 @@ SUBROUTINE WINDWAVECAL FC3 =TANH(0.530*(9.81*AVEDEP/WVEL2)**0.75) FC1=WVEL2/9.81*0.283*FC3 FC2=TANH(0.0125*(9.81*FWDIR(L,ZONE)/WVEL2)**0.42/FC3) - WVWHA(L)=MIN(0.75*HP(L),FC1*FC2) !INCLUDING BREAKING WAVE + WVWHA(L)=MIN(0.75*HP(L),REAL(FC1*FC2,KIND(WVWHA(L)))) !INCLUDING BREAKING WAVE ! *** WAVE FREQUENCY FC3 = TANH(0.833*(9.81*AVEDEP/WVEL2)**0.375) FC1=(WVEL/9.81)*7.54*FC3 FC2=TANH(0.077*(9.81*FWDIR(L,ZONE)/WVEL2)**0.25/FC3) - TP=MAX(1.0E-6,FC1*FC2) ! PERIOD - WVFRQL(L)=2.0*PI/TP ! FREQUENCY OMEGA + TP=MAX(1D-6,FC1*FC2) ! PERIOD + WVFRQL(L)=REAL(2.0*PI/TP,KIND(WVFRQL)) ! FREQUENCY OMEGA ! *** ORBITAL VELOCITY FC1=(2.0*PI/TP)**2*HP(L)/9.8 @@ -166,7 +166,7 @@ SUBROUTINE WINDWAVECAL ENDIF ! *** WAVE DIRECTION (RADIANS) ANTICLOCKWISE (CELL-EAST AXIS,WAVE) - WACCWE(L)=(90-WDIR-ROTAT)*PI/180._8 + WACCWE(L)=REAL((90-WDIR-ROTAT)*PI/180._8,KIND(WACCWE)) ELSE WVWHA(L) = 0 @@ -196,6 +196,8 @@ FUNCTION FETZONE(WDIR) RESULT(ZONE) REAL(RKD) ,INTENT(IN )::WDIR ![0,360] INTEGER(4)::ZONE + ZONE=0 + IF (WDIR>337.5 .OR. WDIR <= 22.5) THEN ZONE = 1 ELSEIF (WDIR>22.5 .AND. WDIR <= 67.5) THEN @@ -220,7 +222,7 @@ SUBROUTINE FETCH !OUTPUT: FWDIR(2:LA,1:NZONE) IN M USE DRIFTER,ONLY:INSIDECELL REAL(RKD)::AL(NZONE),RL,XM,YM,RL0 - INTEGER(4)::I,J,L,NZ,IM,JM,LM,STATUS,MUL + INTEGER(4)::I,J,L,NZ,IM,JM,LM,STATUS OPEN(UFET,FILE='FETCH.OUT') FWDIR = 0 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3D.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3D.for index 7a6e20606..4f9a57ae7 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3D.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3D.for @@ -8,7 +8,7 @@ C C Merged SNL and DS-INTL USE GLOBAL - REAL TTMP, SECNDS + REAL TTMP,T1TMP REAL, SAVE :: DAYNEXT REAL, SAVE :: SUNDAY1, SUNDAY2, SUNSOL1, SUNSOL2 REAL, SAVE :: SUNFRC1, SUNFRC2 @@ -22,6 +22,10 @@ C Merged SNL and DS-INTL DATA IWQTICI,IWQTAGR,IWQTSTL,IWQTSUN,IWQTBEN,IWQTPSL,IWQTNPL/7*0/ DATA ISMTICI/0/ + REAL SUNSOL01 + REAL SUNFRC02 + SUNSOL01=0.0 + SUNFRC02=0.0 IF(ETIMEDAY.LE.(DTWQ+1.E-8))THEN DAYNEXT=FLOAT(INT(TIMEDAY))+1. !{ GeoSR, YSSONG. 2012/12/15, RESTART @@ -437,14 +441,14 @@ C ![ GeoSR : 2012/12/15 WRITE(1234,*) TIMEDAY,DAYNEXT,WQI1,WQI2,WQI3 ! GeoSR : 2012/12/15] - - TTMP=SECNDS(0.0) + CALL CPU_TIME(TTMP) IF(ISWQLVL.EQ.0) CALL WQSKE0 IF(ISWQLVL.EQ.1) CALL WQSKE1 IF(ISWQLVL.EQ.2) CALL WQSKE2 IF(ISWQLVL.EQ.3) CALL WQSKE3 IF(ISWQLVL.EQ.4) CALL WQSKE4 - TWQKIN=TWQKIN+SECNDS(TTMP) + CALL CPU_TIME(T1TMP) + TWQKIN=TWQKIN+T1TMP-TTMP C C ** DIAGNOSE NEGATIVE CONCENTRATIONS C @@ -463,9 +467,10 @@ C C ** CALL SEDIMENT DIAGENSIS MODEL C IF(IWQBEN.EQ.1)THEN - TTMP=SECNDS(0.0) + CALL CPU_TIME(TTMP) CALL SMMBE - TWQSED=TWQSED+SECNDS(TTMP) + CALL CPU_TIME(T1TMP) + TWQSED=TWQSED+T1TMP-TTMP IF(ISMTS.GE.1)THEN C C ** WRITE SEDIMENT MODEL TIME SERIES diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3DINP.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3DINP.for index d8927e011..17478bdc8 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3DINP.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3DINP.for @@ -6,6 +6,7 @@ C OPTIMIZED AND MODIFIED BY J. M. HAMRICK C CHANGE RECORD C USE GLOBAL + USE MPI CHARACTER*3 CWQHDR(NWQVM) !{GeoSR, GROWTH LIMIT AND ALGAL RATE PRINT, YSSONG, 2015.12.10 CHARACTER*11 FLN1,FLN2 @@ -22,8 +23,12 @@ C PMC CHARACTER*11 HHMMSS IWQTPSL=IWQTPSL IWQTNPL=IWQTNPL ISMTICI=ISMTICI - OPEN(1,FILE='WQ3D.OUT',STATUS='UNKNOWN') - CLOSE(1,STATUS='DELETE') + CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) + IF(MYRANK.EQ.0)THEN + OPEN(8702,FILE='WQ3D.OUT',STATUS='UNKNOWN') + CLOSE(8702,STATUS='DELETE') + ENDIF + CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) C C ** HARDWIRE BY PASS OF RATE COEFFICIENT MAPS C @@ -129,9 +134,12 @@ C C CALL RWQC2 C CALL RWQMAP C + IF(DEBUG)THEN + IF(MYRANK.EQ.0)THEN OPEN(1,FILE='WQWCTS.OUT',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='WQWCTS.OUT',STATUS='UNKNOWN') + ENDIF NWQVOUT=0 DO NW=1,NWQV IF(ISTRWQ(NW).EQ.1)THEN @@ -139,18 +147,21 @@ C CWQHDR(NWQVOUT)=WQTSNAME(NW) ENDIF ENDDO - WRITE(1,1969)(CWQHDR(NW),NW=1,NWQVOUT) + IF(MYRANK.EQ.0) WRITE(1,1969)(CWQHDR(NW),NW=1,NWQVOUT) 1969 FORMAT('C I J K TIME',7X,A3,8X,A3,8X,A3, & 8X,A3,8X,A3,8X,A3,8X,A3,8X,A3,8X,A3, & 8X,A3,8X,A3,8X,A3,8X,A3,8X,A3,8X,A3, & 8X,A3,8X,A3,8X,A3,8X,A3,8X,A3,8X,A3) - CLOSE(1) + IF(MYRANK.EQ.0) CLOSE(1) + ENDIF C C ** INITIALIZE DIURNAL DO ANALYSIS C IF(NDDOAVG.GE.1.AND.DEBUG)THEN + IF(MYRANK.EQ.0)THEN OPEN(1,FILE='DIURNDO.OUT') CLOSE(1,STATUS='DELETE') + ENDIF DO K=1,KC DO L=2,LA DDOMAX(L,K)=-1.E6 @@ -162,8 +173,10 @@ C C ** INITIALIZE LIGHT EXTINCTION ANALYSIS C IF(NDLTAVG.GE.1)THEN + IF(MYRANK.EQ.0)THEN OPEN(1,FILE='LIGHT.OUT') CLOSE(1,STATUS='DELETE') + ENDIF NDLTCNT=0 DO K=1,KC DO L=2,LA @@ -187,7 +200,6 @@ C ! *** READ WQ TIMESERIES CALL RWQCSR C - !{GeoSR, GROWTH LIMIT AND ALGAL RATE PRINT, YSSONG, 2015.12.10 IF(IWQTS.GE.1)THEN IF(ISCOMP .EQ. 3. OR. ISCOMP .EQ. 4)THEN @@ -209,7 +221,7 @@ C ENDIF ENDIF !}GeoSR, GROWTH LIMIT AND ALGAL RATE PRINT, YSSONG, 2015.12.10 - 100 FORMAT(' TIME = ',A11,' HH.MM.SS.HH') +C 100 FORMAT(' TIME = ',A11,' HH.MM.SS.HH') RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3D_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3D_mpi.for new file mode 100644 index 000000000..51f9acbc3 --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQ3D_mpi.for @@ -0,0 +1,663 @@ + SUBROUTINE WQ3D_mpi(ISTL_,IS2TL_) +C +C CONTROL SUBROUTINE FOR WATER QUALITY MODEL +C ORGINALLY CODED BY K.-Y. PARK +C OPTIMIZED AND MODIFIED BY J. M. HAMRICK +C CHANGE RECORD +C +C Merged SNL and DS-INTL + USE GLOBAL + USE MPI + + REAL TTMP,T1TMP + REAL, SAVE :: DAYNEXT + REAL, SAVE :: SUNDAY1, SUNDAY2, SUNSOL1, SUNSOL2 + REAL, SAVE :: SUNFRC1, SUNFRC2 +!{ GeoSR, YSSONG. 2012/12/15, RESTART + REAL, SAVE :: SUNFRC0, SUNSOL0, SUNFRC11, SUNSOL11 + REAL, SAVE :: SUNFRC01,SUNSOL02,WQI0OPT0 + REAL, SAVE :: SUNFRC22,SUNSOL22,SUNFRC33, SUNSOL33 + INTEGER ISUNDAY2,IDAYNEXT +!} GeoSR + INTEGER*4, SAVE :: M + + DATA IWQTICI,IWQTAGR,IWQTSTL,IWQTSUN,IWQTBEN,IWQTPSL,IWQTNPL/7*0/ + DATA ISMTICI/0/ + + REAL SUNSOL01,SUNFRC02 + SUNSOL01=0.0 + SUNFRC02=0.0 + + + S1TIME=MPI_TIC() + IF(ETIMEDAY.LE.(DTWQ+1.E-8))THEN + DAYNEXT=FLOAT(INT(TIMEDAY))+1. +!{ GeoSR, YSSONG. 2012/12/15, RESTART + ISUNDAY2=0 + IDAYNEXT=0 + !IF(MYRANK.EQ.0.AND.DEBUG) OPEN(1234,FILE='SOL.DAT') + IF(MYRANK.EQ.0) OPEN(1234,FILE='SOL.DAT') +!} GeoSR + ENDIF + ! *** PMC - NEW IMPLEMENTATION TO USE DAILY (FROM HOURLY) SOLAR RADIATION FOR ALGAL GROWTH + IF(ITNWQ.EQ.0.AND.IWQSUN.GT.1.AND.NASER.GT.0)THEN + ! *** BUILD THE DAILY AVERAGE SOLAR RADIATION FROM THE ASER DATA +!{ GeoSR, YSSONG. 2012/12/15, RESTART + ! SUNDAY1 = TIMEDAY+0.5 + SUNDAY1 = FLOAT(INT(TIMEDAY))-0.5 +! SUNDAY2 = DAYNEXT+0.5 + SUNDAY2 = DAYNEXT-0.5 + + ! *** FIND 1ST POINT + M = 1 +! DO WHILE (TASER(M,1).LT.SUNDAY1-0.5) + DO WHILE (TASER(M,1).LT.SUNDAY2-0.5) + M = M+1 + END DO +!} GeoSR + + ! *** BUILD THE AVERAGE DAILY SOLAR RADIATION + M1 = 0 + M2 = 0 + SUNSOL1 = 0.0 + DO WHILE (TASER(M,1).LT. + + min(SUNDAY2+0.5,TASER(ubound(TASER,1),1))) + M1 = M1+1 + IF(SOLSWR(M,1).GT.0.)THEN + M2 = M2+1 + SUNSOL1=SUNSOL1+SOLSWR(M,1) + ENDIF + M = M+1 + END DO + IF(M1.GT.0)THEN + SUNFRC1=FLOAT(M2)/FLOAT(M1) + SUNSOL1=SUNSOL1/FLOAT(M1) + ELSE + SUNFRC1=1.0 + ENDIF + +!{ Geosr, jgcho, 2015.5.29 solswr + IF (M.ge.ubound(TASER,1)) then + SUNSOL2=SUNSOL1 + SUNFRC2=SUNFRC1 + ELSE ! IF (M.gt.ubound(TASER,1)) then + ! *** BUILD THE AVERAGE DAILY SOLAR RADIATION + M1 = 0 + M2 = 0 + SUNSOL2 = 0. + DO WHILE (TASER(M,1).LT. + + min(SUNDAY2+1.5,TASER(ubound(TASER,1),1))) + M1 = M1+1 + IF(SOLSWR(M,1).GT.0.)THEN + M2 = M2+1 + SUNSOL2=SUNSOL2+SOLSWR(M,1) + ENDIF + M = M+1 + END DO + IF(M1.GT.0)THEN + SUNFRC2=FLOAT(M2)/FLOAT(M1) + SUNSOL2=SUNSOL2/FLOAT(M1) + ELSE + SUNFRC2=1. + ENDIF + ENDIF ! IF (M.gt.ubound(TASER,1)) then +!} Geosr, jgcho, 2015.5.29 solswr + ENDIF +!{ GeoSR, YSSONG. 2012/12/15, RESTART + IF(ITNWQ.EQ.0)THEN +! IF(ISUNDAY2.EQ.0)THEN + IF(IWQSUN.GT.1.AND.NASER.GT.0)THEN + DO NDUM=2,4 + M = 1 + DO WHILE (TASER(M,1).LT.DAYNEXT-(FLOAT(NDUM))) + M = M+1 + END DO + M1 = 0 + M2 = 0 + SUNSOL0 = 0. +!{ Geosr, jgcho, 2015.5.29 solswr + IF(TASER(M,1).LE.DAYNEXT-(FLOAT(NDUM))) Then +! DO WHILE (TASER(M,1).LT.SUNDAY2-0.5) + DO WHILE (TASER(M,1).LT.DAYNEXT-(FLOAT(NDUM))+1.0) + IF(TASER(M,1).GE.DAYNEXT-(FLOAT(NDUM)))THEN + M1 = M1+1 + IF(SOLSWR(M,1).GT.0.)THEN + M2 = M2+1 + SUNSOL0=SUNSOL0+SOLSWR(M,1) !!! 1 day average + ENDIF + M = M+1 + ENDIF + END DO + IF(M1.GT.0)THEN + SUNFRC0=FLOAT(M2)/FLOAT(M1) + SUNSOL0=SUNSOL0/FLOAT(M1) !!! avg SUNSOL for timeday + ELSE + SUNFRC0=1.0 + ENDIF + ELSE ! IF(TASER(M,1).LE.DAYNEXT-(FLOAT(NDUM))) Then + SUNFRC0=SUNFRC1 + SUNSOL0=SUNSOL1 + ENDIF ! IF(TASER(M,1).LE.DAYNEXT-(FLOAT(NDUM))) Then +!} Geosr, jgcho, 2015.5.29 solswr + IF(NDUM.EQ.2)THEN ! PREVIOUS DAY + SUNSOL11=SUNSOL0 + SUNFRC11=SUNFRC0 + ELSEIF(NDUM.EQ.3)THEN ! TWO DAYS AGO + SUNSOL22=SUNSOL0 + SUNFRC22=SUNFRC0 + ELSEIF(NDUM.EQ.4)THEN ! THREE DAYS AGO + SUNSOL33=SUNSOL0 + SUNFRC33=SUNFRC0 + ENDIF + END DO + ENDIF +! ENDIF + +! IF(IDAYNEXT.EQ.0)THEN + IF(IWQSUN.GT.1.AND.NASER.GT.0)THEN + DO NDUM=2,4 + IF(NDUM.EQ.2)THEN ! PREVIOUS DAY + SUNSOL01=SUNSOL11 + SUNFRC01=SUNFRC11 + SUNSOL02=SUNSOL1 + SUNFRC02=SUNFRC1 + ELSEIF(NDUM.EQ.3)THEN ! TWO DAYS AGO + SUNSOL01=SUNSOL22 + SUNFRC01=SUNFRC22 + SUNSOL02=SUNSOL11 + SUNFRC02=SUNFRC11 + ELSEIF(NDUM.EQ.4)THEN ! THREE DAYS AGO + SUNSOL01=SUNSOL33 + SUNFRC01=SUNFRC33 + SUNSOL02=SUNSOL22 + SUNFRC02=SUNFRC22 + ENDIF + IF(IWQSUN.GT.1)THEN + RATIO = (TIMEDAY-SUNDAY1) + SOLARAVG = RATIO*(SUNSOL02-SUNSOL01)+SUNSOL01 + WQFD=RATIO*(SUNFRC02-SUNFRC01)+SUNFRC01 + ! *** SOLAR RADIATION IN LANGLEYS/DAY + WQI0 = PARADJ*2.065*SOLARAVG + IF(IWQSUN.EQ.2)THEN + ! *** OPTIMAL SOLAR RADIATION IS ALWAYS UPDATED BASED ON DAY AVERAGED + WQI0OPT0 = MAX(WQI0OPT0, WQI0/(WQFD+1.E-18)*0.85) + IF(NASER.GT.1.OR.USESHADE)THEN + SOLARAVG_R8=0. +c SOLARAVG=0. + DO L=LMPI2,LMPILA + SOLARAVG_R8=SOLARAVG_R8+SOLSWRT(L) +c SOLARAVG=SOLARAVG+SOLSWRT(L) + ENDDO + CALL MPI_ALLREDUCE(SOLARAVG_R8,MPI_R8,1,MPI_DOUBLE, + & MPI_SUM,MPI_COMM_WORLD,IERR) +c CALL MPI_ALLREDUCE(SOLARAVG,MPI_R4,1,MPI_REAL, +c & MPI_SUM,MPI_COMM_WORLD,IERR) + SOLARAVG=REAL(MPI_R8) +c SOLARAVG=REAL(MPI_R4) + SOLARAVG=SOLARAVG/FLOAT(LA-1) + ELSE + ! *** Spatially Constant Atmospheric Parameters + !SOLARAVG=SOLSWRT(2) + SOLARAVG=SOLSWRTT(1) + ENDIF + ! *** SOLAR RADIATION IN LANGLEYS/DAY + WQI0 = PARADJ*2.065*SOLARAVG + WQFD=1. + ELSEIF(IWQSUN.GT.2)THEN + ! *** OPTIMAL SOLAR RADIATION IS ALWAYS UPDATED BASED ON DAY AVERAGED + WQI0OPT0 = MAX(WQI0OPT0, WQI0) + ENDIF + IF(NDUM.EQ.2)THEN ! PREVIOUS DAY + WQI1=WQI0OPT0 + ELSEIF(NDUM.EQ.3)THEN ! TWO DAYS AGO + WQI2=WQI0OPT0 + ELSEIF(NDUM.EQ.4)THEN ! THREE DAYS AGO + WQI3=WQI0OPT0 + ENDIF + IF(IWQSUN.GT.0) WQI0OPT0 = 0.0 + ENDIF + END DO + ENDIF +! ENDIF + ENDIF +!} GeoSR, 2012/12/15 + MPI_WTIMES(701)=MPI_WTIMES(701)+MPI_TOC(S1TIME) +C +C ** READ INITIAL CONDITIONS +C + S1TIME=MPI_TIC() + IF(IWQICI.EQ.1) CALL RWQICI + MPI_WTIMES(702)=MPI_WTIMES(702)+MPI_TOC(S1TIME) +!{ GEOSR : DAY read jgcho 2016.10.06 + IF(ISDYNSTP.EQ.0)THEN + TIMTMP=(DT*FLOAT(N)+TCON*TBEGIN)/86400. + ELSE + TIMTMP=TIMESEC/86400. + ENDIF +!} GEOSR : DAY read jgcho 2016.10.06 +C +C ** READ TIME/SPACE VARYING ALGAE PARAMETERS +C +!{ GEOSR : DAY read jgcho 2016.10.06 +! IF(IWQAGR.EQ.1 .AND. ITNWQ.EQ.IWQTAGR) CALL RWQAGR(IWQTAGR) + S1TIME=MPI_TIC() + IF(IWQAGR.EQ.1) THEN + IF(TIMTMP .GE. AGRDAY) CALL RWQAGR(TIMTMP) + ENDIF + MPI_WTIMES(703)=MPI_WTIMES(703)+MPI_TOC(S1TIME) +!} GEOSR : DAY read jgcho 2016.10.06 +C +C +C ** READ TIME/SPACE VARYING SETTLING VELOCITIES +C +!{ GEOSR : DAY read jgcho 2016.10.06 +! IF(IWQSTL.EQ.1 .AND. ITNWQ.EQ.IWQTSTL) CALL RWQSTL(IWQTSTL) + S1TIME=MPI_TIC() + IF(IWQSTL.EQ.1) THEN + IF(TIMTMP .GE. STLDAY) CALL RWQSTL(TIMTMP) + ENDIF + MPI_WTIMES(704)=MPI_WTIMES(704)+MPI_TOC(S1TIME) +!{ GEOSR : DAY read jgcho 2016.10.06 +C +C *** READ BENTHIC FLUX IF REQUIRED +C *** CALL SPATIALLY AND TIME VARYING BENTHIC FLUX HERE. ONLY CALL RWQBEN2 +C *** IF SIMULATION TIME IS >= THE NEXT TIME IN THE BENTHIC FILE. +C + S1TIME=MPI_TIC() + IF(IWQBEN .EQ. 2)THEN +! IF(ISDYNSTP.EQ.0)THEN +! TIMTMP=(DT*FLOAT(N)+TCON*TBEGIN)/86400. +! ELSE +! TIMTMP=TIMESEC/86400. +! ENDIF + IF(TIMTMP .GE. BENDAY)THEN + CALL RWQBEN2(TIMTMP) + ENDIF + ENDIF + MPI_WTIMES(705)=MPI_WTIMES(705)+MPI_TOC(S1TIME) +C +C ** UPDATE POINT SOURCE LOADINGS +C + S1TIME=MPI_TIC() + IF(IWQPSL.EQ.1)THEN + CALL RWQPSL + ELSEIF(IWQPSL.EQ.2) THEN + CALL CALCSER_mpi(ISTL_) + ENDIF + MPI_WTIMES(706)=MPI_WTIMES(706)+MPI_TOC(S1TIME) +C + IF(.FALSE.)THEN + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'fWQV = ', sum(abs(dble(WQV))),WQI0,PARADJ,SOLARAVG + ENDIF + ENDIF + + S1TIME=MPI_TIC() + IF(MYRANK.EQ.0) CALL RWQATM_mpi + MPI_WTIMES(707)=MPI_WTIMES(707)+MPI_TOC(S1TIME) +C +C ** READ SEDIMENT MODEL INITIAL CONDITION +C + S1TIME=MPI_TIC() + IF(IWQBEN.EQ.1)THEN + IF(ISMICI.EQ.1 .AND. ITNWQ.EQ.ISMTICI) CALL RSMICI(ISMTICI) + ENDIF + MPI_WTIMES(708)=MPI_WTIMES(708)+MPI_TOC(S1TIME) +C +C ** UPDATE OLD CONCENTRATIONS +C FOLLOWING THE CALL TO CALWQC MINUS OLD D.O. BEFORE THE CALL). +C FIRST SUBTRACT THE OLD D.O. HERE: +C + S1TIME=MPI_TIC() + IF(ISMTSB.LT.ISMTSE)THEN + DO K=1,KC + DO L=LMPI2,LMPILA + XMRM = WQV(L,K,19)*DTWQ*DZC(K)*HP(L) + XDOTRN(L,K) = XDOTRN(L,K) - XMRM + XDOALL(L,K) = XDOALL(L,K) - XMRM + ENDDO + ENDDO + ENDIF + MPI_WTIMES(709)=MPI_WTIMES(709)+MPI_TOC(S1TIME) +C +C ** CALCULATE PHYSICAL TRANSPORT +C ** WQV(L,K,NW) SENT TO PHYSICAL TRANSPORT AND TRANSPORTED +C ** VALUE RETURNED IN WQV(L,K,NW) +C +C + IF(.FALSE.)THEN + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'gWQV = ', sum(abs(dble(WQV))),WQI0,PARADJ,SOLARAVG + ENDIF + ENDIF + + S1TIME=MPI_TIC() +C CALL CALWQC(ISTL_,IS2TL_) !transports (advects/disperses) WQV + CALL CALWQC_mpi(ISTL_,IS2TL_) !transports (advects/disperses) WQV + MPI_WTIMES(710)=MPI_WTIMES(710)+MPI_TOC(S1TIME) + IF(.FALSE.)THEN + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'hWQV = ', sum(abs(dble(WQV))),WQI0,PARADJ,SOLARAVG + ENDIF + ENDIF +C +C FOLLOWING THE CALL TO CALWQC MINUS OLD D.O. BEFORE THE CALL). +C NOW ADD THE NEW D.O. HERE: +C + S1TIME=MPI_TIC() + IF(ISMTSB.LT.ISMTSE)THEN + DO K=1,KC + DO L=LMPI2,LMPILA + XMRM = WQV(L,K,19)*DTWQ*DZC(K)*HP(L) + XDOTRN(L,K) = XDOTRN(L,K) + XMRM + XDOALL(L,K) = XDOALL(L,K) + XMRM + ENDDO + ENDDO + ENDIF + MPI_WTIMES(711)=MPI_WTIMES(711)+MPI_TOC(S1TIME) +C +C ** UPDATE WATER COLUMN KINETICS AND SEDIMENT MODEL +C ** OVER LONGER TIME INTERVALS THAN PHYSICAL TRANSPORT +C ** IF NWQKDPT .GT. 1 +C + NWQKCNT=NWQKCNT+1 + IF(ITNWQ.EQ.0.OR.NWQKCNT.EQ.NWQKDPT)THEN + S1TIME=MPI_TIC() + !IF(ITNWQ.NE.0)NWQKCNT=0 PMC + NWQKCNT=0 + ! ** UPDATE SOLAR RADIATION INTENSITY + ! WQI1 = SOLAR RADIATION ON PREVIOUS DAY + ! WQI2 = SOLAR RADIATION TWO DAYS AGO + ! WQI3 = SOLAR RADIATION THREE DAYS AGO + ! *** UPDATE OCCURS ONLY WHEN THE SIMULATION DAY CHANGES. + IF(TIMEDAY.GT.DAYNEXT)THEN ! *** DSLLC: FORCE A SOLAR DAY UPDATE +!{ GeoSR : 2012/12/15 SOLAR RADIATION FOR RESTART + IDAYNEXT=1 +!} GeoSR : 2012/12/15 + WQI3 = WQI2 + WQI2 = WQI1 + WQI1 = WQI0OPT + IF(IWQSUN.GT.0)WQI0OPT = 0.0 + DAYNEXT=DAYNEXT+1. + ENDIF + + IF(IWQSUN.GT.1)THEN + IF(TIMEDAY.GT.SUNDAY2)THEN +!{ GeoSR : 2012/12/15 SOLAR RADIATION FOR RESTART + ISUNDAY2=1 +!} GeoSR : 2012/12/15 + ! *** BUILD THE DAILY AVERAGE SOLAR RADIATION FROM THE ASER DATA + SUNDAY1 = SUNDAY2 + SUNSOL1 = SUNSOL2 + SUNFRC1 = SUNFRC2 +!{ Geosr, jgcho, 2015.5.29 solswr + ! *** FIND 1ST POINT + M = 1 + DO WHILE (TASER(M,1).LT.(SUNDAY2+0.5-EPS)) + M = M+1 + END DO + SUNDAY2 = SUNDAY2+1 + ! If date for next day is not provided use values of today + IF( M.ge.ubound(TASER,1) ) then + SUNSOL2=SUNSOL1 + SUNFRC2=SUNFRC1 + ELSE ! IF (M.gt.ubound(TASER,1)) then + ! *** BUILD THE AVERAGE DAILY SOLAR RADIATION + M1 = 0 + M2 = 0 + SUNSOL2 = 0. + DO WHILE (TASER(M,1).LT. + + min(SUNDAY2+0.5-EPS, TASER(ubound(TASER,1),1)) ) + M1 = M1+1 + IF(SOLSWR(M,1).GT.0.)THEN + M2 = M2+1 + SUNSOL2=SUNSOL2+SOLSWR(M,1) + ENDIF + M = M+1 + END DO + IF(M1.GT.0)THEN + SUNFRC2=FLOAT(M2)/FLOAT(M1) + SUNSOL2=SUNSOL2/FLOAT(M1) + ELSE + SUNFRC2=1. + ENDIF + ENDIF +!} Geosr, jgcho, 2015.5.29 SOLSWR + ENDIF + ENDIF + MPI_WTIMES(712)=MPI_WTIMES(712)+MPI_TOC(S1TIME) + ! ** READ SOLAR RADIATION INTENSITY AND DAYLIGHT LENGTH + ! NOTE: IWQSUN=1 CALLS SUBROUTINE RWQSUN WHICH READS THE DAILY + ! SOLAR RADIATION DATA FROM FILE SUNDAY.INP WHICH + ! ARE IN UNITS OF LANGLEYS/DAY. + ! IWQSUN=2 USES THE HOURLY SOLAR RADIATION DATA FROM ASER.INP + ! COUPLED WITH THE COMPUTED OPTIMAL DAILY LIGHT TO + ! LIMIT ALGAL GROWTH. + ! IWQSUN=3 USES THE DAILY AVERAGE SOLAR RADIATION DATA COMPUTED + ! FROM THE HOURLY ASER.INP AND THE COMPUTED OPTIMAL DAILY + ! LIGHT TO LIMIT ALGAL GROWTH. + ! IWQSUN>1 USES THE DAILY AVERAGE SOLAR RADIATION DATA COMPUTED + ! FROM THE HOURLY ASER.INP DATA. CONVERTS WATTS/M**2 TO + ! LANGLEYS/DAY USING 2.065. COMPUTES THE FRACTION OF + ! DAYLIGHT AND ADJUSTS FOR PHOTOSYNTHETIC ACTIVE RADIATION BY + ! PARADJ (~0.43) + ! + S1TIME=MPI_TIC() + IF(IWQSUN.EQ.0)THEN + WQI0OPT = WQI0 + ELSEIF(IWQSUN.EQ.1)THEN + CALL RWQSUN + WQI0=SOLSRDT + WQFD=SOLFRDT + ! *** OPTIMAL SOLAR RADIATION IS ALWAYS UPDATED BASED ON DAY AVERAGED + WQI0OPT = MAX(WQI0OPT, WQI0) + ELSEIF(IWQSUN.GT.1)THEN + RATIO = (TIMEDAY-SUNDAY1) + SOLARAVG = RATIO*(SUNSOL2-SUNSOL1)+SUNSOL1 + WQFD=RATIO*(SUNFRC2-SUNFRC1)+SUNFRC1 + + ! *** SOLAR RADIATION IN LANGLEYS/DAY + WQI0 = PARADJ*2.065*SOLARAVG + + IF(IWQSUN.EQ.2)THEN + ! *** OPTIMAL SOLAR RADIATION IS ALWAYS UPDATED BASED ON DAY AVERAGED + WQI0OPT = MAX(WQI0OPT, WQI0/(WQFD+1.E-18)*0.85) + + IF(NASER.GT.1.OR.USESHADE)THEN + SOLARAVG_R8=0. +c SOLARAVG=0. + DO L=LMPI2,LMPILA + SOLARAVG_R8=SOLARAVG_R8+SOLSWRT(L) +c SOLARAVG=SOLARAVG+SOLSWRT(L) + ENDDO + CALL MPI_ALLREDUCE(SOLARAVG_R8,MPI_R8,1,MPI_DOUBLE, + & MPI_SUM,MPI_COMM_WORLD,IERR) +c CALL MPI_ALLREDUCE(SOLARAVG,MPI_R4,1,MPI_REAL, +c & MPI_SUM,MPI_COMM_WORLD,IERR) + SOLARAVG=REAL(MPI_R8) +c SOLARAVG=REAL(MPI_R4) + SOLARAVG=SOLARAVG/FLOAT(LA-1) + ELSE + ! *** Spatially Constant Atmospheric Parameters + SOLARAVG=SOLSWRT(2) + !SOLARAVG=SOLSWRTT(1) + ENDIF + ! *** SOLAR RADIATION IN LANGLEYS/DAY + WQI0 = PARADJ*2.065*SOLARAVG + WQFD=1. + ELSE + ! *** OPTIMAL SOLAR RADIATION IS ALWAYS UPDATED BASED ON DAY AVERAGED + WQI0OPT = MAX(WQI0OPT, WQI0) + ENDIF + ENDIF + MPI_WTIMES(713)=MPI_WTIMES(713)+MPI_TOC(S1TIME) + IF(.FALSE.)THEN + call collect_in_zero(SOLSWRT) + IF(MYRANK.EQ.0)THEN + PRINT*, n,'SOLARAVG = ', WQI0,sum(SOLSWRT),SOLARAVG + ENDIF + ENDIF +C +C ** LOAD WQV INTO WQVO FOR REACTION CALCULATION +C + S1TIME=MPI_TIC() + NMALG=0 + IF(IDNOTRVA.GT.0) NMALG=1 + DO NW=1,NWQV+NMALG + IF(ISTRWQ(NW).NE.0)THEN + DO K=1,KC + DO L=LMPI2,LMPILA + WQVO(L,K,NW)=WQV(L,K,NW) + ENDDO + ENDDO + ENDIF + ENDDO +!{ GEOSR X-species : jgcho 2015.09.30 + DO NW=1,NXSP + DO K=1,KC + DO L=LMPI2,LMPILA + WQVOX(L,K,NW)=WQVX(L,K,NW) + ENDDO + ENDDO + ENDDO + MPI_WTIMES(714)=MPI_WTIMES(714)+MPI_TOC(S1TIME) +!} GEOSR X-species : jgcho 2015.09.30 +C +C ** CALCULATE KINETIC SOURCES AND SINKS +C + S1TIME=MPI_TIC() +![ GeoSR : 2012/12/15 + !IF(MYRANK.EQ.0.AND.DEBUG) + IF(MYRANK.EQ.0) + & WRITE(1234,*) TIMEDAY,DAYNEXT,WQI1,WQI2,WQI3 +! GeoSR : 2012/12/15] + CALL CPU_TIME(TTMP) + IF(.FALSE.)THEN + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + DO NSP=0,NXSP + call collect_in_zero_array(WQVX(:,:,NSP)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'11WQV = ', sum(abs(dble(WQV))) + PRINT*, n,'11WQVX = ', sum(abs(dble(WQVX))) + PRINT*, 'WQFDI0A =',WQI0BOT(3184),WQI0 + ENDIF + ENDIF + S1TIME=MPI_TIC() + IF(ISWQLVL.EQ.0) CALL WQSKE0 + IF(ISWQLVL.EQ.1) CALL WQSKE1 + IF(ISWQLVL.EQ.2) CALL WQSKE2 + IF(.FALSE.)THEN + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + DO NSP=0,NXSP + call collect_in_zero_array(WQVX(:,:,NSP)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'12WQV = ', sum(abs(dble(WQV))) + PRINT*, n,'12WQVX = ', sum(abs(dble(WQVX))) + PRINT*, 'WQFDI0B =',WQI0BOT(3184),WQI0 + ENDIF + ENDIF + IF(ISWQLVL.EQ.3) CALL WQSKE3_mpi + IF(.FALSE.)THEN + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + DO NSP=0,NXSP + call collect_in_zero_array(WQVX(:,:,NSP)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'13WQV = ', sum(abs(dble(WQV))) + PRINT*, n,'13WQVX = ', sum(abs(dble(WQVX))) + ENDIF + ENDIF + IF(ISWQLVL.EQ.4) CALL WQSKE4 + CALL CPU_TIME(T1TMP) + TWQKIN=TWQKIN+T1TMP-TTMP + MPI_WTIMES(715)=MPI_WTIMES(715)+MPI_TOC(S1TIME) + IF(.FALSE.)THEN + DO NW=0,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + DO NSP=0,NXSP + call collect_in_zero_array(WQVX(:,:,NSP)) + ENDDO + IF(MYRANK.EQ.0)THEN + PRINT*, n,'14WQV = ', sum(abs(dble(WQV))) + PRINT*, n,'14WQVX = ', sum(abs(dble(WQVX))) + ENDIF + ENDIF +C +C ** DIAGNOSE NEGATIVE CONCENTRATIONS +C + S1TIME=MPI_TIC() + IF(IWQNC.EQ.1)CALL WWQNC + MPI_WTIMES(716)=MPI_WTIMES(716)+MPI_TOC(S1TIME) +C +C ** WRITE TIME SERIES +C + IF(ITNWQ.GE.IWQTSB .AND. ITNWQ.LE.IWQTSE.AND.IWQTSE.GT.0)THEN + S1TIME=MPI_TIC() + IF(MOD(ITNWQ,IWQTSDT).EQ.0) CALL WWQTS +C +C CALL WWQTSBIN !{GeoSR, 2014.10.13 JHLEE, GROWTH LIMIT PRINT +C + ENDIF + MPI_WTIMES(717)=MPI_WTIMES(717)+MPI_TOC(S1TIME) + S1TIME=MPI_TIC() + IF(MYRANK.EQ.0) CALL WWQTSBIN !{GeoSR, 2014.10.13 JHLEE, GROWTH LIMIT PRINT + MPI_WTIMES(718)=MPI_WTIMES(718)+MPI_TOC(S1TIME) +C +C ** CALL SEDIMENT DIAGENSIS MODEL +C + S1TIME=MPI_TIC() + IF(IWQBEN.EQ.1)THEN + CALL CPU_TIME(TTMP) + CALL SMMBE + CALL CPU_TIME(T1TMP) + TWQSED=TWQSED+T1TMP-TTMP + IF(ISMTS.GE.1)THEN +C +C ** WRITE SEDIMENT MODEL TIME SERIES +C + IF(ITNWQ.GE.ISMTSB .AND. ITNWQ.LE.ISMTSE)THEN + IF(MOD(ITNWQ,ISMTSDT).EQ.0) CALL WSMTS + ENDIF + ENDIF +C +C ** WRITE SEDIMENT MODEL FLUXES TO BINARY FILE: +C + IF(ITNWQ.GE.ISMTSB .AND. ITNWQ.LE.ISMTSE)THEN + CALL WSMTSBIN + ENDIF + ENDIF + MPI_WTIMES(719)=MPI_WTIMES(719)+MPI_TOC(S1TIME) + ENDIF +C +C ** UPDATE TIME IN DAYS +C +![ GeoSR : 2010/07/27 +c ITNWQ = ITNWQ + 2 + ITNWQ = ITNWQ + 1 +! GeoSR : 2010/07/27] +C +C ** ENDIF ON KINETIC AND SEDIMENT UPDATE +C ** INSERT TIME CALL +C ** WRITE RESTART FILES +C + RETURN + END + diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE0.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE0.for index bd2f3831e..6b778d969 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE0.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE0.for @@ -17,6 +17,8 @@ C C**********************************************************************C C USE GLOBAL + REAL WQVREA + WQVREA=0.0 C CNS1=2.718 NS=1 @@ -55,7 +57,7 @@ C IWQT(L) = NINT( 4.*TWQ(L)+121.) C STOP 'ERROR!! INVALID WATER TEMPERATURE' ENDIF ENDDO - 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) + 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) 911 FORMAT(/,'ERROR: TIME, L, I, J, K, TWQ(L) = ', F10.5, 4I4, F10.4) C DO L=2,LA @@ -202,7 +204,7 @@ C ELSE WQP19(L) = 0.0 ENDIF - 666 FORMAT(' K,IWQ,IZ,WQTDKR = ',3I5,E12.4) +C 666 FORMAT(' K,IWQ,IZ,WQTDKR = ',3I5,E12.4) ENDDO C C TRAPEZOIDAL SOLUTION OF KINETIC EQS: AFTER COMPUTING NEW VALUES, STORE @@ -283,9 +285,9 @@ C SPM C DIURNAL DO ANALYSIS C LIGHT EXTINCTION ANALYSIS C - 1111 FORMAT(I12,F10.4) - 1112 FORMAT(2I5,12F7.2) - 1113 FORMAT(2I5,12E12.4) - 1414 FORMAT(I12,11E12.4) +C1111 FORMAT(I12,F10.4) +C1112 FORMAT(2I5,12F7.2) +C1113 FORMAT(2I5,12E12.4) +C1414 FORMAT(I12,11E12.4) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE1.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE1.for index fe7122169..4c6aacf2d 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE1.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE1.for @@ -38,7 +38,7 @@ C REAL TMP19,TEMFAC,DTWQxH,DTWQxH2,WQA19C,WQA19D,WQA19G REAL WQA19,WQA19A,WQSUM,WQRea,WQPOC,WQDOC,WQNH3,WQCOD REAL WQT20,WQR21,TIMTMP,WQTAMD - REAL WQT22,PPCDO,TMP22,WQA22,WQA22C,WQA22D,WQA22G + REAL PPCDO,TMP22,WQA22,WQA22C,WQA22D,WQA22G REAL WQCDSUM,WQCDREA,WQCDDOC REAL CHL_ABOVE @@ -53,6 +53,13 @@ C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WQISD REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WQISG + WQF1NM=0.0 + WQTTB=0.0 + WQTTT=0.0 + WQVREA=0.0 + WQTT1=0.0 + L=0 + C ! *** 1) CHC - cyanobacteria ! *** 2) CHD - diatom algae @@ -267,7 +274,7 @@ C ENDIF ENDDO ! *** DSLLC END BLOCK - 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) + 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) 911 FORMAT('ERROR: TIME, L, I, J, K, TWQ(L),TEM(L,K) = ', & F10.5, 4I4, 2F10.4,/) @@ -1863,7 +1870,7 @@ C 1111 FORMAT(I12,F10.4) 1112 FORMAT(2I5,12F7.2) 1113 FORMAT(2I5,12E12.4) - 1414 FORMAT(I12,11E12.4) +C1414 FORMAT(I12,11E12.4) RETURN END @@ -1875,6 +1882,10 @@ C REAL TSSS_ABOVE,WQCHLS_ABOVE,POMS_ABOVE REAL K_ABOVE + REAL EXPTOP + INTEGER L + L = 0 + EXPTOP=0.0 K=KC IF(ISTRAN(6).GT.0.OR.ISTRAN(7).GT.0)THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE2.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE2.for index d90142b03..8284ff19b 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE2.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE2.for @@ -7,6 +7,16 @@ C OPTIMIZED AND MODIFIED BY J.M. HAMRICK C CHANGE RECORD C USE GLOBAL + REAL WQAVGIO, WQF1NM, WQKESS1, WQTT1, WQTTB, WQTTT, WQVREA + INTEGER L + WQAVGIO=0.0 + WQF1NM=0.0 + WQKESS1=0.0 + WQTT1=0.0 + WQTTB=0.0 + WQTTT=0.0 + WQVREA=0.0 + L=0 C CNS1=2.718 NS=1 @@ -78,7 +88,7 @@ C IWQT(L) = NINT( 4.*TWQ(L)+121.) C STOP 'ERROR!! INVALID WATER TEMPERATURE' ENDIF ENDDO - 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) + 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) 911 FORMAT(/,'ERROR: TIME, L, I, J, K, TWQ(L) = ', F10.5, 4I4, F10.4) C C NOTE: MRM 04/29/99 ADDED ARRAYS TO KEEP TRACK OF diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE3.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE3.for index e1a1e2994..f144cf9d0 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE3.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE3.for @@ -10,6 +10,7 @@ C C LAST MODIFIED BY YSSONG ON 24 NOVEMBER 2011 USE GLOBAL + USE MPI C CHARACTER*11 FLN ! character array to print growth limit and algal rate INTEGER IZA ! Integer for benthic flux for anoxic env @@ -22,6 +23,15 @@ C !{ GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 REAL WQFDGSC(2),WQFDGSCX !} GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 + REAL WQVREA,WQTT1,WQTTT,WQF1NM,WQAVGIO,WQTTB,WQA1C + WQVREA=0.0 + WQTTT=0.0 + WQF1NM=0.0 + WQAVGIO=0.0 + WQTTB=0.0 + WQA1C=0.0 + WQTT1=0.0 + CNS1=2.718 NS=1 DO L=2,LA @@ -152,14 +162,14 @@ C IWQT(L) = NINT( 4.*TWQ(L)+121.) ELSE TIMTMP=TIMESEC/86400. ENDIF - WRITE(8,911) TIMTMP, L, IL(L), JL(L), K, TWQ(L) - WRITE(6,600)IL(L),JL(L),K,TWQ(L) + IF(MYRANK.EQ.0) WRITE(8,911) TIMTMP,L,IL(L),JL(L),K,TWQ(L) +c IF(MYRANK.EQ.0) WRITE(6,600)IL(L),JL(L),K,TWQ(L) IWQT(L)=MAX(IWQT(L),1) IWQT(L)=MIN(IWQT(L),NWQTD) C STOP 'ERROR!! INVALID WATER TEMPERATURE' ENDIF ENDDO - 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) + 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) 911 FORMAT(/,'ERROR: TIME, L, I, J, K, TWQ(L) = ', F10.5, 4I4, F10.4) C C NOTE: MRM 04/29/99 ADDED ARRAYS TO KEEP TRACK OF @@ -765,7 +775,7 @@ C **** PARAM 01 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} C C DEFINITIONS GROWTH BASAL METAB PREDATION SETTLING TIME STEP @@ -868,7 +878,6 @@ C DO L=2,LA enddo ENDIF ENDDO -!} ELSE DO L=2,LA WQV(L,K,1)=WQVO(L,K,1) @@ -891,7 +900,7 @@ C **** PARAM 02 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} C C DEFINITIONS GROWTH BASAL METAB PREDATION SETTLING TIME STEP @@ -987,7 +996,7 @@ C **** PARAM 03 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} C C DEFINITIONS GROWTH BASAL METAB PREDATION SETTLING TIME STEP @@ -1085,7 +1094,7 @@ C **** PARAM 04 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} C C DEFINITIONS HYDROLYSIS SETTLING @@ -1152,7 +1161,7 @@ C **** PARAM 05 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQC5 = - (WQKLPC(L)+WQLPSET(L,1)) WQKK(L) = 1.0 / (1.0 - DTWQO2*WQC5) @@ -1213,7 +1222,7 @@ C **** PARAM 06 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQD6 = - (WQKHR(L)+WQDENIT(L)) WQKK(L) = 1.0 / (1.0 - DTWQO2*WQD6) @@ -1272,7 +1281,7 @@ C **** PARAM 07 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQE7 = - (WQKRPP(L)+WQRPSET(L,1)) WQKK(L) = 1.0 / (1.0 - DTWQO2*WQE7) @@ -1338,7 +1347,7 @@ C **** PARAM 08 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQF8 = - (WQKLPP(L)+WQLPSET(L,1)) WQKK(L) = 1.0 / (1.0 - DTWQO2*WQF8) @@ -1404,7 +1413,7 @@ C **** PARAM 09 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQKK(L) = 1.0 / (1.0 + DTWQO2*WQKDOP(L)) WQA9C = (WQFPDC*WQBMC(L) + WQFPDP*WQPRC(L)) * WQVO(L,K,1) @@ -1454,7 +1463,7 @@ C **** PARAM 10 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQA10C=(WQFPIC*WQBMC(L)+WQFPIP*WQPRC(L)-WQPC(L)) & *WQVO(L,K,1) @@ -1534,7 +1543,7 @@ C **** PARAM 11 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQI11 = - (WQKRPN(L)+WQRPSET(L,1)) WQKK(L) = 1.0 / (1.0 - DTWQO2*WQI11) @@ -1603,7 +1612,7 @@ C **** PARAM 12 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQJ12 = - (WQKLPN(L)+WQLPSET(L,1)) WQKK(L) = 1.0 / (1.0 - DTWQO2*WQJ12) @@ -1672,7 +1681,7 @@ C **** PARAM 13 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQKK(L) = 1.0 / (1.0 + DTWQO2*WQKDON(L)) WQA13C=(WQFNDC*WQBMC(L)+WQFNDP*WQPRC(L))*WQANCC @@ -1726,7 +1735,7 @@ C **** PARAM 14 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} C C DEFINITIONS ATM DRY DEP LOADS VOLUMN @@ -1789,7 +1798,7 @@ C **** PARAM 15 DO L=2,LA IZ=IWQZMAP(L,K) !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} C C DEFINITIONS ATM DRY DEP LOADS VOLUMN @@ -1847,7 +1856,7 @@ C **** PARAM 16 IF(IWQSI.EQ.1)THEN DO L=2,LA !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQM16 = - (WQKSUA(IWQT(L)) + WQBDSET(L,1)) WQKK(L) = 1.0 / (1.0 - DTWQO2*WQM16) @@ -1904,7 +1913,7 @@ C **** PARAM 17 IF(IWQSI.EQ.1)THEN DO L=2,LA !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQKK(L) = (WQFSID*WQBMD(L) + WQFSIP*WQPRD(L) - WQPD(L)) & * WQASCD * WQVO(L,K,2) @@ -1966,7 +1975,7 @@ C **** PARAM 18 IF(ISTRWQ(18).EQ.1)THEN DO L=2,LA !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQKK(L) = 1.0 / (1.0 - WQO18(L)) C @@ -2009,7 +2018,7 @@ C **** PARAM 19 IF(ISTRWQ(19).EQ.1)THEN DO L=2,LA !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQKK(L) = 1.0 / (1.0 - DTWQO2*WQP19(L)) C @@ -2159,7 +2168,7 @@ C **** PARAM 20 IF(IWQSRP.EQ.1)THEN DO L=2,LA !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQT20 = - DTWQO2*WQWSSET(L,1) WQKK(L) = 1.0 / (1.0 - WQT20) @@ -2196,7 +2205,7 @@ C **** PARAM 21 IF(IWQFCB.EQ.1)THEN DO L=2,LA !{GeoSR, YSSONG, WQ WET/DRY, 110915 - IF(LMASKDRY(L).AND.IWQM.GE.1)THEN + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN !} WQKK(L) = WQTD2FCB(IWQT(L)) C @@ -2232,6 +2241,7 @@ C IF(ISCOMP .EQ. 3. OR. ISCOMP .EQ. 4)THEN TIME=DT*FLOAT(N)+TCON*TBEGIN TIME=TIME/TCON + IF(MYRANK.EQ.0)THEN WRITE(FLN,"('WQRTS',I2.2,'.DAT')") K OPEN(3,FILE=FLN,POSITION='APPEND') DO M=1,IWQTS @@ -2242,6 +2252,8 @@ C CLOSE(3) ENDIF ENDIF + ENDIF +!}GeoSR, GROWTH LIMIT AND ALGAL RATE PRINT, YSSONG, 2015.12.10 ENDDO C ---------------------------------------------------------------- C @@ -2298,7 +2310,7 @@ C COUPLING TO SEDIMENT MODEL C: EVALUATE DEP. FLUX USING NEW VALUES CAUSE IMPLICIT SCHEME IS USED IN C SPM C - IF(IWQBEN.EQ.1)THEN + IF(IWQBEN.EQ.0)THEN DO L=2,LA IMWQZ = IWQZMAP(L,1) WQDFBC(L) = SCB(L)*WQWSC(IMWQZ)*WQV(L,1,1) @@ -2349,7 +2361,7 @@ C C DIURNAL DO ANALYSIS C IF(NDDOAVG.GE.1)THEN - OPEN(1,FILE='DIURNDO.OUT',POSITION='APPEND') + IF(MYRANK.EQ.0) OPEN(1,FILE='DIURNDO.OUT',POSITION='APPEND') NDDOCNT=NDDOCNT+1 NSTPTMP=NDDOAVG*NTSPTC/2 RMULTMP=1./FLOAT(NSTPTMP) @@ -2367,11 +2379,13 @@ C ELSE TIME=TIMESEC/TCON ENDIF + IF(MYRANK.EQ.0)THEN WRITE(1,1111)N,TIME DO L=2,LA WRITE(1,1112)IL(L),JL(L),(DDOMIN(L,K),K=1,KC), & (DDOMAX(L,K),K=1,KC) ENDDO + ENDIF DO K=1,KC DO L=2,LA DDOMAX(L,K)=-1.E6 @@ -2379,13 +2393,13 @@ C ENDDO ENDDO ENDIF - CLOSE(1) + IF(MYRANK.EQ.0) CLOSE(1) ENDIF C C LIGHT EXTINCTION ANALYSIS C IF(NDLTAVG.GE.1)THEN - OPEN(1,FILE='LIGHT.OUT',POSITION='APPEND') + IF(MYRANK.EQ.0) OPEN(1,FILE='LIGHT.OUT',POSITION='APPEND') NDLTCNT=NDLTCNT+1 NSTPTMP=NDLTAVG*NTSPTC/2 RMULTMP=1./FLOAT(NSTPTMP) @@ -2415,11 +2429,13 @@ C RLIGHTC(L,K)=RMULTMP*RLIGHTC(L,K) ENDDO ENDDO + IF(MYRANK.EQ.0)THEN WRITE(1,1111)N,TIME DO L=2,LA WRITE(1,1113)IL(L),JL(L),(RLIGHTT(L,K),K=1,KC), & (RLIGHTC(L,K),K=1,KC) ENDDO + ENDIF DO K=1,KC DO L=2,LA RLIGHTT(L,K)=0. @@ -2427,7 +2443,7 @@ C ENDDO ENDDO ENDIF - CLOSE(1) + IF(MYRANK.EQ.0) CLOSE(1) ENDIF !{ GEOSR STOKES : YSSONG 2015.08.18 do nsp=1,NXSP @@ -2446,6 +2462,7 @@ C if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 IF(ISSTOKEX(1).EQ.1)THEN + IF(MYRANK.EQ.0)THEN do i=1,IWQTS WRITE(FLN,"('STOKE',I2.2,'.OUT')") i OPEN(1,FILE=trim(FLN),POSITION='APPEND') ! VERTICAL VELOCITY, ALGAL-DENSITY, SOLAR RADIATION, chl-a PRINT AT EACH LAYER @@ -2456,6 +2473,7 @@ C & ,(WQCHL(LWQTS(i),k),k=kc,1,-1) close(1) enddo + ENDIF ENDIF endif !if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 1114 FORMAT(F12.6,(E12.4)) diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE3_mpi.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE3_mpi.for new file mode 100644 index 000000000..f882467fc --- /dev/null +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE3_mpi.for @@ -0,0 +1,2611 @@ + SUBROUTINE WQSKE3_mpi +C +C: AFTER COMPUTING NEW VALUES, STORE WQVO+WQV INTO WQVO(L,K,NWQV) EXCEPT +C: NWQV=15,19,21. +C ORGINALLY CODED BY K.-Y. PARK +C OPTIMIZED AND MODIFIED BY J.M. HAMRICK +C +C PMC - THIS IS THE SAME AS WQSKE2 +C +C LAST MODIFIED BY YSSONG ON 24 NOVEMBER 2011 + + USE GLOBAL + USE MPI +!{GeoSR, GROWTH LIMIT AND ALGAL RATE PRINT, YSSONG, 2015.12.10 + CHARACTER*11 FLN + CHARACTER*80 FMTSTR +!} +C + REAL WQGNX(NXSP),WQGPX(NXSP),WQF1NX(NXSP) ! GEOSR X-species : jgcho 2015.09.24 + REAL WQISX(NXSP),WQFDX(NXSP),WQF2IX(NXSP) ! GEOSR X-species : jgcho 2015.09.25 + REAL WQTTX(NXSP) ! GEOSR X-species : jgcho 2015.09.25 + REAL WQACX(NXSP),WQKKX(LCMWQ,NXSP) !,WQRCX(NXSP) GEOSR X-species : jgcho 2015.10.01 + REAL WQA2X(NXSP),WQA3X(NXSP) ! GEOSR X-species : jgcho 2015.10.10 + !{ GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 + REAL WQFDGSC(2),WQFDGSCX + !} GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 + INTEGER LWQ3K + REAL WQVREA,WQTT1,WQTTT,WQF1NM,WQAVGIO,WQTTB,WQA1C + WQVREA=0.0 + WQTTT=0.0 + WQF1NM=0.0 + WQAVGIO=0.0 + WQTTB=0.0 + WQA1C=0.0 + WQTT1=0.0 + + CNS1=2.718 + NS=1 + IF(.FALSE.)THEN + IF(MYRANK.EQ.0) THEN + PRINT*, 'WQFDIA1 =',WQI0BOT(3184),WQI0 + ENDIF + ENDIF +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQI0BOT(L)=WQI0 + ENDDO + IF(.FALSE.)THEN + IF(MYRANK.EQ.0) THEN + PRINT*, 'WQFDIA2 =',WQI0BOT(3184),WQI0 + ENDIF + ENDIF + +!{ GEOSR STOKES : YSSONG 2015.08.18 + CYANOMASS=0.0 +!} GEOSR STOKES : YSSONG 2015.08.18 + +!{ GEOSR BENTHIC FLUX FOR ANOXIC ENV : YSSONG 2015.09.08 + IF(IWQBEN.EQ.0.AND.IWQBENOX.EQ.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQBFCOD(L)=WQBFOXCOD(1,1) + WQBFNH4(L)=WQBFOXNH4(1,1) + WQBFNO3(L)=WQBFOXNO3(1,1) + WQBFO2(L)= WQBFOXO2(1,1) + WQBFPO4D(L)=WQBFOXPO4D(1,1) + WQBFSAD(L)=WQBFOXSAD(1,1) + ENDDO + ELSEIF(IWQBEN.EQ.0.AND.IWQBENOX.NE.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(WQVO(L,1,19).GT.DOXCRT)THEN + WQBFCOD(L)=WQBFOXCOD(1,1) + WQBFNH4(L)=WQBFOXNH4(1,1) + WQBFNO3(L)=WQBFOXNO3(1,1) + WQBFO2(L)= WQBFOXO2(1,1) + WQBFPO4D(L)=WQBFOXPO4D(1,1) + WQBFSAD(L)=WQBFOXSAD(1,1) + ELSE + WQBFCOD(L)=WQBFOXCOD(1,2) + WQBFNH4(L)=WQBFOXNH4(1,2) + WQBFNO3(L)=WQBFOXNO3(1,2) + WQBFO2(L)= WQBFOXO2(1,2) + WQBFPO4D(L)=WQBFOXPO4D(1,2) + WQBFSAD(L)=WQBFOXSAD(1,2) + ENDIF + ENDDO + ENDIF + + IF(IWQBEN.EQ.2.AND.IWQBENOX.EQ.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQBFCOD(L)=WQBFOXCOD(L,1) + WQBFNH4(L)=WQBFOXNH4(L,1) + WQBFNO3(L)=WQBFOXNO3(L,1) + WQBFO2(L)= WQBFOXO2(L,1) + WQBFPO4D(L)=WQBFOXPO4D(L,1) + WQBFSAD(L)=WQBFOXSAD(L,1) + ENDDO + ELSEIF(IWQBEN.EQ.2.AND.IWQBENOX.NE.0)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IF(WQVO(L,1,19).GT.DOXCRT)THEN + WQBFCOD(L)=WQBFOXCOD(L,1) + WQBFNH4(L)=WQBFOXNH4(L,1) + WQBFNO3(L)=WQBFOXNO3(L,1) + WQBFO2(L)= WQBFOXO2(L,1) + WQBFPO4D(L)=WQBFOXPO4D(L,1) + WQBFSAD(L)=WQBFOXSAD(L,1) + ELSE + WQBFCOD(L)=WQBFOXCOD(L,2) + WQBFNH4(L)=WQBFOXNH4(L,2) + WQBFNO3(L)=WQBFOXNO3(L,2) + WQBFO2(L)= WQBFOXO2(L,2) + WQBFPO4D(L)=WQBFOXPO4D(L,2) + WQBFSAD(L)=WQBFOXSAD(L,2) + ENDIF + ENDDO + ENDIF +!} GEOSR BENTHIC FLUX FOR ANOXIC ENV : YSSONG 2015.09.08 + IF(.FALSE.)THEN + DO NSP=1,21; call collect_in_zero_array(WQV(:,:,NSP)); ENDDO !#1-1 + IF(MYRANK.EQ.0) THEN + DO LWQ3K=1,21 + PRINT*,'WQ1V=',LWQ3K,sum(abs(dble(WQV(:,:,LWQ3K)))) + ENDDO + PRINT*, 'WQFDIA =',WQI0BOT(3184) + ENDIF + ENDIF + + DO K=KC,1,-1 +C +C DZWQ=1/H, VOLWQ=1/VOL +C +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + TWQ(L)=TEM(L,K) + SWQ(L)=MAX(SAL(L,K), 0.0) + DZWQ(L) = 1.0 / (DZC(K)*HP(L)) + VOLWQ(L) = DZWQ(L) / DXYP(L) + IMWQZT(L)=IWQZMAP(L,K) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQBCSET(L,1) = WQWSC(IMWQZT(L))*DZWQ(L) + WQBDSET(L,1) = WQWSD(IMWQZT(L))*DZWQ(L) + WQBGSET(L,1) = WQWSG(IMWQZT(L))*DZWQ(L) + WQRPSET(L,1) = WQWSRP(IMWQZT(L))*DZWQ(L) + WQLPSET(L,1) = WQWSLP(IMWQZT(L))*DZWQ(L) +!{ GEOSR X-species : jgcho 2015.09.18 + DO nsp=1,NXSP + WQBXSET(L,1,nsp) = WQWSX(IMWQZT(L),nsp)*DZWQ(L) + ENDDO +!} GEOSR X-species : jgcho 2015.09.18 + ENDDO + IF(IWQSRP.EQ.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQWSSET(L,1) = WQWSS(IMWQZT(L))*DZWQ(L) + ENDDO + ENDIF + IF(K.NE.KC)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + IMWQZT1(L)=IWQZMAP(L,K+1) + ENDDO +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQBCSET(L,2) = WQWSC(IMWQZT1(L))*DZWQ(L) + WQBDSET(L,2) = WQWSD(IMWQZT1(L))*DZWQ(L) + WQBGSET(L,2) = WQWSG(IMWQZT1(L))*DZWQ(L) + WQRPSET(L,2) = WQWSRP(IMWQZT1(L))*DZWQ(L) + WQLPSET(L,2) = WQWSLP(IMWQZT1(L))*DZWQ(L) +!{ GEOSR X-species : jgcho 2015.09.18 + DO nsp=1,NXSP + WQBXSET(L,2,nsp) = WQWSX(IMWQZT1(L),nsp)*DZWQ(L) + ENDDO +!} GEOSR X-species : jgcho 2015.09.18 + ENDDO + IF(IWQSRP.EQ.1)THEN +!$OMP PARALLEL DO + DO L=LMPI2,LMPILA + WQWSSET(L,2) = WQWSS(IMWQZT1(L))*DZWQ(L) + ENDDO + ENDIF + ENDIF +C +C FIND AN INDEX FOR LOOK-UP TABLE FOR TEMPERATURE DEPENDENCY +C +!$OMP PARALLEL DO PRIVATE(TIMTMP) + DO L=LMPI2,LMPILA +C IWQT(L) = 2.0*TWQ(L) +11 +C - charles IWQT(L) = 10.0*TWQ(L) +151 +C IWQT(L) = NINT( 4.*TWQ(L)+121.) + IWQT(L)=NINT((TWQ(L)-WQTDMIN)/WQTDINC) ! *** DSLLC SINGLE LINE + IF(IWQT(L).LT.1 .OR. IWQT(L).GT.NWQTD)THEN + IF(ISDYNSTP.EQ.0)THEN + TIMTMP=DT*FLOAT(N)+TCON*TBEGIN + TIMTMP=TIMTMP/86400. + ELSE + TIMTMP=TIMESEC/86400. + ENDIF + IWQT(L)=MAX(IWQT(L),1) + IWQT(L)=MIN(IWQT(L),NWQTD) +C STOP 'ERROR!! INVALID WATER TEMPERATURE' + ENDIF + ENDDO +C 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) +C 911 FORMAT(/,'ERROR: TIME, L, I, J, K, TWQ(L) = ', F10.5, 4I4, F10.4) +C +C NOTE: MRM 04/29/99 ADDED ARRAYS TO KEEP TRACK OF +C NITROGEN, PHOSPHORUS, LIGHT, AND TEMPERATURE LIMITS +C FOR ALGAE GROWTH FOR CYANOBACTERIA, DIATOMS, GREENS, +C AND MACROALGAE. THESE ARE THE ARRAYS: +C XLIMNX(L,K) = NITROGEN LIMITATION FOR ALGAE GROUP X +C XLIMPX(L,K) = PHOSPHORUS LIMITATION FOR ALGAE GROUP X +C XLIMIX(L,K) = LIGHT LIMITATION FOR ALGAE GROUP X +C XLIMTX(L,K) = TEMPERATURE LIMITATION FOR ALGAE GROUP X +C BEGIN HORIZONTAL LOOP FOR ALGAE PARMETERS +C + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) + RNH4WQ(L) = MAX (WQVO(L,K,14), 0.0) + RNO3WQ(L) = MAX (WQVO(L,K,15), 0.0) + PO4DWQ(L) = MAX (WQPO4D(L,K), 0.0) + RNH4NO3(L) = RNH4WQ(L) + RNO3WQ(L) + WQGNC = RNH4NO3(L) / (WQKHNC+RNH4NO3(L)+ 1.E-18) + WQGND = RNH4NO3(L) / (WQKHND+RNH4NO3(L)+ 1.E-18) + WQGNG = RNH4NO3(L) / (WQKHNG+RNH4NO3(L)+ 1.E-18) + WQGPC = PO4DWQ(L) / (WQKHPC+PO4DWQ(L)+ 1.E-18) + WQGPD = PO4DWQ(L) / (WQKHPD+PO4DWQ(L)+ 1.E-18) + WQGPG = PO4DWQ(L) / (WQKHPG+PO4DWQ(L)+ 1.E-18) + XLIMNC(L,K) = XLIMNC(L,K) + WQGNC + XLIMND(L,K) = XLIMND(L,K) + WQGND + XLIMNG(L,K) = XLIMNG(L,K) + WQGNG + XLIMPC(L,K) = XLIMPC(L,K) + WQGPC + XLIMPD(L,K) = XLIMPD(L,K) + WQGPD + XLIMPG(L,K) = XLIMPG(L,K) + WQGPG + IF(IDNOTRVA.GT.0 .AND. K.EQ.1)THEN + WQGNM = RNH4NO3(L) / (WQKHNM+RNH4NO3(L) + 1.E-18) + WQGPM = PO4DWQ(L) / (WQKHPM+PO4DWQ(L) + 1.E-18) + WQF1NM = MIN(WQGNM, WQGPM) + XLIMNM(L,K) = XLIMNM(L,K) + WQGNM + XLIMPM(L,K) = XLIMPM(L,K) + WQGPM + ENDIF + WQF1NC = MIN(WQGNC, WQGPC) + IF(IWQSI.EQ.1)THEN + SADWQ = MAX (WQSAD(L,K), 0.0) + WQGSD = SADWQ / (WQKHS+SADWQ+ 1.E-18) + WQF1ND = MIN(WQGND, WQGPD, WQGSD) + ELSE + WQF1ND = MIN(WQGND, WQGPD) + ENDIF + WQF1NG = MIN(WQGNG, WQGPG) + IF(IDNOTRVA.GT.0)THEN + PO4DWQ(L) = MAX (WQPO4D(L,K), 0.0) + ENDIF +!{ GEOSR X-species : jgcho 2015.09.24 + do nsp=1,NXSP + WQGNX(nsp)=RNH4NO3(L) / (WQKHNX(nsp)+RNH4NO3(L)+ 1.E-18) + WQGPX(nsp)=PO4DWQ(L) / (WQKHPX(nsp)+PO4DWQ(L)+ 1.E-18) + XLIMNX(L,K,nsp) = XLIMNX(L,K,nsp) + WQGNX(nsp) + XLIMPX(L,K,nsp) = XLIMPX(L,K,nsp) + WQGPX(nsp) + if (IWQX(nsp).eq.1) then ! cyano + WQF1NX(nsp) = MIN(WQGNX(nsp), WQGPX(nsp)) + endif + WQF1NX(nsp) = MIN(WQGNC, WQGPC) + if (IWQSI.EQ.1 .and. IWQX(nsp).eq.2) then ! diatom + SADWQ = MAX (WQSAD(L,K), 0.0) + WQGSD = SADWQ / (WQKHSX(nsp)+SADWQ+ 1.E-18) + WQF1NX(nsp) = MIN(WQGNX(nsp), WQGPX(nsp),WQGSD) + else + WQF1NX(nsp) = MIN(WQGNX(nsp), WQGPX(nsp)) + endif + enddo +!} GEOSR X-species : jgcho 2015.09.24 +C +C IN C&C, F2IC=F2IC/FCYAN, FACTOR TO ALLOW CYANOBACTERIA MAT FORMATION +C + IF(SOLSWRT(L).GE.0.001)THEN + IF(USESHADE)THEN + WQI0 = PARADJ*2.065*SOLSWRT(L) + ENDIF + XMRM = WQKECHL*WQCHL(L,K) + IF(WQKECHL .LT. 0.0)THEN + XMRM = 0.054*WQCHL(L,K)**0.6667 + 0.0088*WQCHL(L,K) + ENDIF + WQKESS = WQKEB(IMWQZT(L))+WQKETSS*SEDT(L,K) + XMRM + WQKESS1 = WQKESS + IF(K.NE.KC)THEN + XMRM = WQKECHL*WQCHL(L,KC) + IF(WQKECHL .LT. 0.0)THEN + XMRM = 0.054*WQCHL(L,KC)**0.6667 + 0.0088*WQCHL(L,KC) + ENDIF + WQKESS1=WQKEB(IMWQZT(L))+WQKETSS*SEDT(L,KC) + XMRM + ENDIF +C +C COMPUTE SECCHI DEPTH FOR USE AS OUTPUT VARIABLE: +C + WQKETOT(L,K) = WQKESS + WQAVGIO = WQCIA*WQI0 + WQCIB*WQI1 + WQCIC*WQI2 + IF(IWQSUN .EQ. 2)THEN + WQAVGIO = WQCIA*WQI1 + WQCIB*WQI2 + WQCIC*WQI3 + ENDIF + WQISC = MAX( WQAVGIO*EXP(-WQKESS1*WQDOPC), WQISMIN ) + WQISD = MAX( WQAVGIO*EXP(-WQKESS1*WQDOPD), WQISMIN ) + WQISG = MAX( WQAVGIO*EXP(-WQKESS1*WQDOPG), WQISMIN ) + WQTT1 = (CNS1 * WQFD * DZWQ(L)) / WQKESS +C +C WQFDI0 = - WQI0 / (WQFD+ 1.E-18) +C + WQFDI0 = - WQI0BOT(L) / (WQFD + 1.E-18) + WQFDC = WQFDI0 / (WQISC + 1.E-18) + WQFDD = WQFDI0 / (WQISD + 1.E-18) + WQFDG = WQFDI0 / (WQISG + 1.E-18) + WQHTT = WQHT(K) * HP(L) + WQTTB = EXP( -WQKESS * (WQHTT+1.0/DZWQ(L)) ) + WQTTT = EXP( -WQKESS * WQHTT ) + WQF2IC = WQTT1 * (EXP(WQFDC*WQTTB) - EXP(WQFDC*WQTTT)) + WQF2ID = WQTT1 * (EXP(WQFDD*WQTTB) - EXP(WQFDD*WQTTT)) + WQF2IG = WQTT1 * (EXP(WQFDG*WQTTB) - EXP(WQFDG*WQTTT)) + !WQF2IC = WQF2IC * PSHADE(L) + !WQF2ID = WQF2ID * PSHADE(L) + !WQF2IG = WQF2IG * PSHADE(L) + XLIMIC(L,K) = XLIMIC(L,K) + WQF2IC + XLIMID(L,K) = XLIMID(L,K) + WQF2ID + XLIMIG(L,K) = XLIMIG(L,K) + WQF2IG +!{ GEOSR X-species : jgcho 2015.09.25 + do nsp=1,NXSP + WQISX(nsp) = MAX( WQAVGIO*EXP(-WQKESS1*WQDOPX(nsp)) + & , WQISMIN ) + WQFDX(nsp) = WQFDI0 / (WQISX(nsp) + 1.E-18) + WQF2IX(nsp) = WQTT1 * (EXP(WQFDX(nsp)*WQTTB) + & - EXP(WQFDX(nsp)*WQTTT)) + XLIMIX(L,K,nsp) = XLIMIX(L,K,nsp) + WQF2IX(nsp) + enddo +!} GEOSR X-species : jgcho 2015.09.25 + ELSE + WQF2IC=0.0 + WQF2ID=0.0 + WQF2IG=0.0 +!{ GEOSR X-species : jgcho 2015.09.25 + do nsp=1,NXSP + WQF2IX(nsp) = 0. + enddo +!} GEOSR X-species : jgcho 2015.09.25 + ENDIF +!{ GEOSR STOKES : YSSONG 2015.08.18 + !{ GEOSR STOKES X : jgcho 2015.10.13 + do nsp=1,NXSP + IF(ISSTOKEX(nsp).GE.1)THEN + CALL WQSTOKES01(WQKESS1,L,K,nsp) + ELSE + WQALSETX(L,KC,nsp) = WQBXSET(L,1,nsp) + IF(K.NE.KC) WQALSETX(L,K,nsp) = WQBXSET(L,2,nsp) + ENDIF + enddo + !} GEOSR STOKES X : jgcho 2015.10.13 +!} GEOSR STOKES : YSSONG 2015.08.18 +C +C UPDATE SOLAR RADIATION AT BOTTOM OF THIS LAYER +C + IF (WQKESS.LT.1.0E-12) WQKESS=0. + IF (WQKESS1.LT.1.0E-12) WQKESS1=0. + WQI0BOT(L)=WQI0BOT(L)*EXP(-WQKESS*(1.0/DZWQ(L))) + IF(IDNOTRVA.GT.0 .AND. K.EQ.1)THEN + WQFDI0 = - WQI0BOT(L) / (WQFD + 1.E-18) + WQISM = MAX( WQAVGIO*EXP(-WQKESS1*WQDOPM(IZ)), WQISMIN ) + WQFDM = WQFDI0 / (WQISM + 1.E-18) + WQF2IM = WQTT1 * (EXP(WQFDM*WQTTB) - EXP(WQFDM*WQTTT)) + !WQF2IM = WQF2IM * PSHADE(L) + UMRM = MAX(U(L,K), U(L+1,K)) + VMRM = MAX(V(L,K), V(LNC(L),K)) + WQVEL=SQRT(UMRM*UMRM + VMRM*VMRM) + WQLVF=1.0 +C +C OPTION 1 FOR VELOCITY LIMITATION ASSUMES MACROALGAE GROWTH +C IS LIMITED AT LOW VELOCITIES DUE TO REDUCED AVAILABILITY OF +C NUTRIENTS REACHING THE ALGAE BIOMASS. USES A MICHAELIS-MENTON +C TYPE OF EQUATION. +C + IF(IWQVLIM .EQ. 1)THEN + IF(WQVEL .GT. WQKMVMIN(L))THEN + WQLVF = WQVEL / (WQKMV(L) + WQVEL) + ELSE + WQLVF = WQKMVMIN(L) / (WQKMV(L) + WQKMVMIN(L)) + ENDIF + ENDIF +C +C OPTION 2 FOR VELOCITY LIMITATION APPLIES A FIVE-PARAMETER LOGISTIC +C FUNCTION THAT CAN BE ADJUSTED TO LIMIT MACROALGAE GROWTH FOR +C EITHER LOW OR HIGH (SCOUR) VELOCITIES. IN STREAMS WITH LOW NUTRIENTS, +C THE LOW VELOCITY WILL LIKELY BE LIMITING SINCE AMPLE NUTRIENTS MAY +C NOT REACH THE ALGAE BIOMASS DUE TO REDUCED FLOW. IN STREAMS WITH +C ABUNDANT NUTRIENTS, LOW VELOCITIES WILL NOT LIMIT MACROALGAE GROWTH, +C INSTEAD, HIGH VELOCITIES WILL LIKELY SCOUR THE MACROALGAE AND DETACH +C IT FROM THE SUBSTRATE. +C + IF(IWQVLIM .EQ.2)THEN + XNUMER = WQKMVA(L) - WQKMVD(L) + XDENOM = 1.0 + (WQVEL/WQKMVC(L))**WQKMVB(L) + WQLVF = WQKMVD(L) + ( XNUMER / (XDENOM**WQKMVE(L)) ) + ENDIF +C +C USE THE MORE SEVERELY LIMITING OF VELOCITY OR NUTRIENT FACTORS: +C + XMRM = MIN(WQLVF, WQF1NM) + WQF1NM = XMRM +C +C FIRST CONVERT FROM MACROALGAE FROM A CONCENTRATION (MG C/M3) +C TO A DENSITY (MG C/M2). +C + XMRM = WQVO(L,K,IDNOTRVA)*DZC(K)*HP(L) + WQLDF = WQKBP(L) / (WQKBP(L) + XMRM) + WQPM(L)= WQPMM(IMWQZT(L))*WQF1NM*WQF2IM*WQTDGM(IWQT(L))* + & WQLDF + XLIMVM(L,K) = XLIMVM(L,K) + WQLVF + XLIMDM(L,K) = XLIMDM(L,K) + WQLDF + XLIMIM(L,K) = XLIMIM(L,K) + WQF2IM + XLIMTM(L,K) = XLIMTM(L,K) + WQTDGM(IWQT(L)) + ENDIF + XLIMTC(L,K) = XLIMTC(L,K) + WQTDGC(IWQT(L)) + XLIMTD(L,K) = XLIMTD(L,K) + WQTDGD(IWQT(L)) + XLIMTG(L,K) = XLIMTG(L,K) + WQTDGG(IWQT(L)) +!{ GEOSR X-species : jgcho 2015.09.25 + do nsp=1,NXSP + XLIMTX(L,K,nsp) = XLIMTX(L,K,nsp) + WQTDGX(IWQT(L),nsp) + enddo +!} GEOSR X-species : jgcho 2015.09.25 +C +C: WQSTOX=WQSTOX**2 +C + IF(IWQSTOX.EQ.1)THEN + WQF4SC = WQSTOX / (WQSTOX + SWQ(L)*SWQ(L)+1.E-12) + WQPC(L)=WQPMC(IMWQZT(L))*WQF1NC*WQF2IC*WQTDGC(IWQT(L)) + & *WQF4SC + ELSE + WQPC(L) = WQPMC(IMWQZT(L))*WQF1NC*WQF2IC*WQTDGC(IWQT(L)) + ENDIF + !{ GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 +! WQPD(L) = WQPMD(IMWQZT(L))*WQF1ND*WQF2ID*WQTDGD(IWQT(L)) +! WQPG(L) = WQPMG(IMWQZT(L))*WQF1NG*WQF2IG*WQTDGG(IWQT(L)) + if (IWQDGSTOX.eq.1) then + tdiff=WQSALB(1)-WQSALA(1) + wctm1=( WQSALB(1) - SWQ(L) )/tdiff + wctm2=( SWQ(L) - WQSALA(1) )/tdiff + WQFDGSC(1)=wctm1*WQCOEFSA(1) + wctm2*WQCOEFSB(1) + if (WQFDGSC(1).lt.WQCOEFSA(1)) WQFDGSC(1)=WQCOEFSA(1) + if (WQFDGSC(1).gt.WQCOEFSB(1)) WQFDGSC(1)=WQCOEFSB(1) + + tdiff=WQSALB(2)-WQSALA(2) + wctm1=(WQSALB(2)-SWQ(L))/tdiff + wctm2=(SWQ(L)-WQSALA(2))/tdiff + WQFDGSC(2)=wctm1*WQCOEFSA(2) + wctm2*WQCOEFSB(2) + if (WQFDGSC(2).lt.WQCOEFSA(2)) WQFDGSC(2)=WQCOEFSA(2) + if (WQFDGSC(2).gt.WQCOEFSB(2)) WQFDGSC(2)=WQCOEFSB(2) + + WQPD(L) = WQPMD(IMWQZT(L))*WQF1ND*WQF2ID*WQTDGD(IWQT(L)) + & *WQFDGSC(1) + WQPG(L) = WQPMG(IMWQZT(L))*WQF1NG*WQF2IG*WQTDGG(IWQT(L)) + & *WQFDGSC(2) + else + WQPD(L) = WQPMD(IMWQZT(L))*WQF1ND*WQF2ID*WQTDGD(IWQT(L)) + WQPG(L) = WQPMG(IMWQZT(L))*WQF1NG*WQF2IG*WQTDGG(IWQT(L)) + endif + !} GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 +!{ GEOSR X-species : jgcho 2015.09.25 + do nsp=1,NXSP + IF(IWQSTOX.EQ.1 .and. IWQX(nsp).eq.1)THEN + WQF4SC = WQSTOXX(nsp) / (WQSTOXX(nsp) + & + SWQ(L)*SWQ(L)+1.E-12) + WQPX(L,nsp)=WQPMX(IMWQZT(L),nsp)*WQF1NX(nsp)*WQF2IX(nsp) + & *WQTDGX(IWQT(L),nsp)*WQF4SC + ENDIF +! WQPX(L,nsp) = WQPMX(IMWQZT(L),nsp)*WQF1NX(nsp)*WQF2IX(nsp) +! & *WQTDGX(IWQT(L),nsp) + !{ GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 + IF(IWQDGSTOX.eq.1 .and. IWQX(nsp).ge.2)THEN + tdiff=WQSALBX(nsp)-WQSALAX(nsp) + wctm1=(WQSALBX(nsp)-SWQ(L))/tdiff + wctm2=(SWQ(L)-WQSALAX(nsp))/tdiff + WQFDGSCX=wctm1*WQCOEFSAX(nsp) + wctm2*WQCOEFSBX(nsp) + if (WQFDGSCX.lt.WQCOEFSAX(nsp)) WQFDGSCX=WQCOEFSAX(nsp) + if (WQFDGSCX.gt.WQCOEFSBX(nsp)) WQFDGSCX=WQCOEFSBX(nsp) + + WQPX(L,nsp) = WQPMX(IMWQZT(L),nsp)*WQF1NX(nsp)*WQF2IX(nsp) + & *WQTDGX(IWQT(L),nsp)*WQFDGSCX + ELSE ! IF(IWQDGSTOX.eq.1)THEN + WQPX(L,nsp) = WQPMX(IMWQZT(L),nsp)*WQF1NX(nsp)*WQF2IX(nsp) + & *WQTDGX(IWQT(L),nsp) + ENDIF ! IF(IWQDGSTOX.eq.1)THEN + !} GeoSR Diatom, Green algae Salinity TOX : jgcho 2019.11.27 + enddo +!} GEOSR X-species : jgcho 2015.09.25 +C +C AT NIGHT, I.E., WHEN SOLAR RADIATION IS LESS THAN 0.001 (05/11/99 +C + IF(IWQSUN .EQ. 2)THEN + IF(WQI0 .LE. 0.001)THEN + WQPC(L) = 0.0 + WQPD(L) = 0.0 + WQPG(L) = 0.0 +!{ GEOSR X-species : jgcho 2015.09.25 + do nsp=1,NXSP + WQPX(L,nsp) = 0.0 + enddo +!} GEOSR X-species : jgcho 2015.09.25 + WQPM(L) = 0.0 + ENDIF + ENDIF +C +C ALGAL BASAL METABOLISM & PREDATION +C + WQBMC(L) = WQBMRC(IMWQZT(L)) * WQTDRC(IWQT(L)) + WQPRC(L) = WQPRRC(IMWQZT(L)) * WQTDRC(IWQT(L)) +C +C THE VARIABLE WQTDGP ADJUSTS PREDATION AND BASAL METABOLISM BASED ON A +C LOWER/UPPER OPTIMUM TEMPERATURE FUNCTION. THIS WILL ALLOW DIATOMS TO +C BLOOM IN WINTER IF WQTDGP IS CLOSE TO ZERO. +C + WQBMD(L)=WQBMRD(IMWQZT(L))*WQTDRD(IWQT(L))*WQTDGP(IWQT(L)) + WQPRD(L)=WQPRRD(IMWQZT(L))*WQTDRD(IWQT(L))*WQTDGP(IWQT(L)) + WQBMG(L) = WQBMRG(IMWQZT(L)) * WQTDRG(IWQT(L)) + WQPRG(L) = WQPRRG(IMWQZT(L)) * WQTDRG(IWQT(L)) + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQBMM(L) = WQBMRM(IMWQZT(L)) * WQTDRM(IWQT(L)) + WQPRM(L) = WQPRRM(IMWQZT(L)) * WQTDRM(IWQT(L)) + ENDIF +!{ GEOSR X-species : jgcho 2015.09.30 + do nsp=1,NXSP +! if (IWQX(nsp).eq.2) then + WQBMX(L,nsp) = WQBMRX(IMWQZT(L),nsp)*WQTDRX(IWQT(L),nsp) + & *WQTDGPX(IWQT(L),nsp) + WQPRX(L,nsp) = WQPRRX(IMWQZT(L),nsp)*WQTDRX(IWQT(L),nsp) + & *WQTDGPX(IWQT(L),nsp) +! endif +! WQBMX(L,nsp) = WQBMRX(IMWQZT(L),nsp) * WQTDRX(IWQT(L),nsp) +! WQPRX(L,nsp) = WQPRRX(IMWQZT(L),nsp) * WQTDRX(IWQT(L),nsp) + enddo +!} GEOSR X-species : jgcho 2015.09.30 + ENDDO +C +C END HORIZONTAL LOOP FOR ALGAE PARMETERS +C + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) + WQOBTOT(L) = WQVO(L,K,1)+WQVO(L,K,2)+WQVO(L,K,3) +!{ GEOSR X-species : jgcho 2015.09.30 + do nsp=1,NXSP + WQOBTOT(L) = WQOBTOT(L) + WQVOX(L,K,nsp) + enddo +!} GEOSR X-species : jgcho 2015.09.30 + WQKRPC(L) = (WQKRC + WQKRCALG*WQOBTOT(L)) * WQTDHDR(IWQT(L)) + WQKLPC(L) = (WQKLC + WQKLCALG*WQOBTOT(L)) * WQTDHDR(IWQT(L)) + XMRM = 0.0 + IF(IDNOTRVA.GT.0 .AND. K.EQ.1)THEN + XMRM = WQKDCALM(IZ) * WQVO(L,K,IDNOTRVA) + ENDIF +C +C M. MORTON 08/28/99: ADDED SPATIALLY VARIABLE DOC HYDROLYSIS RATE WQKDC +C TO ACHIEVE BETTER CONTROL IN SYSTEMS WITH A COMBINATION OF FRESHWAT +C STREAMS AND TIDAL RIVERS WITH DIFFERENT CHARACTERISTICS. +C + WQKDOC=(WQKDC(IZ)+WQKDCALG*WQOBTOT(L)+XMRM)*WQTDMNL(IWQT(L)) + O2WQ(L) = MAX(WQVO(L,K,19), 0.0) + WQTT1 = WQKDOC / (WQKHORDO + O2WQ(L)+ 1.E-18) + WQKHR(L) = WQTT1 * O2WQ(L) + WQDENIT(L)=WQTT1*WQAANOX*RNO3WQ(L)/(WQKHDNN+RNO3WQ(L)+1.E-18) + ENDDO +C +C 7-10 PHOSPHORUS +C +!{ GEOSR X-species : jgcho 2015.09.30 + WQKHP = 0. + do nsp=1,NXSP + WQKHP = WQKHP + WQKHPX(nsp) + enddo + WQKHP = (WQKHP+WQKHPC+WQKHPD+WQKHPG)/float(NXSP+3) +!} GEOSR X-species : jgcho 2015.09.30 + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) + WQAPC(L)=1.0/(WQCP1PRM+WQCP2PRM*EXP(-WQCP3PRM*PO4DWQ(L))) +! WQKHP = (WQKHPC+WQKHPD+WQKHPG) / 3.0 ! GEOSR X-species : jgcho 2015.09.30 + WQTT1 = WQKHP / (WQKHP+PO4DWQ(L)+ 1.E-18) * WQOBTOT(L) + WQKRPP(L) = (WQKRP + WQKRPALG*WQTT1) * WQTDHDR(IWQT(L)) + WQKLPP(L) = (WQKLP + WQKLPALG*WQTT1) * WQTDHDR(IWQT(L)) + WQKDOP(L) = (WQKDP + WQKDPALG*WQTT1) * WQTDMNL(IWQT(L)) + ENDDO + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) + IF(IWQSRP.EQ.1)THEN + WQTTM = WQKPO4P*WQTAMP(L,K) + WQH10(L) = - WQWSSET(L,1) * WQTTM / (1.0+WQTTM) + IF(K.NE.KC)THEN + WQTTM = WQKPO4P*WQTAMP(L,K+1) + WQT10(L) = WQWSSET(L,2) * WQTTM / (1.0+WQTTM) + ENDIF + ELSE IF(IWQSRP.EQ.2)THEN + WQTTS = WQKPO4P*SEDT(L,K) + WQH10(L) = - WSEDO(NS) * WQTTS * DZWQ(L) / (1.0+WQTTS) + IF(K.NE.KC)THEN + WQTTS = WQKPO4P*SEDT(L,K) + WQT10(L) = WSEDO(NS) * WQTTS * DZWQ(L) / (1.0+WQTTS) + ENDIF + ELSE + WQH10(L) = 0.0 + WQT10(L) = 0.0 + ENDIF + ENDDO +C +C 11-15 NITROGEN +C +!{ GEOSR X-species : jgcho 2015.09.30 + WQKHN = 0. + do nsp=1,NXSP + WQKHN = WQKHN + WQKHNX(nsp) + enddo + WQKHN = (WQKHN+WQKHNC+WQKHND+WQKHNG)/float(NXSP+3) +!} GEOSR X-species : jgcho 2015.09.30 + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +! WQKHN = (WQKHNC+WQKHND+WQKHNG) / 3.0 + WQTT1 = WQKHN / (WQKHN+RNH4NO3(L)+ 1.E-18) * WQOBTOT(L) + WQKRPN(L) = (WQKRN + WQKRNALG*WQTT1) * WQTDHDR(IWQT(L)) + WQKLPN(L) = (WQKLN + WQKLNALG*WQTT1) * WQTDHDR(IWQT(L)) + WQKDON(L) = (WQKDN + WQKDNALG*WQTT1) * WQTDMNL(IWQT(L)) + ENDDO + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) + IF(RNH4NO3(L).EQ.0.0)THEN + WQPNC(L)=0.0 + WQPND(L)=0.0 + WQPNG(L)=0.0 + WQPNM(L)=0.0 +!{ GEOSR X-species : jgcho 2015.09.30 + do nsp=1,NXSP + WQPNX(L,nsp)=0.0 + enddo +!} GEOSR X-species : jgcho 2015.09.30 + ELSE + WQTTC = RNH4WQ(L)/(WQKHNC+RNO3WQ(L)+ 1.E-18) + WQTTD = RNH4WQ(L)/(WQKHND+RNO3WQ(L)+ 1.E-18) + WQTTG = RNH4WQ(L)/(WQKHNG+RNO3WQ(L)+ 1.E-18) + WQTTM = RNH4WQ(L)/(WQKHNM+RNO3WQ(L)+ 1.E-18) + WQPNC(L) = (RNO3WQ(L)/(WQKHNC+RNH4WQ(L)+ 1.E-18) + & + WQKHNC/(RNH4NO3(L)+ 1.E-18)) * WQTTC + WQPND(L) = (RNO3WQ(L)/(WQKHND+RNH4WQ(L)+ 1.E-18) + & + WQKHND/(RNH4NO3(L)+ 1.E-18)) * WQTTD + WQPNG(L) = (RNO3WQ(L)/(WQKHNG+RNH4WQ(L)+ 1.E-18) + & + WQKHNG/(RNH4NO3(L)+ 1.E-18)) * WQTTG + WQPNM(L) = (RNO3WQ(L)/(WQKHNM+RNH4WQ(L)+ 1.E-18) + & + WQKHNM/(RNH4NO3(L)+ 1.E-18)) * WQTTM +!{ GEOSR X-species : jgcho 2015.09.30 + do nsp=1,NXSP + WQTTX(nsp) = RNH4WQ(L)/(WQKHNX(nsp)+RNO3WQ(L)+ 1.E-18) + WQPNX(L,nsp) = (RNO3WQ(L)/(WQKHNX(nsp)+RNH4WQ(L)+ 1.E-18) + & + WQKHNX(nsp)/(RNH4NO3(L)+ 1.E-18)) * WQTTX(nsp) + enddo +!} GEOSR X-species : jgcho 2015.09.30 + ENDIF + WQNIT(L) = O2WQ(L) * WQTDNIT(IWQT(L)) / + & ( (WQKHNDO+O2WQ(L)) * (WQKHNN+RNH4WQ(L)) + 1.E-18) + ENDDO + IF(IWQSI.EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) + IF(IWQSRP.EQ.1)THEN + WQTTM = WQKSAP*WQTAMP(L,K) + WQN17(L) = - WQWSSET(L,1) * WQTTM / (1.0+WQTTM) + IF(K.NE.KC)THEN + WQTTM = WQKSAP*WQTAMP(L,K+1) + WQT17(L) = WQWSSET(L,2) * WQTTM / (1.0+WQTTM) + ENDIF + ELSE IF(IWQSRP.EQ.2)THEN + WQTTS = WQKSAP*SEDT(L,K) + WQN17(L) = - WSEDO(NS) * WQTTS * DZWQ(L) / (1.0+WQTTS) + IF(K.NE.KC)THEN + WQTTS = WQKSAP*SEDT(L,K+1) + WQT17(L) = WSEDO(NS) * WQTTS * DZWQ(L) / (1.0+WQTTS) + ENDIF + ELSE + WQN17(L) = 0.0 + WQT17(L) = 0.0 + ENDIF + ENDDO + ENDIF +C +C 04/29/99 MRM: +C THE FOLLOWING ARRAYS WERE ADDED TO KEEP TRACK OF THE VARIOUS COMPONENT +C OF DISSOLVED OXYGEN. THE INSTANTANEOUS VALUES FOR EACH COMPONENT ARE +C SUMMED IN THE ARRAYS AND THEN DUMPED TO THE WQDOCOMP.BIN FILE AT THE +C SAME TIME INTERVAL AS FOR THE WQWCAVG.BIN FILES (I.E., IWQTSDT INTERVA +C USUALLY DAILY AVERAGES). THE ARRAY DESCRIPTIONS ARE: +C XDOSOD(L,K) = D.O. COMPONENT FOR SEDIMENT OXYGEN DEMAND +C XDOKAR(L,K) = D.O. COMPONENT FOR REAERATION +C XDODOC(L,K) = D.O. COMPONENT FOR DISS. ORG. CARBON DECAY +C XDONIT(L,K) = D.O. COMPONENT FOR AMMONIA NITRIFICATION +C XDOCOD(L,K) = D.O. COMPONENT FOR CHEM. OXY. DEMAND OXIDATION +C XDOPPB(L,K) = D.O. COMPONENT FOR PHOTOSYNTHESIS OF TOTAL CHLOROPHYLL +C XDORRB(L,K) = D.O. COMPONENT FOR RESPIRATION OF TOTAL CHLOROPHYLL +C XDOPPM(L,K) = D.O. COMPONENT FOR PHOTOSYNTHESIS OF MACROALGAE +C XDORRM(L,K) = D.O. COMPONENT FOR RESPIRATION OF MACROALGAE +C XDOALL(L,K) = SUM OF THE ABOVE 10 D.O. COMPONENTS +C NLIM = COUNTER FOR NUMBER OF ITEMS SUMMED IN EACH ARRAY SLOT +C + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) + WQO18(L)= -DTWQO2*WQKCOD(IWQT(L),IZ)*O2WQ(L) / + & (WQKHCOD(IZ) + O2WQ(L) + 1.E-18) +C +C TT THE FOLLOWING MODIFICATION TO THE D.O. SATURATION CALCULATION MADE +C TT BY J.M. HAMRICK / M.R. MORTON ON 03/08/97. SEE CHAPRA (1997) PG. 3 +C + TVAL1=1./(TWQ(L)+273.15) + TVAL2=TVAL1*TVAL1 + TVAL3=TVAL1*TVAL2 + TVAL4=TVAL2*TVAL2 + RLNSAT1=-139.3441+(1.575701E+5*TVAL1)-(6.642308E+7*TVAL2) + & +(1.2438E+10*TVAL3)-(8.621949E+11*TVAL4) + RLNSAT2=RLNSAT1-SWQ(L)*( 1.7674E-2-(1.0754E+1*TVAL1) + & +(2.1407E+3*TVAL2) ) + WQDOS(L) = EXP(RLNSAT2) + XDOSAT(L,K) = XDOSAT(L,K) + WQDOS(L)*DTWQ*DZC(K)*HP(L) + IF(K.EQ.KC)THEN +C +C IN THE FOLLOWING EQUATION, SALINITY MUST BE IN MG/L, HENCE, SWQ(L) +C IS MULTIPLIED BY 1000. +C WQDOS = 14.5532 - 0.38217*TVAL1 + 5.4258E-3*TVAL2 - +C DO NOT ALLOW WIND SPEEDS ABOVE 11 M/SEC IN THE FOLLOWING EQUATION: +C + WINDREA = WINDST(L) + WQWREA=0.728*SQRT(WINDREA)+(0.0372*WINDREA-0.317)*WINDREA +C +C WQWREA = 0.728*SQRT(WINDST(L)) +C + IF(IWQKA(IZ) .EQ. 0)THEN + WQVREA = WQKRO(IZ) + WQWREA = 0.0 + ENDIF +C +C WIND VELOCITY COMPUTED ABOVE: +C + IF(IWQKA(IZ) .EQ. 1)THEN + WQVREA = WQKRO(IZ) + ENDIF +C +C WQKRO = 3.933 TYPICALLY +C + IF(IWQKA(IZ) .EQ. 2)THEN + UMRM = 0.5*(U(L,K)+U(L+1,K)) + VMRM = 0.5*(V(L,K)+V(LNC(L),K)) + XMRM = SQRT(UMRM*UMRM + VMRM*VMRM) + WQVREA = WQKRO(IZ) * XMRM**0.5 / HP(L)**0.5 + ENDIF +C +C WQKRO = 5.32 TYPICALLY +C + IF(IWQKA(IZ) .EQ. 3)THEN + UMRM = MAX(U(L,K), U(L+1,K)) + VMRM = MAX(V(L,K), V(LNC(L),K)) + XMRM = SQRT(UMRM*UMRM + VMRM*VMRM) + WQVREA = WQKRO(IZ) * XMRM**0.67 / HP(L)**1.85 + ENDIF +C +C MODIFIED OWENS AND GIBBS REAERATION EQUATION: +C NOTE: NORMALIZED TO A DEPTH OF 1.0 FT, I.E., THIS EQUATION GIVES THE +C SAME REAERATION AS OWENS & GIBBS AT 1.0 FT DEPTH; AT HIGHER +C DEPTHS IT GIVES LARGER REAERATION THAN OWENS & GIBBS. +C WQKRO = 5.32 TYPICALLY +C + IF(IWQKA(IZ) .EQ. 4)THEN + UMRM = MAX(U(L,K), U(L+1,K)) + VMRM = MAX(V(L,K), V(LNC(L),K)) + XMRM = SQRT(UMRM*UMRM + VMRM*VMRM) + YMRM = HP(L)*3.0*(1.0 - HP(L)/(HP(L)+0.1524)) + WQVREA = WQKRO(IZ) * XMRM**0.67 / YMRM**1.85 + ENDIF +C +C NOW COMBINE REAERATION DUE TO WATER VELOCITY AND WIND STRESS: +C + WQVREA = WQVREA * REAC(IZ) + WQWREA = WQWREA * REAC(IZ) + WQP19(L)=-(WQVREA+WQWREA)*DZWQ(L)*WQTDKR(IWQT(L),IZ) + WQKRDOS(L) = - WQP19(L)*WQDOS(L) + ELSE + WQP19(L) = 0.0 + ENDIF + ENDDO + IF(IWQSRP.EQ.1)THEN + DO L=LMPI2,LMPILA + WQR20(L) = (WQWDSL(L,K,20)+WQWPSL(L,K,20))*VOLWQ(L) + & + (WQVO(L,K,20) - WQTAMP(L,K)) * WQWSSET(L,1) + IF(K.EQ.KC)THEN + WQR20(L) = WQR20(L) + WQATML(L,KC,20) * VOLWQ(L) + ENDIF + IF(K.EQ.1) WQR20(L) = WQR20(L) + & + WQTDTAM(IWQT(L))*DZWQ(L)/(WQKHBMF+O2WQ(L)+ 1.E-18) + IF(K.NE.KC) WQR20(L) = WQR20(L) + & + (WQVO(L,K+1,20) - WQTAMP(L,K+1)) * WQWSSET(L,2) + ENDDO + ENDIF +C +C TRAPEZOIDAL SOLUTION OF KINETIC EQS: AFTER COMPUTING NEW VALUES, STORE +C WQVO+WQV INTO WQVO(L,K,NWQV) +C + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + DO L=LMPI2,LMPILA + WQA1C=(WQPM(L)-WQBMM(L)-WQPRM(L)-WQWSM*DZWQ(L))*DTWQO2 + WQVA1C = 1.0 / (1.0 - WQA1C) + WQV(L,K,IDNOTRVA)=(WQVO(L,K,IDNOTRVA)+WQA1C*WQVO(L, + & K,IDNOTRVA))*WQVA1C*SMAC(L) + WQV(L,K,IDNOTRVA) = MAX(WQV(L,K,IDNOTRVA),WQMCMIN)*SMAC(L) + WQVO(L,K,IDNOTRVA) = WQVO(L,K,IDNOTRVA)+WQV(L,K,IDNOTRVA) + ENDDO + ENDIF +C **** PARAM 01 ! cyano bacteria + IF(ISTRWQ(1).EQ.1)THEN +!{ GeoSR Bentic-cyano : JHLEE 2015.10.12 + IF(ISCYANO.EQ.1.AND.K.EQ.1) THEN + CALL Sub_SPORE(TIMTMP) + ENDIF +!} GeoSR Bentic-cyano : JHLEE 2015.10.12 + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} +C +C DEFINITIONS GROWTH BASAL METAB PREDATION SETTLING TIME STEP +C +!{ GEOSR STOKES : YSSONG 2015.08.18 + IF(WQBCSET(L,1).GE.0.0)THEN + WQA1C=(WQPC(L)-WQBMC(L)-WQPRC(L)-WQBCSET(L,1))*DTWQO2 + ELSE + IF(K.NE.KC)THEN + WQA1C=(WQPC(L)-WQBMC(L)-WQPRC(L)+WQBCSET(L,1))*DTWQO2 + ENDIF + ENDIF +!} + WQKK(L) = 1.0 / (1.0 - WQA1C) + !{ GEOSR X-species STOKES : jgcho 2015.10.13 + do nsp=1,NXSP + if (IWQX(nsp).eq.1) then ! cyano + WQACX(nsp)=(WQPX(L,nsp)-WQBMX(L,nsp)-WQPRX(L,nsp)) + & *DTWQO2 ! GEOSR X-species : jgcho 2015.10.08 + IF(WQALSETX(L,K,nsp).GT.0.0)THEN !{ GEOSR STOKES : YSSONG 2015.08.18 !!!! SINK WQALSET(L,K,1) ! GEOSR X-species : jgcho 2015.10.08 + WQACX(nsp)=WQACX(nsp)-WQALSETX(L,K,nsp)*DTWQO2 ! GEOSR X-species : jgcho 2015.10.08 + ENDIF !{ GEOSR STOKES : YSSONG 2015.08.18 !!!! SINK + IF(WQALSETX(L,K,nsp).LT.0.0)THEN ! GEOSR X-species : jgcho 2015.10.08 + IF(K.NE.KC)THEN + WQACX(nsp)=WQACX(nsp)+WQALSETX(L,K,nsp)*DTWQO2 ! GEOSR X-species : jgcho 2015.10.08 + ENDIF + ENDIF + WQKKX(L,nsp) = 1.0 / (1.0 - WQACX(nsp)) + endif + enddo + !} GEOSR X-species STOKES : jgcho 2015.10.13 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR1C = (WQWDSL(L,K,1) + WQWPSL(L,K,1)) * VOLWQ(L) +!{ GEOSR X-species : jgcho 2015.10.01 +! GEOSR X-species : jgcho 2015.10. 5 not use WQWDSL, WQWPSL +!} GEOSR X-species : jgcho 2015.10.01 + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR1C = WQR1C + WQATML(L,KC,1) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,1) + DTWQ*WQR1C + WQA1C*WQVO(L,K,1) +!{ GEOSR X-species : jgcho 2015.10.05 + do nsp=1,NXSP + if (IWQX(nsp).eq.1) then ! cyano + WQRRX(L,nsp)=WQVOX(L,K,nsp) + WQACX(nsp)*WQVOX(L,K,nsp) +!{ GeoSR Bentic-cyano : JHLEE 2015.10.12 + IF(ISCYANO.EQ.1.AND.K.EQ.1)THEN + WQRRX(L,nsp) = WQRRX(L,nsp) + + & CYA_ADD(L)*DZWQ(L)*DTWQ + ENDIF +!} GeoSR Bentic-cyano : JHLEE 2015.10.12 + endif + enddo +!} GEOSR X-species : jgcho 2015.10.05 +!{ GEOSR STOKES : YSSONG 2015.08.18 + IF(K.NE.KC)THEN + IF(WQBCSET(L,1).GT.0.0)THEN + WQRR(L) = WQRR(L) + DTWQO2*WQBCSET(L,1)*WQVOCB(L,K+1) ! ORG + endif + do nsp=1,NXSP + IF(WQALSETX(L,K+1,nsp).GT.0.0)THEN !!! SOURCE from UPPER LAYER ! GEOSR X-species : jgcho 2015.10.08 + WQRRX(L,nsp) = WQRRX(L,nsp) + & + DTWQO2*WQALSETX(L,K+1,nsp)*WQVOXB(L,K+1,nsp) !WQVOCBX(L,K+1,nsp) ! GEOSR X-species : jgcho 2015.10.08 + ENDIF + enddo + ENDIF + IF(K.NE.1)THEN + IF(WQBCSET(L,1).LT.0.0)THEN + WQRR(L) = WQRR(L) - DTWQO2*WQBCSET(L,1)*WQVOCB(L,K-1) ! ORG + endif + do nsp=1,NXSP + IF(WQALSETX(L,K-1,nsp).LT.0.0)THEN !!! SOURCE from LOWER LAYER ! GEOSR X-species : jgcho 2015.10.08 + WQRRX(L,nsp) = WQRRX(L,nsp) + & - DTWQO2*WQALSETX(L,K-1,nsp)*WQVOXB(L,K-1,nsp) ! GEOSR X-species : jgcho 2015.10.08 + ENDIF + enddo + ENDIF +!} GEOSR STOKES : YSSONG 2015.08.18 +C ENDDO +!} +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C IF(K.NE.KC)THEN +C DO L=2,LA +C WQRR(L) = WQRR(L) + DTWQO2*WQBCSET(L,2)*WQVO(L,K+1,1) +C ENDDO +C ENDIF + +C DO L=2,LA +!} + WQV(L,K,1)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L))*WQVO(L,K,1) + WQVO(L,K,1) = WQVO(L,K,1)+WQV(L,K,1) + do nsp=1,NXSP + if (IWQX(nsp).eq.1) then + WQVX(L,K,nsp)=SCB(L)*(WQRRX(L,nsp)*WQKKX(L,nsp)) + & +(1.-SCB(L))*WQVOX(L,K,nsp) + WQVOX(L,K,nsp) = WQVOX(L,K,nsp)+WQVX(L,K,nsp) + endif + enddo +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,1)=WQVO(L,K,1) + WQVO(L,K,1) = WQVO(L,K,1)+WQV(L,K,1) + do nsp=1,NXSP + if (IWQX(nsp).eq.1) then + WQVX(L,K,nsp)=WQVOX(L,K,nsp) + WQVOX(L,K,nsp) = WQVOX(L,K,nsp)+WQVX(L,K,nsp) + endif + enddo + ENDIF + ENDDO +!} +C3301 format(i4,100e12.4) + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,1)=WQVO(L,K,1) + WQVO(L,K,1) = WQVO(L,K,1)+WQV(L,K,1) + do nsp=1,NXSP + if (IWQX(nsp).eq.1) then + WQVX(L,K,nsp)=WQVOX(L,K,nsp) + WQVOX(L,K,nsp) = WQVOX(L,K,nsp)+WQVX(L,K,nsp) + endif + enddo + ENDDO + ENDIF +!{GEOSR STOKES : YSSONG 2015.08.18 + IF(NXSP.EQ.1)THEN ! FOR MASS CONSERVE TEST + DO L=LMPI2,LMPILA + CYANOMASS=CYANOMASS+WQVOX(L,K,1)*DZC(K)*HP(L)*DXYP(L) + ENDDO + ENDIF +!} +C **** PARAM 02 + IF(ISTRWQ(2).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} +C +C DEFINITIONS GROWTH BASAL METAB PREDATION SETTLING TIME STEP +C + WQA2D=(WQPD(L)-WQBMD(L)-WQPRD(L)-WQBDSET(L,1))*DTWQO2 + WQKK(L) = 1.0 / (1.0 - WQA2D) +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.2) then + WQA2X(nsp)=(WQPX(L,nsp)-WQBMX(L,nsp) + & -WQPRX(L,nsp)-WQBXSET(L,1,nsp))*DTWQO2 + WQKKX(L,nsp) = 1.0 / (1.0 - WQA2X(nsp)) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.10 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR2D = (WQWDSL(L,K,2) + WQWPSL(L,K,2)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR2D = WQR2D + WQATML(L,KC,2) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,2) + DTWQ*WQR2D + WQA2D*WQVO(L,K,2) +!{ GEOSR X-species : jgcho 2015.10.13 + do nsp=1,NXSP + if (IWQX(nsp).eq.2) then + WQRRX(L,nsp)=WQVOX(L,K,nsp) + WQA2X(nsp)*WQVOX(L,K,nsp) + endif + enddo +!{ GEOSR X-species : jgcho 2015.10.13 +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(K.NE.KC)THEN + WQRR(L) = WQRR(L) + DTWQO2*WQBDSET(L,2)*WQVO(L,K+1,2) +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.2) then + WQRRX(L,nsp)=WQRRX(L,nsp) + DTWQO2*WQBXSET(L,2,nsp) + & *WQVOX(L,K+1,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.10 + ENDIF +C ENDDO +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C IF(K.NE.KC)THEN +C DO L=2,LA +C WQRR(L) = WQRR(L) + DTWQO2*WQBDSET(L,2)*WQVO(L,K+1,2) +C ENDDO +C ENDIF +C DO L=2,LA +!} + WQV(L,K,2)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,2) + WQVO(L,K,2) = WQVO(L,K,2)+WQV(L,K,2) +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.2) then + WQVX(L,K,nsp)=SCB(L)*(WQRRX(L,nsp)*WQKKX(L,nsp)) + & +(1.-SCB(L))*WQVOX(L,K,nsp) + WQVOX(L,K,nsp) = WQVOX(L,K,nsp)+WQVX(L,K,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.10 +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,2)=WQVO(L,K,2) + WQVO(L,K,2) = WQVO(L,K,2)+WQV(L,K,2) +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.2) then + WQVX(L,K,nsp)=WQVOX(L,K,nsp) + WQVOX(L,K,nsp) = WQVOX(L,K,nsp)+WQVX(L,K,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.10 + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,2)=WQVO(L,K,2) + WQVO(L,K,2) = WQVO(L,K,2)+WQV(L,K,2) +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.2) then + WQVX(L,K,nsp)=WQVOX(L,K,nsp) + WQVOX(L,K,nsp) = WQVOX(L,K,nsp)+WQVX(L,K,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.10 + ENDDO + ENDIF +C **** PARAM 03 + IF(ISTRWQ(3).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} +C +C DEFINITIONS GROWTH BASAL METAB PREDATION SETTLING TIME STEP +C + WQA3G=(WQPG(L)-WQBMG(L)-WQPRG(L)-WQBGSET(L,1))*DTWQO2 + WQKK(L) = 1.0 / (1.0 - WQA3G) +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.3) then + WQA3X(nsp)=(WQPX(L,nsp)-WQBMX(L,nsp) + & -WQPRX(L,nsp)-WQBXSET(L,1,nsp))*DTWQO2 + WQKKX(L,nsp) = 1.0 / (1.0 - WQA3X(nsp)) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.10 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR3G = (WQWDSL(L,K,3) + WQWPSL(L,K,3)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR3G = WQR3G + WQATML(L,KC,3) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,3) + DTWQ*WQR3G + WQA3G*WQVO(L,K,3) + !{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.3) then + WQRRX(L,nsp)=WQVOX(L,K,nsp) + WQA3X(nsp)*WQVOX(L,K,nsp) + endif + enddo + !} GEOSR X-species : jgcho 2015.10.10 +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(K.NE.KC)THEN + WQRR(L) = WQRR(L) + DTWQO2*WQBGSET(L,2)*WQVO(L,K+1,3) +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.3) then + WQRRX(L,nsp)=WQRRX(L,nsp) + DTWQO2*WQBXSET(L,2,nsp) + & *WQVOX(L,K+1,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.10 + ENDIF +C ENDDO +!} +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C IF(K.NE.KC)THEN +C DO L=2,LA +C WQRR(L) = WQRR(L) + DTWQO2*WQBGSET(L,2)*WQVO(L,K+1,3) +C ENDDO +C ENDIF + +C DO L=2,LA +!} + WQV(L,K,3)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,3) + WQVO(L,K,3) = WQVO(L,K,3)+WQV(L,K,3) +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.3) then + WQVX(L,K,nsp)=SCB(L)*(WQRRX(L,nsp)*WQKKX(L,nsp)) + & +(1.-SCB(L))*WQVOX(L,K,nsp) + WQVOX(L,K,nsp) = WQVOX(L,K,nsp)+WQVX(L,K,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.10 +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,3)=WQVO(L,K,3) + WQVO(L,K,3) = WQVO(L,K,3)+WQV(L,K,3) +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.3) then + WQVX(L,K,nsp)=WQVOX(L,K,nsp) + WQVOX(L,K,nsp) = WQVOX(L,K,nsp)+WQVX(L,K,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.10 + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,3)=WQVO(L,K,3) + WQVO(L,K,3) = WQVO(L,K,3)+WQV(L,K,3) +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + if (IWQX(nsp).eq.3) then + WQVX(L,K,nsp)=WQVOX(L,K,nsp) + WQVOX(L,K,nsp) = WQVOX(L,K,nsp)+WQVX(L,K,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.10 + ENDDO + ENDIF +C **** PARAM 04 + IF(ISTRWQ(4).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} +C +C DEFINITIONS HYDROLYSIS SETTLING +C + WQB4 = - (WQKRPC(L)+WQRPSET(L,1)) + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQB4) +C +C DEFINITIONS ALGAE PREDATION SOURCE OF RPOC +C + WQA4 = WQFCRP * (WQPRC(L)*WQVO(L,K,1) + & + WQPRD(L)*WQVO(L,K,2) + WQPRG(L)*WQVO(L,K,3)) + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA4 = WQA4+WQFCRPM*WQPRM(L)*WQVO(L,K,IDNOTRVA) + ENDIF +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + WQA4 = WQA4 + WQFCRP*(WQPRX(L,nsp)*WQVOX(L,K,nsp)) + enddo +!} GEOSR X-species : jgcho 2015.10.10 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR4 = (WQWDSL(L,K,4) + WQWPSL(L,K,4)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR4 = WQR4 + WQATML(L,KC,4) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,4) + DTWQ*WQR4 + DTWQO2*( WQA4 + & + WQB4*WQVO(L,K,4) ) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(K.NE.KC)THEN + WQRR(L) = WQRR(L) + DTWQO2*WQRPSET(L,2)*WQVO(L,K+1,4) + ENDIF +C ENDDO +!} +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C IF(K.NE.KC)THEN +C DO L=2,LA +C WQRR(L) = WQRR(L) + DTWQO2*WQRPSET(L,2)*WQVO(L,K+1,4) +C ENDDO +C ENDIF + +C DO L=2,LA +!} + WQV(L,K,4)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,4) + WQVO(L,K,4) = WQVO(L,K,4)+WQV(L,K,4) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,4)=WQVO(L,K,4) + WQVO(L,K,4) = WQVO(L,K,4)+WQV(L,K,4) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,4)=WQVO(L,K,4) + WQVO(L,K,4) = WQVO(L,K,4)+WQV(L,K,4) + ENDDO + ENDIF +C **** PARAM 05 + IF(ISTRWQ(5).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQC5 = - (WQKLPC(L)+WQLPSET(L,1)) + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQC5) + WQA5 = WQFCLP * (WQPRC(L)*WQVO(L,K,1) + & + WQPRD(L)*WQVO(L,K,2) + WQPRG(L)*WQVO(L,K,3)) + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA5 =WQA5 + WQFCLPM * WQPRM(L)*WQVO(L,K,IDNOTRVA) + ENDIF +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + WQA5 = WQA5 + WQFCLP*(WQPRX(L,nsp)*WQVOX(L,K,nsp)) + enddo +!} GEOSR X-species : jgcho 2015.10.10 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR5 = (WQWDSL(L,K,5) + WQWPSL(L,K,5)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR5 = WQR5 + WQATML(L,KC,5) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,5) + DTWQ*WQR5 + DTWQO2*( WQA5 + & + WQC5*WQVO(L,K,5) ) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(K.NE.KC)THEN + WQRR(L) = WQRR(L) + DTWQO2*WQLPSET(L,2)*WQVO(L,K+1,5) + ENDIF +C ENDDO +!} +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C IF(K.NE.KC)THEN +C DO L=2,LA +C WQRR(L) = WQRR(L) + DTWQO2*WQLPSET(L,2)*WQVO(L,K+1,5) +C ENDDO +C ENDIF + +C DO L=2,LA +!} + WQV(L,K,5)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,5) + WQVO(L,K,5) = WQVO(L,K,5)+WQV(L,K,5) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,5)=WQVO(L,K,5) + WQVO(L,K,5) = WQVO(L,K,5)+WQV(L,K,5) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,5)=WQVO(L,K,5) + WQVO(L,K,5) = WQVO(L,K,5)+WQV(L,K,5) + ENDDO + ENDIF +C **** PARAM 06 + IF(ISTRWQ(6).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQD6 = - (WQKHR(L)+WQDENIT(L)) + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQD6) + O2WQ(L) = MAX(WQVO(L,K,19), 0.0) + WQA6C=(WQFCDC+CFCDCWQ*WQKHRC/(WQKHRC+O2WQ(L)+1.E-18)) + & *WQBMC(L) + WQA6D=(WQFCDD+CFCDDWQ*WQKHRD/(WQKHRD+O2WQ(L)+1.E-18)) + & *WQBMD(L) + WQA6G=(WQFCDG+CFCDGWQ*WQKHRG/(WQKHRG+O2WQ(L)+1.E-18)) + & *WQBMG(L) + WQA6 = ( WQA6C + WQFCDP*WQPRC(L) )*WQVO(L,K,1) + & + ( WQA6D + WQFCDP*WQPRD(L) )*WQVO(L,K,2) + & + ( WQA6G + WQFCDP*WQPRG(L) )*WQVO(L,K,3) + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA6M=(WQFCDM+(1-WQFCDM)*WQKHRM(IZ) / + & (WQKHRM(IZ) + O2WQ(L) + 1.E-18))*WQBMM(L) + WQA6 =WQA6+ (WQA6M+ WQFCDPM*WQPRM(L))*WQVO(L,K,IDNOTRVA) + ENDIF +!{ GEOSR X-species : jgcho 2015.10.10 + do nsp=1,NXSP + WQA6X=(WQFCDX(nsp)+CFCDWQX(nsp)*WQKHRX(nsp) + & /(WQKHRX(nsp)+O2WQ(L)+1.E-18))*WQBMX(L,nsp) + WQA6 = WQA6 + & + (WQA6X + WQFCDP*WQPRX(L,nsp))*WQVOX(L,K,nsp) + enddo +!} GEOSR X-species : jgcho 2015.10.10 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR6 = (WQWDSL(L,K,6) + WQWPSL(L,K,6)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR6 = WQR6 + WQATML(L,KC,6) * VOLWQ(L) + ENDIF + WQRR(L)=WQVO(L,K,6)+DTWQ*WQR6+DTWQO2*(WQA6+WQKRPC(L)* + & WQVO(L,K,4) + WQKLPC(L)*WQVO(L,K,5) + WQD6*WQVO(L,K,6) ) + WQV(L,K,6)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,6) + WQVO(L,K,6) = WQVO(L,K,6)+WQV(L,K,6) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,6)=WQVO(L,K,6) + WQVO(L,K,6) = WQVO(L,K,6)+WQV(L,K,6) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,6)=WQVO(L,K,6) + WQVO(L,K,6) = WQVO(L,K,6)+WQV(L,K,6) + ENDDO + ENDIF +C **** PARAM 07 + IF(ISTRWQ(7).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQE7 = - (WQKRPP(L)+WQRPSET(L,1)) + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQE7) + WQA7C = (WQFPRC*WQBMC(L) + WQFPRP*WQPRC(L)) * WQVO(L,K,1) + WQA7D = (WQFPRD*WQBMD(L) + WQFPRP*WQPRD(L)) * WQVO(L,K,2) + WQA7G = (WQFPRG*WQBMG(L) + WQFPRP*WQPRG(L)) * WQVO(L,K,3) + WQA7 = (WQA7C+WQA7D+WQA7G) * WQAPC(L) + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA7 = WQA7 + (WQFPRM*WQBMM(L) + WQFPRPM*WQPRM(L)) + & * WQVO(L,K,IDNOTRVA)* WQAPC(L)*WQAPCM + ENDIF +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + WQA7X = (WQFPRX(nsp)*WQBMX(L,nsp) + WQFPRP*WQPRX(L,nsp)) + & * WQVOX(L,K,nsp) + WQA7 = WQA7 + WQA7X*WQAPC(L) + enddo +!} GEOSR X-species : jgcho 2015.10.12 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR7 = (WQWDSL(L,K,7) + WQWPSL(L,K,7)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR7 = WQR7 + WQATML(L,KC,7) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,7) + DTWQ*WQR7 + DTWQO2*( WQA7 + & + WQE7*WQVO(L,K,7) ) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(K.NE.KC)THEN + WQRR(L) = WQRR(L) + DTWQO2*WQRPSET(L,2)*WQVO(L,K+1,7) + ENDIF +C ENDDO +!} +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C IF(K.NE.KC)THEN +C DO L=2,LA +C WQRR(L) = WQRR(L) + DTWQO2*WQRPSET(L,2)*WQVO(L,K+1,7) +C ENDDO +C ENDIF + +C DO L=2,LA +!} + WQV(L,K,7)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,7) + WQVO(L,K,7) = WQVO(L,K,7)+WQV(L,K,7) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,7)=WQVO(L,K,7) + WQVO(L,K,7) = WQVO(L,K,7)+WQV(L,K,7) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,7)=WQVO(L,K,7) + WQVO(L,K,7) = WQVO(L,K,7)+WQV(L,K,7) + ENDDO + ENDIF +C **** PARAM 08 + IF(ISTRWQ(8).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQF8 = - (WQKLPP(L)+WQLPSET(L,1)) + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQF8) + WQA8C = (WQFPLC*WQBMC(L) + WQFPLP*WQPRC(L)) * WQVO(L,K,1) + WQA8D = (WQFPLD*WQBMD(L) + WQFPLP*WQPRD(L)) * WQVO(L,K,2) + WQA8G = (WQFPLG*WQBMG(L) + WQFPLP*WQPRG(L)) * WQVO(L,K,3) + WQA8 = (WQA8C+WQA8D+WQA8G) * WQAPC(L) + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA8 = WQA8 + (WQFPLM*WQBMM(L) + WQFPLPM*WQPRM(L)) + & * WQVO(L,K,IDNOTRVA)* WQAPC(L)*WQAPCM + ENDIF +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + WQA8X = (WQFPLX(nsp)*WQBMX(L,nsp) + WQFPLP*WQPRX(L,nsp)) + & * WQVOX(L,K,nsp) + WQA8 = WQA8 + WQA8X*WQAPC(L) + enddo +!} GEOSR X-species : jgcho 2015.10.12 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR8 = (WQWDSL(L,K,8) + WQWPSL(L,K,8)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR8 = WQR8 + WQATML(L,KC,8) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,8) + DTWQ*WQR8 + DTWQO2*( WQA8 + & + WQF8*WQVO(L,K,8) ) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(K.NE.KC)THEN + WQRR(L) = WQRR(L) + DTWQO2*WQLPSET(L,2)*WQVO(L,K+1,8) + ENDIF +C ENDDO +!} +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C IF(K.NE.KC)THEN +C DO L=2,LA +C WQRR(L) = WQRR(L) + DTWQO2*WQLPSET(L,2)*WQVO(L,K+1,8) +C ENDDO +C ENDIF + +C DO L=2,LA +!} + WQV(L,K,8)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,8) + WQVO(L,K,8) = WQVO(L,K,8)+WQV(L,K,8) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,8)=WQVO(L,K,8) + WQVO(L,K,8) = WQVO(L,K,8)+WQV(L,K,8) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,8)=WQVO(L,K,8) + WQVO(L,K,8) = WQVO(L,K,8)+WQV(L,K,8) + ENDDO + ENDIF +C **** PARAM 09 + IF(ISTRWQ(9).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQKK(L) = 1.0 / (1.0 + DTWQO2*WQKDOP(L)) + WQA9C = (WQFPDC*WQBMC(L) + WQFPDP*WQPRC(L)) * WQVO(L,K,1) + WQA9D = (WQFPDD*WQBMD(L) + WQFPDP*WQPRD(L)) * WQVO(L,K,2) + WQA9G = (WQFPDG*WQBMG(L) + WQFPDP*WQPRG(L)) * WQVO(L,K,3) + WQA9 = (WQA9C+WQA9D+WQA9G) * WQAPC(L) + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA9 = WQA9 + (WQFPDM*WQBMM(L) + WQFPDPM*WQPRM(L)) + & * WQVO(L,K,IDNOTRVA) * WQAPC(L)*WQAPCM + ENDIF +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + WQA9X = (WQFPDX(nsp)*WQBMX(L,nsp) + WQFPDP*WQPRX(L,nsp)) + & * WQVOX(L,K,nsp) + WQA9 = WQA9 + WQA9X*WQAPC(L) + enddo +!} GEOSR X-species : jgcho 2015.10.12 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR9 = (WQWDSL(L,K,9) + WQWPSL(L,K,9)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR9 = WQR9 + WQATML(L,KC,9) * VOLWQ(L) + ENDIF + WQRR(L)=WQVO(L,K,9)+DTWQ*WQR9+DTWQO2*(WQA9+WQKRPP(L)* + & WQVO(L,K,7)+WQKLPP(L)*WQVO(L,K,8)-WQKDOP(L)*WQVO(L,K,9)) + WQV(L,K,9)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,9) + WQVO(L,K,9) = WQVO(L,K,9)+WQV(L,K,9) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,9)=WQVO(L,K,9) + WQVO(L,K,9) = WQVO(L,K,9)+WQV(L,K,9) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,9)=WQVO(L,K,9) + WQVO(L,K,9) = WQVO(L,K,9)+WQV(L,K,9) + ENDDO + ENDIF +C **** PARAM 10 + IF(ISTRWQ(10).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQA10C=(WQFPIC*WQBMC(L)+WQFPIP*WQPRC(L)-WQPC(L)) + & *WQVO(L,K,1) + WQA10D=(WQFPID*WQBMD(L)+WQFPIP*WQPRD(L)-WQPD(L)) + & *WQVO(L,K,2) + WQA10G=(WQFPIG*WQBMG(L)+WQFPIP*WQPRG(L)-WQPG(L)) + & *WQVO(L,K,3) + WQKK(L) = (WQA10C+WQA10D+WQA10G) * WQAPC(L) + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQKK(L) =WQKK(L)+(WQFPIM*WQBMM(L)+WQFPIP*WQPRM(L) + & -WQPM(L))*WQVO(L,K,IDNOTRVA) * WQAPC(L)*WQAPCM + ENDIF +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + WQA10X=(WQFPIX(nsp)*WQBMX(L,nsp)+WQFPIP*WQPRX(L,nsp) + & -WQPX(L,nsp))*WQVOX(L,K,nsp) + WQKK(L) = WQKK(L) + WQA10X*WQAPC(L) + enddo +!} GEOSR X-species : jgcho 2015.10.12 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQRR(L) = (WQWDSL(L,K,10)+WQWPSL(L,K,10)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQRR(L) = WQRR(L) + WQATML(L,KC,10) * VOLWQ(L) + ENDIF +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C ENDDO +!} + IF(K.EQ.1)THEN +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C DO L=2,LA + WQRR(L) = WQRR(L) + WQBFPO4D(L)*DZWQ(L) +C ENDDO + ENDIF +C DO L=2,LA +!} + WQRR(L) = WQVO(L,K,10) + DTWQ*WQRR(L) + DTWQO2*( WQKK(L) + & + WQKDOP(L)*WQVO(L,K,9) + WQH10(L)*WQVO(L,K,10) ) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(K.NE.KC)THEN + WQRR(L) = WQRR(L) + DTWQO2*WQT10(L)*WQVO(L,K+1,10) + ENDIF +C ENDDO +!} +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C IF(K.NE.KC)THEN +C DO L=2,LA +C WQRR(L) = WQRR(L) + DTWQO2*WQT10(L)*WQVO(L,K+1,10) +C ENDDO +C ENDIF + +C DO L=2,LA +!} + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQH10(L)) + WQV(L,K,10)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,10) + WQVO(L,K,10) = WQVO(L,K,10)+WQV(L,K,10) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,10)=WQVO(L,K,10) + WQVO(L,K,10) = WQVO(L,K,10)+WQV(L,K,10) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,10)=WQVO(L,K,10) + WQVO(L,K,10) = WQVO(L,K,10)+WQV(L,K,10) + ENDDO + ENDIF +C **** PARAM 11 + IF(ISTRWQ(11).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQI11 = - (WQKRPN(L)+WQRPSET(L,1)) + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQI11) + WQA11C=(WQFNRC*WQBMC(L)+WQFNRP*WQPRC(L)) + & *WQANCC*WQVO(L,K,1) + WQA11D=(WQFNRD*WQBMD(L)+WQFNRP*WQPRD(L)) + & *WQANCD*WQVO(L,K,2) + WQA11G=(WQFNRG*WQBMG(L)+WQFNRP*WQPRG(L)) + & *WQANCG*WQVO(L,K,3) + WQA11 = WQA11C+WQA11D+WQA11G + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA11 =WQA11 + (WQFNRM*WQBMM(L)+WQFNRPM*WQPRM(L)) + & *WQANCM*WQVO(L,K,IDNOTRVA) + ENDIF +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + WQA11X=(WQFNRX(nsp)*WQBMX(L,nsp)+WQFNRP*WQPRX(L,nsp)) + & *WQANCX(nsp)*WQVOX(L,K,nsp) + WQA11 = WQA11+WQA11X + enddo +!} GEOSR X-species : jgcho 2015.10.12 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR11 = (WQWDSL(L,K,11)+WQWPSL(L,K,11)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR11 = WQR11 + WQATML(L,KC,11) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,11) + DTWQ*WQR11 + DTWQO2*( WQA11 + & + WQI11*WQVO(L,K,11) ) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(K.NE.KC)THEN + WQRR(L) = WQRR(L) + DTWQO2*WQRPSET(L,2)*WQVO(L,K+1,11) + ENDIF +C ENDDO +!} +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C IF(K.NE.KC)THEN +C DO L=2,LA +C WQRR(L) = WQRR(L) + DTWQO2*WQRPSET(L,2)*WQVO(L,K+1,11) +C ENDDO +C ENDIF + +C DO L=2,LA +!} + WQV(L,K,11)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,11) + WQVO(L,K,11) = WQVO(L,K,11)+WQV(L,K,11) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,11)=WQVO(L,K,11) + WQVO(L,K,11) = WQVO(L,K,11)+WQV(L,K,11) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,11)=WQVO(L,K,11) + WQVO(L,K,11) = WQVO(L,K,11)+WQV(L,K,11) + ENDDO + ENDIF +C **** PARAM 12 + IF(ISTRWQ(12).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQJ12 = - (WQKLPN(L)+WQLPSET(L,1)) + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQJ12) + WQA12C=(WQFNLC*WQBMC(L)+WQFNLP*WQPRC(L))*WQANCC + & *WQVO(L,K,1) + WQA12D=(WQFNLD*WQBMD(L)+WQFNLP*WQPRD(L))*WQANCD + & *WQVO(L,K,2) + WQA12G=(WQFNLG*WQBMG(L)+WQFNLP*WQPRG(L))*WQANCG + & *WQVO(L,K,3) + WQA12 = WQA12C+WQA12D+WQA12G + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA12 =WQA12 +(WQFNLM*WQBMM(L)+WQFNLPM*WQPRM(L)) + & *WQANCM*WQVO(L,K,IDNOTRVA) + ENDIF +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + WQA12X=(WQFNLX(nsp)*WQBMX(L,nsp)+WQFNLP*WQPRX(L,nsp)) + & *WQANCX(nsp)*WQVOX(L,K,nsp) + WQA12 = WQA12+WQA12X + enddo +!} GEOSR X-species : jgcho 2015.10.12 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR12 = (WQWDSL(L,K,12)+WQWPSL(L,K,12)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR12 = WQR12 + WQATML(L,KC,12) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,12) + DTWQ*WQR12 + DTWQO2*( WQA12 + & + WQJ12*WQVO(L,K,12) ) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(K.NE.KC)THEN + WQRR(L) = WQRR(L) + DTWQO2*WQLPSET(L,2)*WQVO(L,K+1,12) + ENDIF +C ENDDO +!} +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C IF(K.NE.KC)THEN +C DO L=2,LA +C WQRR(L) = WQRR(L) + DTWQO2*WQLPSET(L,2)*WQVO(L,K+1,12) +C ENDDO +C ENDIF + +C DO L=2,LA +!} + WQV(L,K,12)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L))*WQVO(L,K,12) + WQVO(L,K,12) = WQVO(L,K,12)+WQV(L,K,12) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,12)=WQVO(L,K,12) + WQVO(L,K,12) = WQVO(L,K,12)+WQV(L,K,12) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,12)=WQVO(L,K,12) + WQVO(L,K,12) = WQVO(L,K,12)+WQV(L,K,12) + ENDDO + ENDIF +C **** PARAM 13 + IF(ISTRWQ(13).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQKK(L) = 1.0 / (1.0 + DTWQO2*WQKDON(L)) + WQA13C=(WQFNDC*WQBMC(L)+WQFNDP*WQPRC(L))*WQANCC + & *WQVO(L,K,1) + WQA13D=(WQFNDD*WQBMD(L)+WQFNDP*WQPRD(L))*WQANCD + & *WQVO(L,K,2) + WQA13G=(WQFNDG*WQBMG(L)+WQFNDP*WQPRG(L))*WQANCG + & *WQVO(L,K,3) + WQA13 = WQA13C+WQA13D+WQA13G + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA13 =WQA13 + (WQFNDM*WQBMM(L)+WQFNDPM*WQPRM(L)) + & *WQANCM*WQVO(L,K,IDNOTRVA) + ENDIF +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + WQA13X=(WQFNDX(nsp)*WQBMX(L,nsp)+WQFNDP*WQPRX(L,nsp)) + & *WQANCX(nsp)*WQVOX(L,K,nsp) + WQA13 = WQA13+WQA13X + enddo +!} GEOSR X-species : jgcho 2015.10.12 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR13 = (WQWDSL(L,K,13) + WQWPSL(L,K,13)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR13 = WQR13 + WQATML(L,KC,13) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,13) + DTWQ*WQR13 + DTWQO2*( WQA13 + & + WQKRPN(L)*WQVO(L,K,11) + WQKLPN(L)*WQVO(L,K,12) + & - WQKDON(L)*WQVO(L,K,13) ) + WQV(L,K,13)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,13) + WQVO(L,K,13) = WQVO(L,K,13)+WQV(L,K,13) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,13)=WQVO(L,K,13) + WQVO(L,K,13) = WQVO(L,K,13)+WQV(L,K,13) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,13)=WQVO(L,K,13) + WQVO(L,K,13) = WQVO(L,K,13)+WQV(L,K,13) + ENDDO + ENDIF +C **** PARAM 14 + IF(ISTRWQ(14).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQRR(L) = (WQWDSL(L,K,14)+WQWPSL(L,K,14)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQRR(L) = WQRR(L) + WQATML(L,KC,14) * VOLWQ(L) + ENDIF +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C ENDDO +!} + IF(K.EQ.1)THEN +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C DO L=2,LA + WQRR(L) = WQRR(L) + WQBFNH4(L)*DZWQ(L) +C ENDDO +!} + ENDIF +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C DO L=2,LA + WQKK(L) = 1.0 / (1.0 + DTWQO2*WQNIT(L)) + WQA14C=WQFNIC*WQBMC(L)+WQFNIP*WQPRC(L)-WQPNC(L)*WQPC(L) + WQA14D=WQFNID*WQBMD(L)+WQFNIP*WQPRD(L)-WQPND(L)*WQPD(L) + WQA14G=WQFNIG*WQBMG(L)+WQFNIP*WQPRG(L)-WQPNG(L)*WQPG(L) + WQA14 = WQA14C*WQANCC*WQVO(L,K,1) + & + WQA14D*WQANCD*WQVO(L,K,2) + WQA14G*WQANCG*WQVO(L,K,3) + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA14 = WQA14 + (WQFNIM*WQBMM(L)+WQFNIPM*WQPRM(L) + & - WQPNM(L)*WQPM(L))*WQANCM*WQVO(L,K,IDNOTRVA) + ENDIF +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + WQA14X=WQFNIX(nsp)*WQBMX(L,nsp)+WQFNIP*WQPRX(L,nsp) + & -WQPNX(L,nsp)*WQPX(L,nsp) + WQA14 = WQA14 + WQA14X*WQANCX(nsp)*WQVOX(L,K,nsp) + enddo +!} GEOSR X-species : jgcho 2015.10.12 + WQRR(L) = WQVO(L,K,14) + DTWQ*WQRR(L) + DTWQO2*( WQA14 + & + WQKDON(L)*WQVO(L,K,13) - WQNIT(L)*WQVO(L,K,14) ) + WQV(L,K,14)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,14) + WQVO(L,K,14) = WQVO(L,K,14)+WQV(L,K,14) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,14)=WQVO(L,K,14) + WQVO(L,K,14) = WQVO(L,K,14)+WQV(L,K,14) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,14)=WQVO(L,K,14) + WQVO(L,K,14) = WQVO(L,K,14)+WQV(L,K,14) + ENDDO + ENDIF +C **** PARAM 15 + IF(ISTRWQ(15).EQ.1)THEN + DO L=LMPI2,LMPILA + IZ=IWQZMAP(L,K) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQRR(L) = (WQWDSL(L,K,15)+WQWPSL(L,K,15)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQRR(L) = WQRR(L) + WQATML(L,KC,15) * VOLWQ(L) + ENDIF +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C ENDDO + IF(K.EQ.1)THEN +C DO L=2,LA + WQRR(L) = WQRR(L) + WQBFNO3(L)*DZWQ(L) +C ENDDO + ENDIF +C DO L=2,LA +!} + WQA15C = (WQPNC(L)-1.0)*WQPC(L) * WQANCC * WQVO(L,K,1) + WQA15D = (WQPND(L)-1.0)*WQPD(L) * WQANCD * WQVO(L,K,2) + WQA15G = (WQPNG(L)-1.0)*WQPG(L) * WQANCG * WQVO(L,K,3) + WQA15 = WQA15C+WQA15D+WQA15G + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQA15 =WQA15 + (WQPNM(L)-1.0)*WQPM(L)*WQANCM + & *WQVO(L,K,IDNOTRVA) + ENDIF +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + WQA15X=(WQPNX(L,nsp)-1.0)*WQPX(L,nsp) * WQANCX(nsp) + & * WQVOX(L,K,nsp) +! & * WQVO(L,K,nsp) + WQA15 = WQA15 + WQA15X + enddo +!} GEOSR X-species : jgcho 2015.10.12 + WQV(L,K,15)=SCB(L)*( WQVO(L,K,15) + DTWQ*WQRR(L) + & + DTWQO2*( WQA15 + & -WQANDC*WQDENIT(L)*WQVO(L,K,6)+WQNIT(L)*WQVO(L,K,14))) + & +(1.-SCB(L))*WQVO(L,K,15) + WQVO(L,K,15) = WQVO(L,K,15)+WQV(L,K,15) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,15)=WQVO(L,K,15) + WQVO(L,K,15) = WQVO(L,K,15)+WQV(L,K,15) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,15)=WQVO(L,K,15) + WQVO(L,K,15) = WQVO(L,K,15)+WQV(L,K,15) + ENDDO + ENDIF +C **** PARAM 16 + IF(ISTRWQ(16).EQ.1)THEN + IF(IWQSI.EQ.1)THEN + DO L=LMPI2,LMPILA +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQM16 = - (WQKSUA(IWQT(L)) + WQBDSET(L,1)) + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQM16) + WQA16D = (WQFSPD*WQBMD(L) + WQFSPP*WQPRD(L)) * WQASCD + & * WQVO(L,K,2) +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + if (IWQX(nsp).eq.2) then + WQA16D = WQA16D + (WQFSPDX(nsp)*WQBMX(L,nsp) + & + WQFSPPX(nsp)*WQPRX(L,nsp)) * WQASCDX(nsp) + & * WQVOX(L,K,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.12 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR16 = (WQWDSL(L,K,16)+WQWPSL(L,K,16)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR16 = WQR16 + WQATML(L,KC,16) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,16) + DTWQ*WQR16 + DTWQO2*( WQA16D + & + WQM16*WQVO(L,K,16) ) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C ENDDO + IF(K.NE.KC)THEN +C DO L=2,LA + WQRR(L) = WQRR(L) + DTWQO2*WQBDSET(L,2)*WQVO(L,K+1,16) +C ENDDO + ENDIF +C DO L=2,LA +!} + WQV(L,K,16)=SCB(L)*( WQRR(L)*WQKK(L) ) + & +(1.-SCB(L))*WQVO(L,K,16) + WQVO(L,K,16) = WQVO(L,K,16)+WQV(L,K,16) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,16)=WQVO(L,K,16) + WQVO(L,K,16) = WQVO(L,K,1)+WQV(L,K,16) + ENDIF + ENDDO +!} + ENDIF + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,16)=WQVO(L,K,16) + WQVO(L,K,16) = WQVO(L,K,16)+WQV(L,K,16) + ENDDO + ENDIF +C **** PARAM 17 + IF(ISTRWQ(17).EQ.1)THEN + IF(IWQSI.EQ.1)THEN + DO L=LMPI2,LMPILA +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQKK(L) = (WQFSID*WQBMD(L) + WQFSIP*WQPRD(L) - WQPD(L)) + & * WQASCD * WQVO(L,K,2) +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + if (IWQX(nsp).eq.2) then + WQKK(L) = WQKK(L) + (WQFSIDX(nsp)*WQBMX(L,nsp) + & + WQFSIPX(nsp)*WQPRX(L,nsp) - WQPX(L,nsp)) + & * WQASCDX(nsp) * WQVOX(L,K,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.12 +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQRR(L) = (WQWDSL(L,K,17)+WQWPSL(L,K,17)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQRR(L) = WQRR(L) + WQATML(L,KC,17) * VOLWQ(L) + ENDIF +C ENDDO + IF(K.EQ.1)THEN +C DO L=2,LA + WQRR(L) = WQRR(L) + WQBFSAD(L)*DZWQ(L) +C ENDDO + ENDIF +C DO L=2,LA + WQRR(L) = WQVO(L,K,17) + DTWQ*WQRR(L) + DTWQO2 + & *(WQKK(L)+WQKSUA(IWQT(L))*WQVO(L,K,16) + & +WQN17(L)*WQVO(L,K,17)) +C ENDDO + IF(K.NE.KC)THEN +C DO L=2,LA + WQRR(L) = WQRR(L) + DTWQO2*WQT17(L)*WQVO(L,K+1,17) +C ENDDO + ENDIF +C DO L=2,LA +!} + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQN17(L)) + WQV(L,K,17)=SCB(L)*( WQRR(L)*WQKK(L) ) + & +(1.-SCB(L))*WQVO(L,K,17) + WQVO(L,K,17) = WQVO(L,K,17)+WQV(L,K,17) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,17)=WQVO(L,K,17) + WQVO(L,K,17) = WQVO(L,K,17)+WQV(L,K,17) + ENDIF + ENDDO +!} + ENDIF + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,17)=WQVO(L,K,17) + WQVO(L,K,17) = WQVO(L,K,17)+WQV(L,K,17) + ENDDO + ENDIF +C **** PARAM 18 + IF(ISTRWQ(18).EQ.1)THEN + DO L=LMPI2,LMPILA +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQKK(L) = 1.0 / (1.0 - WQO18(L)) +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQRR(L) = (WQWDSL(L,K,18)+WQWPSL(L,K,18)) * VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQRR(L) = WQRR(L) + WQATML(L,KC,18) * VOLWQ(L) + ENDIF +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C ENDDO + IF(K.EQ.1)THEN +C DO L=2,LA + WQRR(L) = WQRR(L) + WQBFCOD(L)*DZWQ(L) +C ENDDO + ENDIF +C DO L=2,LA +!} + WQRR(L)=WQVO(L,K,18)+DTWQ*WQRR(L)+WQO18(L)*WQVO(L,K,18) + WQV(L,K,18)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,18) + WQVO(L,K,18) = WQVO(L,K,18)+WQV(L,K,18) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,18)=WQVO(L,K,18) + WQVO(L,K,18) = WQVO(L,K,18)+WQV(L,K,18) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,18)=WQVO(L,K,18) + WQVO(L,K,18) = WQVO(L,K,18)+WQV(L,K,18) + ENDDO + ENDIF +C **** PARAM 19 + IF(ISTRWQ(19).EQ.1)THEN + DO L=LMPI2,LMPILA +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQKK(L) = 1.0 / (1.0 - DTWQO2*WQP19(L)) +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQRR(L) = (WQWDSL(L,K,19)+WQWPSL(L,K,19)) * VOLWQ(L) + XDOPSL(L,K) = XDOPSL(L,K) + WQRR(L)*DTWQ*DZC(K)*HP(L) + XDOALL(L,K) = XDOALL(L,K) + WQRR(L)*DTWQ*DZC(K)*HP(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQRR(L) = WQRR(L) + WQATML(L,KC,19) * VOLWQ(L) + ENDIF +!{GeoSR, YSSONG, WQ WET/DRY, 110915 +C ENDDO + IF(K.EQ.KC)THEN +C DO L=2,LA + WQRR(L) = WQRR(L) + WQKRDOS(L) +C ENDDO + ENDIF + IF(K.EQ.1)THEN +C DO L=2,LA + WQRR(L) = WQRR(L) + WQBFO2(L)*DZWQ(L) + XDOSOD(L,K) = XDOSOD(L,K) + WQBFO2(L)*DTWQ + XDOALL(L,K) = XDOALL(L,K) + WQBFO2(L)*DTWQ +C ENDDO + ENDIF +C DO L=2,LA +!} + IZ=IWQZMAP(L,K) + O2WQ(L) = MAX(WQVO(L,K,19), 0.0) + WQTTC = (1.3 - 0.3*WQPNC(L)) * WQPC(L) + WQTTD = (1.3 - 0.3*WQPND(L)) * WQPD(L) + WQTTG = (1.3 - 0.3*WQPNG(L)) * WQPG(L) + XDOPPB(L,K) = XDOPPB(L,K) + ( WQTTC*WQVO(L,K,1) + & +WQTTD*WQVO(L,K,2)+WQTTG*WQVO(L,K,3))*WQAOCR*DTWQO2 + & *DZC(K)*HP(L) + XDOALL(L,K) = XDOALL(L,K) + ( WQTTC*WQVO(L,K,1) + & +WQTTD*WQVO(L,K,2)+WQTTG*WQVO(L,K,3))*WQAOCR*DTWQO2 + & *DZC(K)*HP(L) +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + WQTTX(nsp)=(1.3 - 0.3*WQPNX(L,nsp)) * WQPX(L,nsp) + XDOPPB(L,K) = XDOPPB(L,K) + ( WQTTX(nsp)*WQVOX(L,K,nsp)) + & *WQAOCR*DTWQO2*DZC(K)*HP(L) + XDOALL(L,K) = XDOALL(L,K) + ( WQTTX(nsp)*WQVOX(L,K,nsp)) + & *WQAOCR*DTWQO2*DZC(K)*HP(L) + enddo +!} GEOSR X-species : jgcho 2015.10.12 + + XMRM = CFCDCWQ*O2WQ(L)*WQBMC(L)/(WQKHRC+O2WQ(L)+ 1.E-18) + WQA19C = WQTTC - XMRM + XDORRB(L,K) = XDORRB(L,K) - XMRM*WQVO(L,K,1) + & * WQAOCR*DTWQO2*DZC(K)*HP(L) + XDOALL(L,K) = XDOALL(L,K) - XMRM*WQVO(L,K,1) + & * WQAOCR*DTWQO2*DZC(K)*HP(L) + + XMRM = CFCDDWQ*O2WQ(L)*WQBMD(L)/(WQKHRD+O2WQ(L)+ 1.E-18) + WQA19D = WQTTD - XMRM + XDORRB(L,K) = XDORRB(L,K) - XMRM*WQVO(L,K,2) + & * WQAOCR*DTWQO2*DZC(K)*HP(L) + XDOALL(L,K) = XDOALL(L,K) - XMRM*WQVO(L,K,2) + & * WQAOCR*DTWQO2*DZC(K)*HP(L) + + XMRM = CFCDGWQ*O2WQ(L)*WQBMG(L)/(WQKHRG+O2WQ(L)+ 1.E-18) + WQA19G = WQTTG - XMRM + XDORRB(L,K) = XDORRB(L,K) - XMRM*WQVO(L,K,3) + & * WQAOCR*DTWQO2*DZC(K)*HP(L) + XDOALL(L,K) = XDOALL(L,K) - XMRM*WQVO(L,K,3) + & * WQAOCR*DTWQO2*DZC(K)*HP(L) + + WQA19 = ( WQA19C*WQVO(L,K,1) + WQA19D*WQVO(L,K,2) + & + WQA19G*WQVO(L,K,3) ) * WQAOCR +!{ GEOSR X-species : jgcho 2015.10.12 + do nsp=1,NXSP + XMRM = CFCDWQX(nsp)*O2WQ(L)*WQBMX(L,nsp)/(WQKHRX(nsp) + & +O2WQ(L)+ 1.E-18) + WQA19X = WQTTX(nsp) - XMRM + XDORRB(L,K) = XDORRB(L,K) - XMRM*WQVOX(L,K,nsp) + & * WQAOCR*DTWQO2*DZC(K)*HP(L) + XDOALL(L,K) = XDOALL(L,K) - XMRM*WQVOX(L,K,nsp) + & * WQAOCR*DTWQO2*DZC(K)*HP(L) + WQA19 = WQA19 + (WQA19X*WQVOX(L,K,nsp)) * WQAOCR + enddo +!} GEOSR X-species : jgcho 2015.10.12 +C +C MODIFIED BY MRM 05/23/99 TO ALLOW DIFFERENT AOCR CONSTANTS TO BE APPLI +C TO PHOTOSYNTHESIS AND RESPIRATION TERMS FOR MACROALGAE: +C + IF(IDNOTRVA.GT.0.AND.K.EQ.1)THEN + WQTTM = (1.3 - 0.3*WQPNM(L)) * WQPM(L) + XMRM=(1.0-WQFCDM)*O2WQ(L)*WQBMM(L)/(WQKHRM(IZ)+O2WQ(L) + & +1.E-18) + WQA19A = WQTTM * WQVO(L,K,IDNOTRVA) * WQAOCRPM - + & XMRM * WQVO(L,K,IDNOTRVA) * WQAOCRRM + WQA19 = WQA19 + WQA19A + XDOPPM(L,K) = XDOPPM(L,K) + + & WQTTM*WQVO(L,K,IDNOTRVA)*WQAOCRPM*DTWQO2*DZC(K)*HP(L) + XDOALL(L,K) = XDOALL(L,K) + + & WQTTM*WQVO(L,K,IDNOTRVA)*WQAOCRPM*DTWQO2*DZC(K)*HP(L) + XDORRM(L,K) = XDORRM(L,K) - + & XMRM*WQVO(L,K,IDNOTRVA)*WQAOCRRM*DTWQO2*DZC(K)*HP(L) + XDOALL(L,K) = XDOALL(L,K) - + & XMRM*WQVO(L,K,IDNOTRVA)*WQAOCRRM*DTWQO2*DZC(K)*HP(L) + ENDIF + WQRR(L) = WQVO(L,K,19) + DTWQ*WQRR(L) + DTWQO2*( WQA19 + & -WQAOCR*WQKHR(L)*WQVO(L,K,6)-WQAONT*WQNIT(L)*WQVO(L,K,14) + & + WQP19(L)*WQVO(L,K,19) ) + WQO18(L)*WQVO(L,K,18) + WQV(L,K,19)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L)) + & *WQVO(L,K,19) + WQV(L,K,19) = MAX (WQV(L,K,19), 0.0) + WQVO(L,K,19) = WQVO(L,K,19)+WQV(L,K,19) +C +C COMPUTE AND SAVE D.O. DEFICIT: +C + XMRM = WQDOS(L) - WQV(L,K,19) + XDODEF(L,K) = XDODEF(L,K) + XMRM*DTWQ*DZC(K)*HP(L) + IF(K.EQ.KC)THEN + XDOKAR(L,K) = XDOKAR(L,K) + WQKRDOS(L)*DTWQ*DZC(K)*HP(L) + & + WQP19(L)*WQVO(L,K,19)*DTWQO2*DZC(K)*HP(L) + XDOALL(L,K) = XDOALL(L,K) + WQKRDOS(L)*DTWQ*DZC(K)*HP(L) + & + WQP19(L)*WQVO(L,K,19)*DTWQO2*DZC(K)*HP(L) + ENDIF + XDODOC(L,K)=XDODOC(L,K) - WQAOCR*WQKHR(L)*WQVO(L,K,6) + & *DTWQO2*DZC(K)*HP(L) + XDOALL(L,K)=XDOALL(L,K) - WQAOCR*WQKHR(L)*WQVO(L,K,6) + & *DTWQO2*DZC(K)*HP(L) + XDONIT(L,K)=XDONIT(L,K)-WQAONT*WQNIT(L)*WQVO(L,K,14) + & *DTWQO2*DZC(K)*HP(L) + XDOALL(L,K)=XDOALL(L,K)-WQAONT*WQNIT(L)*WQVO(L,K,14) + & *DTWQO2*DZC(K)*HP(L) + XDOCOD(L,K)=XDOCOD(L,K) - WQO18(L)*WQVO(L,K,18) + & *DZC(K)*HP(L) + XDOALL(L,K)=XDOALL(L,K) - WQO18(L)*WQVO(L,K,18) + & *DZC(K)*HP(L) + XDODZ(L,K) = XDODZ(L,K) + DZC(K)*HP(L) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,19)=WQVO(L,K,19) + WQVO(L,K,19) = WQVO(L,K,19)+WQV(L,K,19) + ENDIF + ENDDO +!} + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,19)=WQVO(L,K,19) + WQVO(L,K,19) = WQVO(L,K,19)+WQV(L,K,19) + ENDDO + ENDIF +C **** PARAM 20 + IF(ISTRWQ(20).EQ.1)THEN + IF(IWQSRP.EQ.1)THEN + DO L=LMPI2,LMPILA +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQT20 = - DTWQO2*WQWSSET(L,1) + WQKK(L) = 1.0 / (1.0 - WQT20) + WQRR(L)=WQVO(L,K,20)+DTWQ*WQR20(L)+WQT20*WQVO(L,K,20) +C ENDDO + IF(K.NE.KC)THEN +C DO L=2,LA + WQRR(L) = WQRR(L) + DTWQO2*WQWSSET(L,2)*WQVO(L,K+1,20) +C ENDDO + ENDIF +C DO L=2,LA + WQV(L,K,20)=SCB(L)*( WQRR(L)*WQKK(L) ) + & +(1.-SCB(L))*WQVO(L,K,20) + WQVO(L,K,20) = WQVO(L,K,20)+WQV(L,K,20) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,20)=WQVO(L,K,20) + WQVO(L,K,20) = WQVO(L,K,20)+WQV(L,K,20) + ENDIF + ENDDO +!} + ENDIF + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,20)=WQVO(L,K,20) + WQVO(L,K,20) = WQVO(L,K,20)+WQV(L,K,20) + ENDDO + ENDIF +C +C WQTD1FCB=1+DTWQO2*WQS21,WQTD2FCB=1/(1-DTWQO2*S21) +C +C **** PARAM 21 + IF(ISTRWQ(21).EQ.1)THEN + IF(IWQFCB.EQ.1)THEN + DO L=LMPI2,LMPILA +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + IF(LMASKDRY(L).OR.IWQM.GE.1)THEN +!} + WQKK(L) = WQTD2FCB(IWQT(L)) +C +C DEFINITIONS ATM DRY DEP LOADS VOLUMN +C + WQR21= (WQWDSL(L,K,NWQV)+WQWPSL(L,K,NWQV))*VOLWQ(L) + IF(K.EQ.KC)THEN +C +C DEFINITIONS ATM WET DEP VOLUMN +C + WQR21 = WQR21 + WQATML(L,KC,21) * VOLWQ(L) + ENDIF + WQRR(L) = WQVO(L,K,NWQV)*WQTD1FCB(IWQT(L)) + DTWQ*WQR21 + WQV(L,K,21)=SCB(L)*( WQRR(L)*WQKK(L) ) + & +(1.-SCB(L))*WQVO(L,K,21) + WQVO(L,K,21) = WQVO(L,K,21)+WQV(L,K,21) +!{GeoSR, YSSONG, WQ WET/DRY, 110915 + ELSE + WQV(L,K,21)=WQVO(L,K,21) + WQVO(L,K,21) = WQVO(L,K,21)+WQV(L,K,21) + ENDIF + ENDDO +!} + ENDIF + ELSE + DO L=LMPI2,LMPILA + WQV(L,K,21)=WQVO(L,K,21) + WQVO(L,K,21) = WQVO(L,K,21)+WQV(L,K,21) + ENDDO + ENDIF + +!{GeoSR, GROWTH LIMIT AND ALGAL RATE PRINT, YSSONG, 2015.12.10 + IF(IWQTS.GE.1)THEN + IF(ISCOMP .EQ. 3. OR. ISCOMP .EQ. 4)THEN + TIME=DT*FLOAT(N)+TCON*TBEGIN + TIME=TIME/TCON + IF(MYRANK.EQ.0)THEN + WRITE(FLN,"('WQRTS',I2.2,'.DAT')") K + OPEN(300+K,FILE=FLN,POSITION='APPEND') + DO M=1,IWQTS + LL=LWQTS(M) + WRITE(300+K,8999) TIME,WQPC(LL),WQBMC(LL),WQPRC(LL), + & WQPD(LL),WQBMD(LL),WQPRD(LL),WQPG(LL),WQBMG(LL),WQPRG(LL) + ENDDO + CLOSE(300+K) + ENDIF + ENDIF + ENDIF +!}GeoSR, GROWTH LIMIT AND ALGAL RATE PRINT, YSSONG, 2015.12.10 + + ENDDO +C + IF(.FALSE.)THEN + DO NSP=1,21; call collect_in_zero_array(WQV(:,:,NSP)); ENDDO !#1-1 + IF(MYRANK.EQ.0) THEN + DO LWQ3K=1,21 + DO K=1,KC + PRINT*,'WQ2V=',LWQ3K,k,sum(abs(dble(WQV(:,K,LWQ3K)))) + ENDDO + ENDDO + PRINT*,'L3184=',WQV(3184,2,1) + ENDIF + ENDIF +C +C ---------------------------------------------------------------- +C +C INCREMENT COUNTER FOR LIMITATION AND XDOXXX DO COMPONENT ARRAYS: +C + IF(ISDYNSTP.EQ.0)THEN + TIMTMP=DT*FLOAT(N)+TCON*TBEGIN + TIMTMP=TIMTMP/TCTMSR + ELSE + TIMTMP=TIMESEC/TCTMSR + ENDIF + TIMESUM3 = TIMESUM3 + TIMTMP + NLIM = NLIM + 1 +C +C COMPUTE WQCHL,WQTAMP,WQPO4D,WQSAD AT A NEW TIME STEP: WQCHLX=1/WQCHLX +C + DO K=1,KC + DO L=LMPI2,LMPILA + WQCHL(L,K) = WQV(L,K,1)*WQCHLC + WQV(L,K,2)*WQCHLD + & + WQV(L,K,3)*WQCHLG +!{ GEOSR X-species : jgcho 2015.10.13 + do nsp=1,NXSP + WQCHL(L,K) = WQCHL(L,K) + WQVX(L,K,nsp)*WQCHLX(nsp) + enddo +!} GEOSR X-species : jgcho 2015.10.13 + ENDDO + ENDDO +C + IF(IWQSRP.EQ.1)THEN + DO K=1,KC + DO L=LMPI2,LMPILA + O2WQ(L) = MAX(WQV(L,K,19), 0.0) + WQTAMD = MIN( WQTAMDMX*EXP(-WQKDOTAM*O2WQ(L)), WQV(L,K,20) ) + WQTAMP(L,K) = WQV(L,K,20) - WQTAMD + WQPO4D(L,K) = WQV(L,K,10) / (1.0 + WQKPO4P*WQTAMP(L,K)) + WQSAD(L,K) = WQV(L,K,17) / (1.0 + WQKSAP*WQTAMP(L,K)) + ENDDO + ENDDO + ELSE IF(IWQSRP.EQ.2)THEN + DO K=1,KC + DO L=LMPI2,LMPILA + WQPO4D(L,K) = WQV(L,K,10) / (1.0 + WQKPO4P*SEDT(L,K)) + WQSAD(L,K) = WQV(L,K,17) / (1.0 + WQKSAP*SEDT(L,K)) + ENDDO + ENDDO + ELSE + DO K=1,KC + DO L=LMPI2,LMPILA + WQPO4D(L,K) = WQV(L,K,10) + WQSAD(L,K) = WQV(L,K,17) + ENDDO + ENDDO + ENDIF +C +C COUPLING TO SEDIMENT MODEL +C: EVALUATE DEP. FLUX USING NEW VALUES CAUSE IMPLICIT SCHEME IS USED IN +C SPM +C + IF(IWQBEN.EQ.0)THEN + DO L=LMPI2,LMPILA + IMWQZ = IWQZMAP(L,1) + WQDFBC(L) = SCB(L)*WQWSC(IMWQZ)*WQV(L,1,1) + WQDFBD(L) = SCB(L)*WQWSD(IMWQZ)*WQV(L,1,2) + WQDFBG(L) = SCB(L)*WQWSG(IMWQZ)*WQV(L,1,3) + & +WQWSM*DZWQ(L)*WQV(L,1,IDNOTRVA) +!{ GEOSR X-species : jgcho 2015.10.13 WQWSX(1,i) + do nsp=1,NXSP + if (IWQX(nsp).eq.1) then + WQDFBC(L) = WQDFBC(L) + & + SCB(L)*WQWSX(IMWQZ,nsp)*WQVX(L,1,nsp) + endif + if (IWQX(nsp).eq.2) then + WQDFBD(L) = WQDFBD(L) + & + SCB(L)*WQWSX(IMWQZ,nsp)*WQVX(L,1,nsp) + endif + if (IWQX(nsp).eq.3) then + WQDFBG(L) = WQDFBG(L) + & + SCB(L)*WQWSX(IMWQZ,nsp)*WQVX(L,1,nsp) + endif + enddo +!} GEOSR X-species : jgcho 2015.10.13 + WQDFRC(L) = SCB(L)*WQWSRP(IMWQZ)*WQV(L,1,4) + WQDFLC(L) = SCB(L)*WQWSLP(IMWQZ)*WQV(L,1,5) + WQDFRP(L) = SCB(L)*WQWSRP(IMWQZ)*WQV(L,1,7) + WQDFLP(L) = SCB(L)*WQWSLP(IMWQZ)*WQV(L,1,8) + WQDFRN(L) = SCB(L)*WQWSRP(IMWQZ)*WQV(L,1,11) + WQDFLN(L) = SCB(L)*WQWSLP(IMWQZ)*WQV(L,1,12) + IF(IWQSI.EQ.1) WQDFSI(L) = SCB(L)*WQWSD(IMWQZ)*WQV(L,1,16) + ENDDO + IF(IWQSRP.EQ.1)THEN + DO L=LMPI2,LMPILA + IMWQZ = IWQZMAP(L,1) + WQDFLP(L) = SCB(L)*( WQDFLP(L) + & + WQWSS(IMWQZ)*( WQV(L,1,10)-WQPO4D(L,1) ) ) + IF(IWQSI.EQ.1) WQDFSI(L) = SCB(L)*( WQDFSI(L) + & + WQWSS(IMWQZ)*( WQV(L,1,17)-WQSAD(L,1) ) ) + ENDDO + ELSE IF(IWQSRP.EQ.2)THEN + DO L=LMPI2,LMPILA + WQDFLP(L) = SCB(L)*( WQDFLP(L)+WSEDO(NS)*( WQV(L,1,10) + & -WQPO4D(L,1) ) ) + IF(IWQSI.EQ.1) WQDFSI(L) = SCB(L)*( WQDFSI(L) + & + WSEDO(NS)*( WQV(L,1,17)-WQSAD(L,1) ) ) + ENDDO + ENDIF + ENDIF +C +C DIURNAL DO ANALYSIS +C + IF(NDDOAVG.GE.1)THEN + IF(MYRANK.EQ.0) OPEN(1,FILE='DIURNDO.OUT',POSITION='APPEND') + NDDOCNT=NDDOCNT+1 + NSTPTMP=NDDOAVG*NTSPTC/2 + RMULTMP=1./FLOAT(NSTPTMP) + DO K=1,KC + DO L=2,LA + DDOMAX(L,K)=MAX(DDOMAX(L,K),WQV(L,K,19)) + DDOMIN(L,K)=MIN(DDOMIN(L,K),WQV(L,K,19)) + ENDDO + ENDDO + IF(NDDOCNT.EQ.NSTPTMP)THEN + NDDOCNT=0 + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N)+TCON*TBEGIN + TIME=TIME/TCON + ELSE + TIME=TIMESEC/TCON + ENDIF + IF(MYRANK.EQ.0)THEN + WRITE(1,1111)N,TIME + DO L=2,LA + WRITE(1,1112)IL(L),JL(L),(DDOMIN(L,K),K=1,KC), + & (DDOMAX(L,K),K=1,KC) + ENDDO + ENDIF + DO K=1,KC + DO L=2,LA + DDOMAX(L,K)=-1.E6 + DDOMIN(L,K)=1.E6 + ENDDO + ENDDO + ENDIF + IF(MYRANK.EQ.0) CLOSE(1) + ENDIF +C +C LIGHT EXTINCTION ANALYSIS +C + IF(NDLTAVG.GE.1)THEN + IF(MYRANK.EQ.0) OPEN(1,FILE='LIGHT.OUT',POSITION='APPEND') + NDLTCNT=NDLTCNT+1 + NSTPTMP=NDLTAVG*NTSPTC/2 + RMULTMP=1./FLOAT(NSTPTMP) + DO K=1,KC + DO L=2,LA + RLIGHT1=WQKEB(IMWQZT(L))+WQKETSS*SEDT(L,K) + XMRM = WQKECHL*WQCHL(L,K) + IF(WQKECHL .LT. 0.0)THEN + XMRM = 0.054*WQCHL(L,K)**0.6667 + 0.0088*WQCHL(L,K) + ENDIF + RLIGHT2 = XMRM + RLIGHTT(L,K)=RLIGHTT(L,K)+RLIGHT1 + RLIGHTC(L,K)=RLIGHTC(L,K)+RLIGHT1+RLIGHT2 + ENDDO + ENDDO + IF(NDLTCNT.EQ.NSTPTMP)THEN + NDLTCNT=0 + IF(ISDYNSTP.EQ.0)THEN + TIME=DT*FLOAT(N)+TCON*TBEGIN + TIME=TIME/TCON + ELSE + TIME=TIMESEC/TCON + ENDIF + DO K=1,KC + DO L=2,LA + RLIGHTT(L,K)=RMULTMP*RLIGHTT(L,K) + RLIGHTC(L,K)=RMULTMP*RLIGHTC(L,K) + ENDDO + ENDDO + IF(MYRANK.EQ.0)THEN + WRITE(1,1111)N,TIME + DO L=2,LA + WRITE(1,1113)IL(L),JL(L),(RLIGHTT(L,K),K=1,KC), + & (RLIGHTC(L,K),K=1,KC) + ENDDO + ENDIF + DO K=1,KC + DO L=2,LA + RLIGHTT(L,K)=0. + RLIGHTC(L,K)=0. + ENDDO + ENDDO + ENDIF + IF(MYRANK.EQ.0) CLOSE(1) + ENDIF +!{ GEOSR STOKES : YSSONG 2015.08.18 + do nsp=1,NXSP + DO K=1,KC + DO L=LMPI2,LMPILA + WQVOXB(L,K,nsp) = WQVOX(L,K,nsp) + ENDDO + ENDDO + enddo + + DO K=1,KC + DO L=LMPI2,LMPILA + WQVOCB(L,K) = WQVO(L,K,1) + ENDDO + ENDDO +C + if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 + IF(ISSTOKEX(1).EQ.1)THEN + IF(MYRANK.EQ.0)THEN + do i=1,IWQTS + WRITE(FLN,"('STOKE',I2.2,'.OUT')") i + OPEN(1,FILE=trim(FLN),POSITION='APPEND') ! VERTICAL VELOCITY, ALGAL-DENSITY, SOLAR RADIATION, chl-a PRINT AT EACH LAYER + WRITE(FMTSTR, '("(F12.6,",I0,"(E12.4))")') NXSP*KC*4 + write(1,FMTSTR) TIMTMP + & ,((WQALSETX(LWQTS(i),k,nsp),nsp=1,NXSP),k=kc,1,-1) + & ,((WQRHOX(LWQTS(i),k,nsp),nsp=1,NXSP),k=kc,1,-1) + & ,((WQSOLDAX(LWQTS(i),k,nsp),nsp=1,NXSP),k=kc,1,-1) + & ,(WQCHL(LWQTS(i),k),k=kc,1,-1) + close(1) + enddo +! OPEN(1,FILE='STOKE.OUT',POSITION='APPEND') +! WRITE(1,1114) TIMTMP,(WQALSETX(136,K,1),WQRHOX(136,K,1), ! GEOSR X-species : jgcho 2015.10.13 +! & WQSOLDAX(136,K,1),WQCHL(136,K),K=1,KC) +! CLOSE(1) + ENDIF + ENDIF + endif !if (NXSP.gt.0) then !{ GEOSR X-species : jgcho 2015.10.15 +!} GEOSR STOKES : YSSONG 2015.08.18 +!{ GeoSR Bentic-cyano : JHLEE 2015.10.12 +C SETTLING VELOCITY ANALYSIS +! IF(ISCYANO.GE.1)THEN +! OPEN(1,FILE='CYANO.OUT',POSITION='APPEND') +! WRITE(1,1115) TIMTMP,CYA_ADD(136),CYA_TIME(136) +! CLOSE(1) +! ENDIF +! 1115 FORMAT(F12.6,2(F15.6,1x)) +!} GeoSR Bentic-cyano : JHLEE 2015.10.12 + 1111 FORMAT(I12,F10.4) + 1112 FORMAT(2I5,12F7.2) + 1113 FORMAT(2I5,12E12.4) + 8999 FORMAT(F10.5,9E12.4) + + RETURN + END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE4.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE4.for index 6723dc6fa..9a23fad76 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE4.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WQSKE4.for @@ -30,6 +30,17 @@ C C**********************************************************************C C USE GLOBAL + REAL WQVREA,WQTT1,WQTTT,WQF1NM,WQAVGIO,WQTTB,WQA1C,WQKESS1 + INTEGER L + L = 0 + WQVREA=0.0 + WQTTT=0.0 + WQF1NM=0.0 + WQAVGIO=0.0 + WQTTB=0.0 + WQA1C=0.0 + WQTT1=0.0 + WQKESS1=0.0 C C**********************************************************************C C @@ -114,16 +125,16 @@ C MRM +++++++++ ADDED BY M. MORTON 08/05/98 ELSE TIMTMP=TIMESEC/86400. ENDIF - WRITE(8,911) TIMTMP, L, IL(L), JL(L), K, TWQ(L) + IF(MYRANK.EQ.0) WRITE(8,911) TIMTMP,L,IL(L),JL(L),K,TWQ(L) C MRM +++++++++ ADDED BY M. MORTON 07/24/98 - WRITE(6,600)IL(L),JL(L),K,TWQ(L) +c IF(MYRANK.EQ.0) WRITE(6,600)IL(L),JL(L),K,TWQ(L) IWQT(L)=MAX(IWQT(L),1) IWQT(L)=MIN(IWQT(L),NWQTD) C STOP 'ERROR!! INVALID WATER TEMPERATURE' ENDIF ENDDO C - 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) +C 600 FORMAT(' I,J,K,TEM = ',3I5,E13.4) 911 FORMAT(/,'ERROR ', & 'TIME, L, I, J, K, TWQ(L) = ', F10.5, 4I4, F10.4) C @@ -1531,7 +1542,7 @@ C C DIURNAL DO ANALYSIS C IF(NDDOAVG.GE.1)THEN - OPEN(1,FILE='DIURNDO.OUT',POSITION='APPEND') + IF(MYRANK.EQ.0) OPEN(1,FILE='DIURNDO.OUT',POSITION='APPEND') NDDOCNT=NDDOCNT+1 NSTPTMP=NDDOAVG*NTSPTC/2 RMULTMP=1./FLOAT(NSTPTMP) @@ -1551,11 +1562,13 @@ C ELSE TIME=TIMESEC/TCON ENDIF + IF(MYRANK.EQ.0)THEN WRITE(1,1111)N,TIME DO L=2,LA WRITE(1,1112)IL(L),JL(L),(DDOMIN(L,K),K=1,KC), & (DDOMAX(L,K),K=1,KC) ENDDO + ENDIF DO K=1,KC DO L=2,LA DDOMAX(L,K)=-1.E6 @@ -1564,13 +1577,13 @@ C ENDDO ENDIF C - CLOSE(1) + IF(MYRANK.EQ.0) CLOSE(1) ENDIF C C LIGHT EXTINCTION ANALYSIS C IF(NDLTAVG.GE.1)THEN - OPEN(1,FILE='LIGHT.OUT',POSITION='APPEND') + IF(MYRANK.EQ.0) OPEN(1,FILE='LIGHT.OUT',POSITION='APPEND') NDLTCNT=NDLTCNT+1 NSTPTMP=NDLTAVG*NTSPTC/2 RMULTMP=1./FLOAT(NSTPTMP) @@ -1607,11 +1620,13 @@ C RLIGHTC(L,K)=RMULTMP*RLIGHTC(L,K) ENDDO ENDDO + IF(MYRANK.EQ.0)THEN WRITE(1,1111)N,TIME DO L=2,LA WRITE(1,1113)IL(L),JL(L),(RLIGHTT(L,K),K=1,KC), & (RLIGHTC(L,K),K=1,KC) ENDDO + ENDIF DO K=1,KC DO L=2,LA RLIGHTT(L,K)=0. @@ -1620,7 +1635,7 @@ C ENDDO ENDIF C - CLOSE(1) + IF(MYRANK.EQ.0) CLOSE(1) ENDIF C C diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQRST.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQRST.for index 36aa9eceb..e4773a0a1 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQRST.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQRST.for @@ -4,11 +4,21 @@ C CHANGE RECORD C WRITE SPATIAL DISTRIBUTIONS AT THE END OF SIMULATION TO UNIT IWQORST. C USE GLOBAL + USE MPI CHARACTER*64 RESTFN ! { GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.5.23 C C WRITE ASCII RESTART FILE: C + + DO NW=1,NWQV + call collect_in_zero_array(WQV(:,:,NW)) + ENDDO + DO NSP=1,NXSP + call collect_in_zero_array(WQVX(:,:,NSP)) + ENDDO + call collect_in_zero_array(QSUM) + IF(MYRANK.EQ.0)THEN IF (ISRST.EQ.0) THEN ! { GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.5.23 OPEN(1,FILE='WQWCRST.OUT',STATUS='UNKNOWN') CLOSE(1,STATUS='DELETE') @@ -84,6 +94,7 @@ C ! } GEOSR X-species RESTART FILE EVERY REFERENCE TIME : JGCHO 2016.1.26 ! ENDIF ! IF (ISRST.EQ.0) THEN + ENDIF ! MYRANK.EQ.0 ! } GEOSR WRITE RESTART FILE EVERY REFERENCE TIME : JGCHO 2011.5.23 C C ALSO WRITE BINARY RESTART FILE: diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQTS.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQTS.for index b1ffd151a..5aa9a1e76 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQTS.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQTS.for @@ -5,6 +5,7 @@ C CHANGE RECORD C WRITE TIME-SERIES OUTPUT: WQCHLX=1/WQCHLX C USE GLOBAL + USE MPI C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WQVOUT IF(.NOT.ALLOCATED(WQVOUT))THEN @@ -12,7 +13,9 @@ C WQVOUT=0.0 ENDIF C + IF(MYRANK.EQ.0.AND.DEBUG)THEN OPEN(1,FILE='WQWCTS.OUT',STATUS='UNKNOWN',POSITION='APPEND') + ENDIF IF(ISDYNSTP.EQ.0)THEN TIMTMP=DT*FLOAT(N)+TCON*TBEGIN TIMTMP=TIMTMP/TCTMSR @@ -89,7 +92,8 @@ C WINDREA = WINDST(LL) WQVOUT(NWQOUT)=0.728*SQRT(WINDREA) & +(0.0372*WINDREA-0.317)*WINDREA - WRITE(1,71) IL(LL),JL(LL),K,TIMTMP, + IF(MYRANK.EQ.0.AND.DEBUG) WRITE(1,71) + & IL(LL),JL(LL),K,TIMTMP, & (WQVOUT(NWOUT),NWOUT=1,NWQOUT) ENDDO ENDDO @@ -102,7 +106,7 @@ C HHTMP = WATER DEPTH (METERS) C CHLM = MACROALGAE BIOMASS IN MICROGRAMS/SQUARE METER: C CHLM IN UG/L AS FOLLOWS: C - CLOSE(1) + IF(MYRANK.EQ.0) CLOSE(1) RETURN END diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQTSBIN.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQTSBIN.for index 102ce71e2..90ee7aabb 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQTSBIN.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/WWQTSBIN.for @@ -50,6 +50,7 @@ C WQVO(LL,K,10) = TOT. INORG. PHOS. WQVO(LL,K,21) = FECAL COLIFORM BACTERIA C WQVO(LL,K,11) = REFRACTORY PON WQVO(LL,K,22) = MACROALGAE C USE GLOBAL + USE MPI C LOGICAL ISASCII, IS2OPEN C @@ -63,6 +64,9 @@ C ! GeoSR, GROWTH LIMIT AND ALGAL RATE PRINT, YSSONG, 2015.12.10 CHARACTER*11 FLN CHARACTER*12 FLNX + REAL WQVREA + WQVREA=0.0 + IF(.NOT.ALLOCATED(TNWQMAX))THEN ALLOCATE(TNWQMAX(LCMWQ,KCM)) ALLOCATE(TNWQMIN(LCMWQ,KCM)) @@ -342,7 +346,7 @@ C XMRM = SQRT(U(LL,K)*U(LL,K) + V(LL,K)*V(LL,K)) C C NOW COMBINE REAERATION DUE TO WATER VELOCITY AND WIND STRESS: C - IWQTMRM = 10.0*TEM(LL,K) + 151 + IWQTMRM = INT(10.0*TEM(LL,K),KIND(IWQTMRM)) + 151 C DZWQMRM = 1.0 / (DZC(K)*HP(LL)) C XMRM = - (WQVREA + WQWREA) * DZWQMRM*WQTDKR(IWQTMRM) XMRM = - (WQVREA + WQWREA) * WQTDKR(IWQTMRM,IZ) @@ -376,7 +380,9 @@ C IF(NWQCNT .EQ. IWQTSDT)THEN TIMTMP = TIMESUM / NWQCNT C C OPEN WQ ASCII FILE: + IF(MYRANK.EQ.0.AND.DEBUG)THEN OPEN(1,FILE='WQWCTS.OUT',STATUS='UNKNOWN',POSITION='APPEND') + ENDIF C C OPEN WQ AVERAGE BINARY FILE: IF(ISWQAVG .GT. 0)THEN @@ -490,7 +496,7 @@ C + TPWQSUM(LL,K),WQVSUM(LL,K,9),POPSUM(LL,K),WQVSUM(LL,K,10), ENDDO ENDDO C - 71 FORMAT(3I5,F11.5, 1P, 23E11.3) +C 71 FORMAT(3I5,F11.5, 1P, 23E11.3) C CLOSE(1) IF(ISWQAVG .GT. 0)THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/ZBRENT.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/ZBRENT.for index fbf45f59c..847b6f449 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/ZBRENT.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/ZBRENT.for @@ -4,12 +4,16 @@ C USING BRENT'S METHOD, FIND THE ROOT OF A FUNC SEDFLUX KNOWN TO LIE C BETWEEN RMIN & RMAX WITHIN AN ACCURACY OF TOL (P. 253 IN NUMERICAL C RECIPE). C + REAL A,B,C,D,E EXTERNAL SEDFLUX PARAMETER (IZMAX=100,EPS=3.0E-8,TOL=1.0E-5, & RMIN=1.0E-4,RMAX=100.0) ISMERR = 0 A = RMIN B = RMAX + C = 0.0 + D = 0.0 + E = 0.0 FA = SEDFLUX(A) FB = SEDFLUX(B) ZBRENT = 0 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/foodchain.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/foodchain.for index 471aee25c..15b930f91 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/foodchain.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/foodchain.for @@ -22,6 +22,7 @@ C C**********************************************************************C C USE GLOBAL + USE MPI C ! *** DSLLC BEGIN INTEGER,ALLOCATABLE,DIMENSION(:)::KBFC @@ -64,6 +65,8 @@ C REAL,ALLOCATABLE,DIMENSION(:,:)::FDCHTXBC REAL,ALLOCATABLE,DIMENSION(:,:)::FDCHTXBP REAL,ALLOCATABLE,DIMENSION(:,:)::FDCHTXBD + INTEGER JSFDCH + JSFDCH=0 C IF(.NOT.ALLOCATED(KBFC))THEN ALLOCATE(KBFC(LCM)) @@ -157,7 +160,7 @@ C C C WRITE(8,*)' FIRST ENTRY TO FOODCHAIN.FOR ' C - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='FOODCHAIN.OUT') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='FOODCHAIN.OUT') @@ -484,7 +487,7 @@ C############################################################################### ENDIF ENDDO C - IF(JSFDCH.EQ.1.AND.DEBUG)THEN + IF(JSFDCH.EQ.1.AND.DEBUG.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='FOODCHAIN.DIA') CLOSE(1,STATUS='DELETE') OPEN(1,FILE='FOODCHAIN.DIA') @@ -662,7 +665,7 @@ C############################################################################### ENDDO ENDDO C - IF(DEBUG)THEN + IF(DEBUG.AND.MYRANK.EQ.0)THEN OPEN(1,FILE='FOODCHAIN.OUT',POSITION='APPEND') C WRITE(1,101)TIME,NTOX,NFDCHZ,TIMFDCH @@ -715,9 +718,9 @@ C 112 FORMAT(20X,10F10.4) 101 FORMAT(F12.4,2I7,F12.3) 102 FORMAT(1X,2I6,10E13.5) - 103 FORMAT(' TXWF TXWC TXWP', - & ' DOCW POCW TXBF TXBC', - & ' TXBP (roc) DOCB POCB TXBPD (r)') +C 103 FORMAT(' TXWF TXWC TXWP', +C & ' DOCW POCW TXBF TXBC', +C & ' TXBP (roc) DOCB POCB TXBPD (r)') 121 FORMAT('DATA: OUTPUT TIME (DAYS), NTOX, NZONES, ', & 'AERAGING PERIOD (SECS)') 122 FORMAT('DATA: NT NZ TXWF TXWC TXWP', diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/initbin0.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/initbin0.for index 252d5d612..a46c80c38 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/initbin0.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/initbin0.for @@ -27,6 +27,7 @@ C C------------------------------------------------------------------- C USE GLOBAL + USE MPI C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XLON REAL,SAVE,ALLOCATABLE,DIMENSION(:)::YLAT @@ -117,7 +118,7 @@ C--------------------------------------------------------- C C IF HYDTS.BIN ALREADY EXISTS, OPEN FOR APPENDING HERE. C - IF(ISTMSR .EQ. 2)THEN + IF(ISTMSR .EQ. 2.AND.MYRANK.EQ.0)THEN IO = 1 5 IO = IO+1 IF(IO .GT. 99)THEN @@ -144,7 +145,7 @@ C------------------------------------------------------------------- C C IF HYDTS.BIN ALREADY EXISTS, DELETE IT HERE. C - IF(ISTMSR .EQ. 1)THEN + IF(ISTMSR .EQ. 1.AND.MYRANK.EQ.0)THEN TBEGAN = TBEGIN IO = 1 10 IO = IO+1 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/initbin2.for b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/initbin2.for index 8188ad6e5..5e7bf2ee1 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/initbin2.for +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/initbin2.for @@ -33,6 +33,7 @@ C**********************************************************************C C C USE GLOBAL + USE MPI C REAL,SAVE,ALLOCATABLE,DIMENSION(:)::XLON REAL,SAVE,ALLOCATABLE,DIMENSION(:)::YLAT @@ -158,7 +159,7 @@ C--------------------------------------------------------- C C IF WQDIURDO.BIN ALREADY EXISTS, OPEN FOR APPENDING HERE. C - IF(ISDIURDO .EQ. 2)THEN + IF(ISDIURDO .EQ. 2.AND.MYRANK.EQ.0)THEN INQUIRE(FILE='WQDIURDO.BIN', EXIST=FEXIST) IF(FEXIST)THEN OPEN(UNIT=2, FILE='WQDIURDO.BIN', ACCESS='DIRECT', @@ -177,7 +178,7 @@ C------------------------------------------------------------------- C C IF WQDIURDO.BIN ALREADY EXISTS, DELETE IT HERE. C - IF(ISDIURDO .EQ. 1)THEN + IF(ISDIURDO .EQ. 1.AND.MYRANK.EQ.0)THEN TBEGAN = TBEGIN INQUIRE(FILE='WQDIURDO.BIN', EXIST=FEXIST) IF(FEXIST)THEN diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_bedload.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_bedload.f90 index ab656ae92..cd1d38f65 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_bedload.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_bedload.f90 @@ -36,7 +36,8 @@ SUBROUTINE BEDLOADJ PSUS(L,1:NSCM)=0.0 ELSEWHERE BLFLAG(L,1:NSCM)=1 - PSUS(L,1:NSCM)=MAX((LOG(USW(L,1:NSCM))-LOG(SQRT(TCRSUS(1:NSCM))/DWS(1:NSCM)))/(LOG(4.0)-LOG(SQRT(TCRSUS(1:NSCM))/DWS(1:NSCM))),0.D0) + PSUS(L,1:NSCM)=MAX((LOG(USW(L,1:NSCM))-LOG(SQRT(TCRSUS(1:NSCM))/DWS(1:NSCM)))& + /(LOG(4.0)-LOG(SQRT(TCRSUS(1:NSCM))/DWS(1:NSCM))),0.0) ENDWHERE ELSEWHERE BLFLAG(L,1:NSCM)=0 diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_main.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_main.f90 index 338ed0e71..4dc702cb9 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_main.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_main.f90 @@ -2,7 +2,7 @@ SUBROUTINE SEDZLJ_MAIN USE GLOBAL IMPLICIT NONE - DOUBLE PRECISION,DIMENSION(LCM)::WVEL,CLEFT,CRIGHT,GRADSED,SEDAVG,CRNUM,CRAIG + DOUBLE PRECISION,DIMENSION(LCM)::WVEL,CLEFT,CRIGHT,GRADSED,SEDAVG,CRNUM INTEGER::L,K,NS DOUBLE PRECISION::AA11,AA12,AA21,AA22,BB11,BB22,DETI ! PT: real values are written in DOUBLE PRECISION. 7/16/08 @@ -16,7 +16,6 @@ SUBROUTINE SEDZLJ_MAIN !**********************************************************************! ! - DO NS=1,NSED DO K=1,KC DO L=2,LA @@ -32,7 +31,9 @@ SUBROUTINE SEDZLJ_MAIN CALL SEDZLJ_SHEAR ! !Calculating the morphology before sediment transport of each time step. - IF(IMORPH_SEDZLJ==1)FORALL(L=2:LA)HBED(L,1:KB)=0.01*(TSED(1:KB,L)/BULKDENS(1:KB,L)) + IF(IMORPH_SEDZLJ==1) THEN + FORALL(L=2:LA) HBED(L,1:KB) = REAL(0.01*(TSED(1:KB,L)/BULKDENS(1:KB,L)),KIND(HBED)) + ENDIF !TSED-sediment layer's thickness. HBED-Bed height. BULKDENS-Density of sediment and water in layer. ! !Setting the sediment concentration in the current. SEDS is a saved version of SED (the sediment @@ -51,7 +52,7 @@ SUBROUTINE SEDZLJ_MAIN ! !WSETA - temporary settling velocity. The division of DWS by 100.0 probably has to do with unit conversion. !going from cm/s to m/s. - FORALL(K=0:KS,L=2:LA)WSETA(L,K,1:NSCM)=DWS(1:NSCM)/100.0 + FORALL(K=0:KS,L=2:LA)WSETA(L,K,1:NSCM)=REAL(DWS(1:NSCM)/100.0,KIND(WSETA)) SEDF(2:LA,0:KS,1:NSCM)=0.0 !if(minval(SEDF) < 0.0) then !print *, 'Negative SEDF 0' @@ -69,7 +70,7 @@ SUBROUTINE SEDZLJ_MAIN WVEL(L)=DELT*HPI(L)*DZIC(KC) CLEFT(L)=1.0+WSETA(L,KC-1,NS)*WVEL(L) CRIGHT(L)=MAX(SED(L,KC,NS),0.0) - SED(L,KC,NS)=CRIGHT(L)/CLEFT(L) + SED(L,KC,NS)=REAL(CRIGHT(L)/CLEFT(L),KIND(SED)) SEDF(L,KC-1,NS)=-WSETA(L,KC-1,NS)*SED(L,KC,NS) ENDFORALL !PT: added if loop to allow code to run faster for KC = 2 case. @@ -79,7 +80,7 @@ SUBROUTINE SEDZLJ_MAIN WVEL(L)=DELT*HPI(L)*DZIC(K) CLEFT(L)=1.0+WSETA(L,K-1,NS)*WVEL(L) CRIGHT(L)=MAX(SED(L,K,NS),0.0)-SEDF(L,K,NS)*WVEL(L) - SED(L,K,NS)=CRIGHT(L)/CLEFT(L) + SED(L,K,NS)=REAL(CRIGHT(L)/CLEFT(L),KIND(SED)) SEDF(L,K-1,NS)=-WSETA(L,K-1,NS)*SED(L,K,NS) ENDFORALL ENDDO @@ -104,9 +105,11 @@ SUBROUTINE SEDZLJ_MAIN ! ** Update the bed thickness based on the flux and calculate ! the flux into the water column. ! - QSBDTOP(L)=SUM(SSGI(1:NSCM)*SEDF(L,0,1:NSCM)) + QSBDTOP(L)=REAL(SUM(SSGI(1:NSCM)*SEDF(L,0,1:NSCM)),KIND(QSBDTOP)) DO NS=1,NSCM - QWBDTOP(L)=QWBDTOP(L)+SSGI(NS)*(VDRBED(L,KBT(L))*MAX(SEDF(L,0,NS),0.0)+VDRDEPO(NS)*MIN(SEDF(L,0,NS),0.0)) + QWBDTOP(L)=REAL(QWBDTOP(L)+SSGI(NS)*(VDRBED(L,KBT(L))*MAX(SEDF(L,0,NS),0.0) & + +VDRDEPO(NS)*MIN(SEDF(L,0,NS),0.0)), & + KIND(QWBDTOP)) ENDDO ! delme @@ -129,7 +132,7 @@ SUBROUTINE SEDZLJ_MAIN CRNUM(L)=1.0+DELT*WSETA(L,K,NS)*HPI(L)*DZIC(K+1) GRADSED(L)=(SED(L,K+1,NS)-SED(L,K,NS))/(DZC(K+1)+DZC(K)) SEDAVG(L)=0.5*(SED(L,K+1,NS)+SED(L,K,NS)+1.0E-16) - WSETA(L,K,NS)=-CRNUM(L)*DZC(K+1)*WSETA(L,K,NS)*GRADSED(L)/SEDAVG(L) + WSETA(L,K,NS)=REAL(-CRNUM(L)*DZC(K+1)*WSETA(L,K,NS)*GRADSED(L)/SEDAVG(L),KIND(WSETA)) ENDFORALL ENDDO ! @@ -196,7 +199,7 @@ SUBROUTINE SEDZLJ_MAIN CRNUM=1.+DELT*WSETA(2:LA,K,NS)*HPI(2:LA)*DZIC(K+1) GRADSED=(SED(2:LA,K+1,NS)-SED(2:LA,K,NS))/(DZC(K+1)+DZC(K)) SEDAVG=0.5*(SED(2:LA,K+1,NS)-SED(2:LA,K,NS)+1.E-16) - WSETA(2:LA,K,NS)=-CRNUM*DZC(K+1)*WSETA(2:LA,K,NS)*GRADSED/SEDAVG + WSETA(2:LA,K,NS)=REAL(-CRNUM*DZC(K+1)*WSETA(2:LA,K,NS)*GRADSED/SEDAVG,KIND(WSETA)) ENDDO ! ! TVAR1S=LOWER DIAGONAL @@ -276,8 +279,8 @@ SUBROUTINE SEDZLJ_MAIN BB11=DELTI*DZC(1)*HP(L)*SED(L,1,NS) BB22=DELTI*DZC(KC)*HP(L)*SED(L,KC,NS) DETI=1./(AA11*AA22-AA12*AA21) - SED(L,1,NS)=DETI*( BB11*AA22-BB22*AA12 ) - SED(L,KC,NS)=DETI*( AA11*BB22-AA21*BB11 ) + SED(L,1,NS)=REAL(DETI*( BB11*AA22-BB22*AA12 ), KIND(SED)) + SED(L,KC,NS)=REAL(DETI*( AA11*BB22-AA21*BB11 ), KIND(SED)) ENDDO ENDIF ! @@ -302,7 +305,7 @@ SUBROUTINE SEDZLJ_MAIN ! SEDZLJ Sediment and Contaminant Transport model ! DO NS=1,NSCM - FORALL(L=2:LA,K=0:KS)WSETA(L,K,NS)=DWS(NS)/100. + FORALL(L=2:LA,K=0:KS)WSETA(L,K,NS)=REAL(DWS(NS)/100.,KIND(WSETA)) !----------------------------------------------------------------------! ! ! ** HORIZONTAL LOOPS @@ -312,7 +315,7 @@ SUBROUTINE SEDZLJ_MAIN WVEL(2:LA)=DELT*HPI(2:LA)*DZIC(K) CLEFT(2:LA)=1.0+WSETA(2:LA,K-1,NS)*WVEL(2:LA) CRIGHT(2:LA)=MAX(SED(2:LA,K,NS),0.0) - SED(2:LA,K,NS)=CRIGHT(2:LA)/CLEFT(2:LA) + SED(2:LA,K,NS)=REAL(CRIGHT(2:LA)/CLEFT(2:LA),KIND(SED)) SEDF(2:LA,K-1,NS)=-WSETA(2:LA,K-1,NS)*SED(2:LA,K,NS) !if(minval(SEDF) < 0.0) then !print *, 'Negative SEDF 7' @@ -323,7 +326,7 @@ SUBROUTINE SEDZLJ_MAIN WVEL(2:LA)=DELT*HPI(2:LA)*DZIC(K) CLEFT(2:LA)=1.0+WSETA(2:LA,K-1,NS)*WVEL(2:LA) CRIGHT(2:LA)=MAX(SED(2:LA,K,NS),0.0)-SEDF(2:LA,K,NS)*WVEL(2:LA) - SED(2:LA,K,NS)=CRIGHT(2:LA)/CLEFT(2:LA) + SED(2:LA,K,NS)=REAL(CRIGHT(2:LA)/CLEFT(2:LA),KIND(SED)) SEDF(2:LA,K-1,NS)=-WSETA(2:LA,K-1,NS)*SED(2:LA,K,NS) !if(minval(SEDF) < 0.0) then !print *, 'Negative SEDF 8' @@ -341,8 +344,10 @@ SUBROUTINE SEDZLJ_MAIN ! ** Update the bed thickness based on the flux and calculate ! the flux into the water column. ! - QSBDTOP(L)=SUM(SSGI(1:NSCM)*SEDF(L,0,1:NSCM)) - QWBDTOP(L)=VDRBED(L,KBT(L))*SUM(SSGI(1:NSCM)*SEDF(L,0,1:NSCM),SEDF(L,0,1:NSCM)>0.0)+SUM(SSGI(1:NSCM)*VDRDEPO(1:NSCM)*SEDF(L,0,1:NSCM),SEDF(L,0,1:NSCM)<0.0) + QSBDTOP(L)=REAL(SUM(SSGI(1:NSCM)*SEDF(L,0,1:NSCM)),KIND(QSBDTOP)) + QWBDTOP(L)=REAL(VDRBED(L,KBT(L))*SUM(SSGI(1:NSCM)*SEDF(L,0,1:NSCM),SEDF(L,0,1:NSCM)>0.0) & + +SUM(SSGI(1:NSCM)*VDRDEPO(1:NSCM)*SEDF(L,0,1:NSCM),SEDF(L,0,1:NSCM)<0.0), & + KIND(QWBDTOP)) !DO NS=1,NSCM !QWBDTOP(L)=QWBDTOP(L)+SSGI(1:NSCM)*(VDRBED(L,KBT(L))*MAX(SEDF(L,0,NS),0.0)+VDRDEPO(NS)*MIN(SEDF(L,0,NS),0.0)) !ENDDO @@ -361,7 +366,7 @@ SUBROUTINE SEDZLJ_MAIN CRNUM(L)=1.0+DELT*WSETA(L,K,NS)*HPI(L)*DZIC(K+1) GRADSED(L)=(SED(L,K+1,NS)-SED(L,K,NS))/(DZC(K+1)+DZC(K)) SEDAVG(L)=0.5*(SED(L,K+1,NS)+SED(L,K,NS)+1.0E-16) - WSETA(L,K,NS)=-CRNUM(L)*DZC(K+1)*WSETA(L,K,NS)*GRADSED(L)/SEDAVG(L) + WSETA(L,K,NS)=REAL(-CRNUM(L)*DZC(K+1)*WSETA(L,K,NS)*GRADSED(L)/SEDAVG(L),KIND(WSETA)) ENDFORALL ENDDO ! diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_morph.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_morph.f90 index 899e3db6f..87bd06e41 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_morph.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_morph.f90 @@ -9,7 +9,7 @@ SUBROUTINE MORPHJ !INTEGER::ITMP,K,L,LL,NS,NT !REAL,SAVE,ALLOCATABLE,DIMENSION(:)::DELBED DOUBLE PRECISION::TMPVAL - INTEGER::ITMP,K,L,LL,NS,NT + INTEGER::ITMP,K,L,NS,NT !PT: real value are written in DOUBLE PRECISION. 7/16/08 DOUBLE PRECISION,SAVE,ALLOCATABLE,DIMENSION(:)::DELBED IF(.NOT.ALLOCATED(DELBED)) THEN @@ -22,10 +22,10 @@ SUBROUTINE MORPHJ HTMP(L)=HP(L) H1P(L)=HP(L) P1(L)=P(L) - HBEDA(L)=0.01*SUM(TSED(1:KB,L)/BULKDENS(1:KB,L)) - HBED(L,1:KB)=0.01*TSED(1:KB,L)/BULKDENS(1:KB,L) + HBEDA(L)=REAL(0.01*SUM(TSED(1:KB,L)/BULKDENS(1:KB,L)),KIND(HBEDA)) + HBED(L,1:KB)=REAL(0.01*TSED(1:KB,L)/BULKDENS(1:KB,L),KIND(HBEDA)) BELV(L)=ZELBEDA(L)+HBEDA(L) - HP(L)=HP(L)+DELBED(L) + HP(L)=HP(L)+REAL(DELBED(L),KIND(HP)) ENDDO !print*,0.01*SUM(TSED(1:KB,2:LA)/BULKDENS(1:KB,2:LA)),sum(belv(2:LA)),sum(hp(2:LA)),sum(delbed(2:la)) DO L=2,LA @@ -37,7 +37,8 @@ SUBROUTINE MORPHJ IF(HP(L)<=0.0) THEN IF(ABS(H1P(L))>=HWET) THEN ITMP=1 - WRITE(8,"('NEG DEPTH DUE TO MORPH CHANGE', 2I5,12F12.5)")IL(L),JL(L),HBED1(L,KBT(L)),HBED(L,KBT(L)),BELV1(L),BELV(L),DELT,QSBDTOP(L),QWBDTOP(L),HBEDA(L) + WRITE(8,"('NEG DEPTH DUE TO MORPH CHANGE', 2I5,12F12.5)")IL(L),JL(L),HBED1(L,KBT(L)),HBED(L,KBT(L)), & + BELV1(L),BELV(L),DELT,QSBDTOP(L),QWBDTOP(L),HBEDA(L) WRITE(8,"('NEG DEPTH DUE TO MORPH CHANGE', 2I5,12F12.5)")L,KBT(L),(HBED(L,K),K=1,KBT(L)) ELSE HP(L)=0.9*HDRY diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_sedic.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_sedic.f90 index 5f4250cfc..e5a1ce685 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_sedic.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_sedic.f90 @@ -1,12 +1,11 @@ SUBROUTINE SEDIC USE GLOBAL IMPLICIT NONE - INTEGER::CORE,I,INCORE,J,L,LL,M,K,NS,VAR_BED,NSCICM,FDIR,NWV + INTEGER::CORE,I,INCORE,J,L,LL,M,K,NS,VAR_BED,FDIR,NWV INTEGER::IWV,JWV,NSKIP CHARACTER(LEN=80)::STR_LINE !PT- real values are written in DOUBLE PRECISION. 7/16/08 - DOUBLE PRECISION::BLKTMP,STWVHTMP,STWVTTMP,STWVDTMP - DOUBLE PRECISION,DIMENSION(10)::PTEMP + DOUBLE PRECISION::STWVHTMP,STWVTTMP,STWVDTMP DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:)::BDEN !(INCORE,KB) DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:)::TAUTEMP !(KB) DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:)::PNEW !(INCORE,KB,NSCM) @@ -197,7 +196,7 @@ SUBROUTINE SEDIC !READ (10,'(A80)') STR_LINE !READ(10,*) (TSED0S(LL),LL=1,KB) FORALL(LL=1:2)BEDLINIT(2:LA,LL)=0.0 - FORALL(LL=3:KB)BEDLINIT(2:LA,LL)=0.01*MAX(1D-12,TSED0S(LL)) + FORALL(LL=3:KB)BEDLINIT(2:LA,LL)=REAL(0.01*MAX(1E-12,TSED0S(LL)),KIND(BEDLINIT)) FORALL(LL=1:KB)HBED(2:LA,LL)=BEDLINIT(2:LA,LL) !************************************************************************** diff --git a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_sedzlj.f90 b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_sedzlj.f90 index 4f184965d..2029375a6 100644 --- a/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_sedzlj.f90 +++ b/model_efdc_dll/native/efdc_fortran_dll/original_efdc_files/s_sedzlj.f90 @@ -1,7 +1,7 @@ SUBROUTINE SEDZLJ(L) USE GLOBAL IMPLICIT NONE - INTEGER::KK,LL,K,L + INTEGER::LL,K,L INTEGER::NSC0,NSC1,NTAU0,NTAU1 REAL::T1TMP, T2TMP DOUBLE PRECISION::WDTDZ @@ -9,12 +9,16 @@ SUBROUTINE SEDZLJ(L) DOUBLE PRECISION::SN01 DOUBLE PRECISION::SN10 DOUBLE PRECISION::SN11 - DOUBLE PRECISION,DIMENSION(NSCM)::PX,PY,PFY,PROB,SMASS,MASSPCB,CSEDSS + DOUBLE PRECISION,DIMENSION(NSCM)::PX,PY,PFY,PROB,SMASS,CSEDSS DOUBLE PRECISION::D50TMPP,TEMP,TEMP2 DOUBLE PRECISION::ESED INTEGER CRAIG INTEGER SURFACE + NTAU0=0 + NTAU1=0 + NSC0=0 + NSC1=0 IF(IS_TIMING)THEN CALL CPU_TIME(T1TMP) @@ -149,13 +153,13 @@ SUBROUTINE SEDZLJ(L) SURFACE=SLLN(L) !otherwise the top layer is SLLN ENDIF D50AVG(L)=SUM(PER(1:NSCM,SURFACE,L)*D50(1:NSCM)) !calculate local d50 at sediment bed surface - FORALL(LL=1:KB)SEDDIA50(L,LL)=SUM(PER(1:NSCM,LL,L)*D50(1:NSCM)) !EFDC variable + FORALL(LL=1:KB)SEDDIA50(L,LL)=REAL(SUM(PER(1:NSCM,LL,L)*D50(1:NSCM)),KIND(SEDDIA50)) !EFDC variable ! Identify Size Class interval to use for Taucrit erosion calculation DO K=1,NSICM-1 IF(D50AVG(L)>=SCND(K).AND.D50AVG(L)=SCND(K).AND.D50AVG(L)