mod_par.f90

Go to the documentation of this file.

!/===========================================================================/
! Copyright (c) 2007, The University of Massachusetts Dartmouth 
! Produced at the School of Marine Science & Technology 
! Marine Ecosystem Dynamics Modeling group
! All rights reserved.
!
! FVCOM has been developed by the joint UMASSD-WHOI research team. For 
! details of authorship and attribution of credit please see the FVCOM
! technical manual or contact the MEDM group.
!
! 
! This file is part of FVCOM. For details, see http://fvcom.smast.umassd.edu 
! The full copyright notice is contained in the file COPYRIGHT located in the 
! root directory of the FVCOM code. This original header must be maintained
! in all distributed versions.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 
! AND ANY EXPRESS OR  IMPLIED WARRANTIES, INCLUDING,  BUT NOT  LIMITED TO,
! THE IMPLIED WARRANTIES OF MERCHANTABILITY AND  FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED.  
!
!/---------------------------------------------------------------------------/
! CVS VERSION INFORMATION
! $Id$
! $Name$
! $Revision$
!/===========================================================================/

MODULE mod_par  
   USE mod_types
   USE mod_utils
   USE lims, ONLY : ngl, mgl
   USE mod_time, ONLY : mpi_time
   IMPLICIT NONE
   SAVE

!
!--Global Information
!
   INTEGER, POINTER :: el_pid(:)         !!PROCESSOR OWNER OF GLOBAL ELEMENT

   INTEGER, POINTER :: elid(:)    !!LOCAL VALUE OF GLOBAL ELEMENT
   INTEGER, POINTER :: nlid(:)    !!LOCAL VALUE OF GLOBAL NODE 
   INTEGER, POINTER :: elid_x(:)             !!LOCAL VALUE OF GLOBAL ELEMENT INCLUDING HALOS
   INTEGER, POINTER :: nlid_x(:)             !!LOCAL VALUE OF GLOBAL NODE INCLUDING HALOS 
!
!--Internal Information (Local)
!
   INTEGER, POINTER :: egid(:)    !!GLOBAL ID OF LOCAL ELEMENT
   INTEGER, POINTER :: ngid(:)    !!GLOBAL ID OF LOCAL NODE 
   INTEGER, POINTER :: egid_x(:)             !!GLOBAL ID OF LOCAL ELEMENT
   INTEGER, POINTER :: ngid_x(:)             !!GLOBAL ID OF LOCAL NODE 

!
!--Boundary Information: Halo Elements          
!
   INTEGER              :: nhe               !!NUMBER OF HALO ELEMENTS
   INTEGER, POINTER :: he_lst(:)         !!GLOBAL IDENTITIES OF HALO ELEMENTS
   INTEGER, POINTER :: he_own(:)         !!OWNER OF HALO ELEMENTS

!
!--Boundary Information: Internal Boundary Nodes
!
   INTEGER :: nbn                            !!NUMBER OF BOUNDARY NODES
   INTEGER :: mx_mlt                         !!MAX MULTIPLICITY OF BOUNDARY NODES
   INTEGER, POINTER :: bn_lst(:)         !!GLOBAL IDENTITY OF BOUNDARY NODES
   INTEGER, POINTER :: bn_loc(:)         !!LOCAL IDENTITY OF BOUNDARY NODES
   INTEGER, POINTER :: bn_mlt(:)         !!MULTIPLICITY OF BOUNDARY NODES
   INTEGER, POINTER :: bn_ney(:,:)       !!NODE OWNER LIST
   INTEGER, POINTER :: nde_id(:)         !! = 0 IF INTERNAL, 1 IF ON INTERNAL BOUNDARY

!
!--Boundary Information: Halo Nodes
!
   INTEGER :: nhn  !!NUMBER OF HALO NODES
   INTEGER, POINTER :: hn_lst(:)         !!LIST OF HALO NODES 
   INTEGER, POINTER :: hn_own(:)         !!PRIMARY OWNER OF HALO NODES


   INTERFACE pprint
      MODULE PROCEDURE pprint_arr
      MODULE PROCEDURE pprint_vec
   END INTERFACE

   INTERFACE aprint
      MODULE PROCEDURE aprint_arr
      MODULE PROCEDURE aprint_vec
   END INTERFACE
!===================================================================================|
   CONTAINS   !!INCLUDED SUBROUTINES FOLLOW
!===================================================================================|

!==============================================================================|
!  WRITE OUT VARIABLE INFORMATION TO LOCAL FILES                               |
!                                          |
!  USAGE EXAMPLES                                                              |
!                                          |
!  write u velocity at surface in triangle 256 to file fort.306 with iteration |
!  I1 = LBOUND(U,1) ; I2 = UBOUND(U,1)                                         |
!  CALL PPRINT(306,I1,I2,KB,U,"element",256,1,1,FLOAT(IINT))                   |
!                                          |
!  I1 = LBOUND(EL,1) ; I2 = UBOUND(EL,1)                                       |
!  write surface elevation at node 233 to file fort.409 with time in hours     |
!  CALL PPRINT(406,I1,I2,1,EL,"node",233,1,1,THOUR)                            |
!                                          |
!  I1 = LBOUND(T1,1) ; I2 = UBOUND(T1,1)                                       |
!  write vertical distribution of salinity at node 422 to file fort.433        |
!  CALL PPRINT(433,I1,I2,KB,T1,"node",422,1,KBM1,THOUR)                        |
!                                          |
!  ARGUMENT LIST                                                               |
!       PPRINT(IUNIT,LB1,UB1,UB2,VARP,VART,ILOC,K1,K2,REF)                     |
!    1.) IUNIT - UNIT NUMBER FOR OUTPUT FILE (MUST BE >= 300 .and. <7000)      |
!    2.) LB1   - LOWER BOUND OF 1ST ARGUMENT OF ARRAY TO PRINT (USUAlLY 0)     |
!    3.) LB2   - UPPER BOUND OF 1ST ARRAY DIMENSION (USUALLY NT OR MT)         |
!        NOTE: LB1/LB2 CAN BE DETERMINE AUTOMATICALLY WITH LBOUND/UBOUND       |
!    4.) UB2   - UPPER BOUND OF SECOND ARRAY DIMENSION                         | 
!        UB2   = 1 FOR SURFACE ARRAYS LIKE EL,UA                               |
!        UB2   = KB FOR 3D ARRAYS LIKE U/V                                     |
!    5.) VARP  = VARIABLE TO PRINT (ARRAY NAME = U,V,WW,EL,T1,RHO1, etc)       |
!    6.) VART  = VARIABLE LOCATION ("element" or "node")                       |
!    7.) ILOC  = INDEX OF ELEMENT/NODE TO PRINT                                | 
!    8.) K1    = LOWER RANGE OF SIGMA LEVEL TO PRINT                           |
!    9.) K2    = UPPER RANGE OF SIGMA LEVEL TO PRINT                           |
!        K1 = 1,K2 = 1 FOR SURFACE VALUES ONLY                                 |
!        K1 = 1,K2 = KBM1 FOR ALL LEVELS                                       |
!   10.) REF   = REFERENCE VALUE FOR DATA (MUST BE FLOAT)                      |
!        REF = THOURS FOR CALCULATION TIME IN HOURS                            |
!        REF = FLOAT(IINT) FOR ITERATION NUMBER                                |
!   11.) IPT = UNIT TO WRITE ERRORS TO (USE IPT)                               |
!==============================================================================|

!==============================================================================|
   SUBROUTINE aprint_vec(IUNIT,VARP,VART,NOW,ILOC,MSG)
     USE mod_time
     IMPLICIT NONE
     TYPE(time), INTENT(IN) :: NOW
     INTEGER,  INTENT(IN) :: IUNIT,ILOC
     REAL(SP), ALLOCATABLE, INTENT(IN),TARGET :: VARP(:)
     CHARACTER(LEN=*), INTENT(IN) :: VART
     CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: MSG
     REAL(SP), POINTER:: VARP_O(:)
     
     varp_o =>  varp
     
     IF(PRESENT(msg))THEN
        CALL pprint_vec(iunit,varp_o,vart,now,iloc,msg)
     ELSE
        CALL pprint_vec(iunit,varp_o,vart,now,iloc)
     END IF

   END SUBROUTINE aprint_vec
   
!==============================================================================|
   SUBROUTINE pprint_vec(IUNIT,VARP,VART,NOW,ILOC,MSG)
     USE control
     USE lims

     IMPLICIT NONE
     TYPE(time), INTENT(IN) :: NOW
     INTEGER,  INTENT(IN) :: IUNIT,ILOC
     REAL(SP), POINTER, INTENT(IN) :: VARP(:)
     CHARACTER(LEN=*), INTENT(IN) :: VART
     CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: MSG

     CHARACTER(LEN=80),parameter :: VAR_E = "element"
     CHARACTER(LEN=80),parameter :: VAR_N = "node"

     CHARACTER(LEN=100) :: STRNG
     CHARACTER(LEN=20) :: short

     INTEGER :: I,J,K,PROCMAX,II,IBND,Kopt,IERR
     LOGICAL :: PRINT_PROC

     !==============================================================================|

     !------------------------------------------------------------------------------|
     !  Process Iunit for Errors                                                    |
     !------------------------------------------------------------------------------|
     IF(iunit /= ipt .and. (iunit < 300 .or. iunit > 7000) )THEN
        CALL fatal_error('ERROR IN PPRINT',&
             & 'FILE UNIT < 300 AND UNIT > 7000 ARE RESERVED FOR FVCOM I/O',&
             & 'PLEASE INCREASE IUNIT TO 300+')
     END IF

     !------------------------------------------------------------------------------|
     !  Process Vartype for Errors                                                  |
     !------------------------------------------------------------------------------|
     IF(vart /= var_e .AND. vart /= var_n)THEN
        CALL fatal_error('VART IN PPRINT NOT CORRECT :'//trim(vart),&
             & 'SHOULD BE "'//trim(var_e)//'" or "'//trim(var_n)//'"')
     END IF


     !------------------------------------------------------------------------------|
     !  Process string output                                                       |
     !------------------------------------------------------------------------------|
     IF(PRESENT(msg)) strng=trim(msg)//"; IINT"


     IF(abs(iint) .lt. 1000) THEN
        WRITE(short,'(I5)') iint
     ELSE IF(abs(iint) .lt. 1000000) THEN
        WRITE(short,'(I8)') iint
     ELSE
        WRITE(short,*) iint
     END IF

     IF(use_real_world_time) THEN
        strng = trim(strng)//trim(short)//", Date/Time:"&
             &//trim(write_datetime(now,3,timezone))//"; ILOC= "
     ELSE
        strng = trim(strng)//trim(short)//", Time(s):"
        WRITE(short,'(f16.8)') seconds(now)
        strng = trim(strng)//trim(short)//"; ILOC="
     END IF

     WRITE(short,'(I8)') iloc
     strng = trim(strng)//trim(short)//"; VALUE="

     !------------------------------------------------------------------------------|
     !  Single Processor Case                                                       |
     !------------------------------------------------------------------------------|
     IF(nprocs == 1)THEN
        WRITE(iunit,*) trim(strng),varp(iloc)
     END IF

     !------------------------------------------------------------------------------|
     !  Multi Processor Case with Element Based Variable (u,v,ww, etc)              |
     !      Transform to Local Element ID with "ELID"                               |
     !------------------------------------------------------------------------------|

     IF(nprocs /= 1 .AND. vart == var_e .AND. elid(iloc) /= 0)THEN

        WRITE(iunit,*) trim(strng),varp(elid(iloc))

     END IF

     !------------------------------------------------------------------------------|
     !  Multi Processor Case with Node Based Variable (s1,t1,rho1,e1, etc)          |
     !      Transform to Local Node ID with "NLID"                                  |
     !      If Node is Interprocessor Boundary Node, Choose Processor with Highest  |
     !      ID Number to Write Values to File                                       |
     !------------------------------------------------------------------------------|

     IF(nprocs /= 1 .AND. vart == var_n .AND. nlid(iloc) > 0)THEN

        print_proc = .true.
        IF(nde_id(nlid(iloc)) == 1)THEN   !!BOUNDARY NODE

           DO ii=1,nbn
              IF(bn_lst(ii) == iloc) ibnd = ii
           END DO

           procmax = 10000
           DO j=1,nprocs
              IF(bn_ney(ibnd,j)==1) THEN
                 IF(j < procmax) procmax = j
              END IF
           END DO

           IF(procmax /=  myid) print_proc = .false.  !!NOT RESPONSIBLE FOR OUTPUT 
        END IF

        IF(print_proc)THEN
           WRITE(iunit,*) trim(strng),varp(nlid(iloc))       
        END IF

     END IF



     RETURN
   END SUBROUTINE pprint_vec
!==============================================================================|
!==============================================================================|
   SUBROUTINE aprint_arr(IUNIT,VARP,VART,NOW,ILOC,K1,K2,MSG)
     USE mod_time
     IMPLICIT NONE
     TYPE(time), INTENT(IN) :: NOW
     INTEGER,  INTENT(IN) :: IUNIT,ILOC,K1
     INTEGER,  INTENT(IN),OPTIONAL :: K2
     REAL(SP), ALLOCATABLE, INTENT(IN),TARGET :: VARP(:,:)
     CHARACTER(LEN=*), INTENT(IN) :: VART
     CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: MSG
     REAL(SP), POINTER:: VARP_O(:,:)
     
     varp_o =>  varp
     
     IF (PRESENT(k2)) THEN
        IF(PRESENT(msg))THEN
           CALL pprint_arr(iunit,varp_o,vart,now,iloc,k1,k2,msg)
        ELSE
           CALL pprint_arr(iunit,varp_o,vart,now,iloc,k1,k2)
        END IF
     ELSE
        IF(PRESENT(msg))THEN
           CALL pprint_arr(iunit,varp_o,vart,now,iloc,k1,k1,msg)
        ELSE
           CALL pprint_arr(iunit,varp_o,vart,now,iloc,k1)
        END IF
     END IF
   END SUBROUTINE aprint_arr
   
!==============================================================================|
   SUBROUTINE pprint_arr(IUNIT,VARP,VART,NOW,ILOC,K1,K2,MSG)
     USE control
     USE lims

     IMPLICIT NONE
     TYPE(time), INTENT(IN) :: NOW
     INTEGER,  INTENT(IN) :: IUNIT,ILOC,K1
     INTEGER,  INTENT(IN),OPTIONAL :: K2
     REAL(SP), POINTER, INTENT(IN) :: VARP(:,:)
     CHARACTER(LEN=*), INTENT(IN) :: VART
     CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: MSG

     CHARACTER(LEN=80),parameter :: VAR_E = "element"
     CHARACTER(LEN=80),parameter :: VAR_N = "node"

     CHARACTER(LEN=100) :: STRNG
     CHARACTER(LEN=20) :: short

     INTEGER :: I,J,K,PROCMAX,II,IBND,Kopt,IERR
     LOGICAL :: PRINT_PROC

     !==============================================================================|

     !------------------------------------------------------------------------------|
     !  Process Iunit for Errors                                                    |
     !------------------------------------------------------------------------------|
     IF(iunit /= ipt .and. (iunit < 300 .or. iunit > 7000) )THEN
        CALL fatal_error('ERROR IN PPRINT',&
             & 'FILE UNIT < 300 AND UNIT > 7000 ARE RESERVED FOR FVCOM I/O',&
             & 'PLEASE INCREASE IUNIT TO 300+')
     END IF

     !------------------------------------------------------------------------------|
     !  Process Vartype for Errors                                                  |
     !------------------------------------------------------------------------------|
     IF(vart /= var_e .AND. vart /= var_n)THEN
        CALL fatal_error('VART IN PPRINT NOT CORRECT :'//trim(vart),&
             & 'SHOULD BE "'//trim(var_e)//'" or "'//trim(var_n)//'"')
     END IF

     !------------------------------------------------------------------------------|
     !  Process optional sigma level range                                          |
     !------------------------------------------------------------------------------|

     IF(PRESENT(k2)) THEN
        kopt=k2
     ELSE
        kopt=k1
     END IF

     !------------------------------------------------------------------------------|
     !  Process string output                                                       |
     !------------------------------------------------------------------------------|
     IF(PRESENT(msg)) strng=trim(msg)//"; IINT"


     IF(abs(iint) .lt. 1000) THEN
        WRITE(short,'(I5)') iint
     ELSE IF(abs(iint) .lt. 1000000) THEN
        WRITE(short,'(I8)') iint
     ELSE
        WRITE(short,*) iint
     END IF

     IF(use_real_world_time) THEN
        strng = trim(strng)//trim(short)//", Date/Time:"&
             &//trim(write_datetime(now,3,timezone))//"; ILOC "
     ELSE
        strng = trim(strng)//trim(short)//", Time(s):"
        WRITE(short,'(f16.8)') seconds(now)
        strng = trim(strng)//trim(short)//"; ILOC="
     END IF

     WRITE(short,'(I8)') iloc
     strng = trim(strng)//trim(short)//"; VALUES="
     !------------------------------------------------------------------------------|
     !  Single Processor Case                                                       |
     !------------------------------------------------------------------------------|
     IF(nprocs == 1)THEN
        WRITE(iunit,*) trim(strng)
        WRITE(iunit,*) (varp(iloc,k),k=k1,kopt)
     END IF

     !------------------------------------------------------------------------------|
     !  Multi Processor Case with Element Based Variable (u,v,ww, etc)              |
     !      Transform to Local Element ID with "ELID"                               |
     !------------------------------------------------------------------------------|

     IF(nprocs /= 1 .AND. vart == var_e .AND. elid(iloc) /= 0)THEN

        WRITE(iunit,*) trim(strng)
        WRITE(iunit,*) (varp(elid(iloc),k),k=k1,kopt)

     END IF

     !------------------------------------------------------------------------------|
     !  Multi Processor Case with Node Based Variable (s1,t1,rho1,e1, etc)          |
     !      Transform to Local Node ID with "NLID"                                  |
     !      If Node is Interprocessor Boundary Node, Choose Processor with Highest  |
     !      ID Number to Write Values to File                                       |
     !------------------------------------------------------------------------------|

     IF(nprocs /= 1 .AND. vart == var_n .AND. nlid(iloc) > 0)THEN

        print_proc = .true.
        IF(nde_id(nlid(iloc)) == 1)THEN   !!BOUNDARY NODE

           DO ii=1,nbn
              IF(bn_lst(ii) == iloc) ibnd = ii
           END DO

           procmax = 10000
           DO j=1,nprocs
              IF(bn_ney(ibnd,j)==1) THEN
                 IF(j < procmax) procmax = j
              END IF
           END DO

           IF(procmax /=  myid) print_proc = .false.  !!NOT RESPONSIBLE FOR OUTPUT 
        END IF

        IF(print_proc)THEN
           WRITE(iunit,*) trim(strng)
           WRITE(iunit,*) (varp(nlid(iloc),k),k=k1,kopt)        
        END IF

     END IF


     RETURN
   END SUBROUTINE pprint_arr
!==============================================================================|

END MODULE mod_par