get_tomspec_value2.f

Go to the documentation of this file.

!                   *****************************
                    SUBROUTINE get_tomspec_value2
!                   *****************************
!
     &(spec)
!
!***********************************************************************
! ARTEMIS   V7P3                                     Aug 2017
!***********************************************************************
!
!brief    READS IN THE TOMAWAC ENERGY SPECTRA.
!
!history  N.DURAND (HRW)
!+        09/03/2001
!+
!+   Original version
!
!history  T.ELLAM (HRW)
!+        13/03/2002
!+
!+   Modified to read in serafin format.spe
!
!history  N.DURAND (HRW)
!+        June 2014
!+
!+   Streamlined for V7P0
!
!history  N.DURAND (HRW)
!+        Feb 2017
!+        V7P2
!+   Revisited to use the hermes module
!+   Covers nesting option 2 only
!
!history  N.DURAND (HRW)
!+        August 2017
!+        V7P3
!+   DEGRAD now defined in DECLARATIONS_ARTEMIS
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!| SPEC           |<->| SPECTRUM STRUCTURE
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
      USE bief
      USE declarations_artemis
!
      USE declarations_special
      IMPLICIT NONE
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      TYPE(spectrum)   , INTENT(INOUT)        :: SPEC
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER                      :: IERR, I, IFF, IDD, ISPEC
      INTEGER                      :: NFIC, TYP
      INTEGER                      :: IDEC
      INTEGER                      :: RECORD
!
      DOUBLE PRECISION             :: EPS, DIST
      DOUBLE PRECISION,ALLOCATABLE :: X1(:),Y1(:),STOCK(:)
!
      CHARACTER(LEN=8)             :: FFORMAT
      CHARACTER(LEN=16),ALLOCATABLE :: VARNAME(:),VARUNIT(:)
!
      INTRINSIC dsqrt, datan, datan2
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      ALLOCATE(varname(spec%N),stat=ierr)
      CALL check_allocate(ierr,'GET_TOMSPEC_VALUE2:VARNAME')
      ALLOCATE(varunit(spec%N),stat=ierr)
      CALL check_allocate(ierr,'GET_TOMSPEC_VALUE2:VARUNIT')
!
      ALLOCATE(x1(nf*ndir),stat=ierr)
      CALL check_allocate(ierr,'GET_TOMSPEC_VALUE2:X1')
      ALLOCATE(y1(nf*ndir),stat=ierr)
      CALL check_allocate(ierr,'GET_TOMSPEC_VALUE2:Y1')
      ALLOCATE(stock(ndir),stat=ierr)
      CALL check_allocate(ierr,'GET_TOMSPEC_VALUE2:STOCK')
!
!=======================================================================
!
      nfic = art_files(wacspe)%LU
      fformat = art_files(wacspe)%FMT
!     THE SUPPORT MESH FOR TOMAWAC SPECTRA IS MADE OF QUADRANGLES
      typ = quadrangle_elt_type
!
!-----------------------------------------------------------------------
!
      IF(spec%N.GE.1) THEN
!
!       NODE NUMBER FOR EACH SPECTRUM/POINT IN SPEC
!
        CALL get_data_var_list(fformat,nfic,spec%N,varname,varunit,ierr)
        CALL check_call(ierr,'GET_TOMSPEC_VALUE2:GET_DATA_VAR_LIST')
        DO ispec=1,spec%N
          READ (varname(ispec)(9:16),'(I8)') spec%NOUTER(ispec)
        ENDDO
!
!       WITH NESTING OPTION 2, GEOGRAPHICAL COORDINATES OF THE SPECTRAL POINTS
!       IN THE TOMAWAC OUTER MESH ARE REQUIRED FOR INTERPOLATION PURPOSES
!       AND TO IDENTIFY NODE CLOSEST TO REQUESTED REFERENCE POINT
!
        CALL xy_tomawac(spec)
!
!       IDENTIFIES NODE CLOSEST TO REQUESTED REFERENCE POINT
!
        eps = 3000.d0
        n_sfref = 0
        DO ispec = 1,spec%N
          dist = dsqrt((spec%XOUTER(ispec)-x_sfref)**2 +
     &                 (spec%YOUTER(ispec)-y_sfref)**2 )
          IF(dist.LT.eps) THEN
            eps = dist
            n_sfref = ispec
          ENDIF
        ENDDO
!
        IF(n_sfref.EQ.0) THEN
          WRITE(lu,201) x_sfref, y_sfref
          DEALLOCATE(x1,y1,stock)
          DEALLOCATE(varname,varunit)
          CALL plante(1)
          stop
        ELSEIF(debug.GT.0) THEN
          WRITE(lu,*) 'GET_TOMSPEC_VALUE2: N_SFREF:',n_sfref
          WRITE(lu,*) '                  : NOUTER:',spec%NOUTER(n_sfref)
        ENDIF
!
!-----------------------------------------------------------------------
!
!       "X AND Y COORDINATES" OF THE SPECTRA IN SPEC
!
        CALL get_mesh_coord(fformat,nfic,1,2,nf*ndir,x1,ierr)
        CALL check_call(ierr,'GET_TOMSPEC_VALUE2:GET_MESH_COORD:X')
        CALL get_mesh_coord(fformat,nfic,2,2,nf*ndir,y1,ierr)
        CALL check_call(ierr,'GET_TOMSPEC_VALUE2:GET_MESH_COORD:Y')
!
!       COMPUTES THE DISCRETE FREQUENCIES FROM "X AND Y"
!
        DO i = 1,nf
          spec%FRE(i) = dsqrt(x1((i-1)*ndir+1)**2+y1((i-1)*ndir+1)**2)
!         IF(DEBUG.GT.0) WRITE(*,*) I,SPEC%FRE(I)
        ENDDO
!
!       COMPUTES THE DISCRETE DIRECTIONS FROM "X AND Y"
!       CONVENTION: FROM X, COUNTER-CLOCKWISE, TOWARDS
!       THE CALCULATION MEANS THAT DIRECTIONS ARE NO LONGER IN TOMAWAC CONVENTION
!       BUT RATHER DIRECTLY IN ARTEMIS CONVENTION
!
        DO i = 1,ndir
          spec%DIR(i) = datan2(y1(i),x1(i))
          spec%DIR(i) = spec%DIR(i)/degrad
!         IN RANGE [0;360]
          IF (spec%DIR(i).LT.0d0) THEN
            spec%DIR(i) = 360.d0 + spec%DIR(i)
          ENDIF
!         IF(DEBUG.GT.0) WRITE(*,*) I,SPEC%DIR(I)
        ENDDO
!
!       RE-ORDERS DIRECTIONS FROM 0 to 360
!       STARTS BY FINDING THE SMALLEST DIRECTION IN [0;360] => IDEC
        idec=0
        eps=360.d0
        DO i = 1,ndir
!         STOCKS THE DIRECTION
          stock(i)=spec%DIR(i)
          IF (spec%DIR(i).LT.eps) THEN
            idec=i
            eps=spec%DIR(i)
          ENDIF
        ENDDO
!
!       ORDERS SPEC%DIR FROM 0 to 360
        DO i = 1,ndir
          IF (i.GT.idec) THEN
            idd=ndir+idec-i+1
          ELSE
            idd=idec-i+1
          ENDIF
          spec%DIR(idd)=stock(i)
        ENDDO
        spec%DIR(ndir+1)=spec%DIR(1)+360.d0
!
!-----------------------------------------------------------------------
!
!       ENERGY DENSITIES FOR EACH SPECTRUM/POINT IN SPEC, AND FOR RECORD TPSTWC
!
        CALL get_data_timestep(fformat,nfic,record,tpstwc,ierr)
        CALL check_call(ierr,'GET_TOMSPEC_VALUE2:GET_DATA_TIMESTEP')
!
        DO ispec=1,nspec
!         IF(DEBUG.GT.0) WRITE(LU,*) VARNAME(ISPEC)
          CALL get_data_value(fformat,nfic,record,varname(ispec),x1,
     &                        nf*ndir,ierr)
          CALL check_call(ierr,'GET_TOMSPEC_VALUE2:GET_DATA_VALUE')
!
          DO iff=1,nf
            DO idd=1,ndir
              spec%ADR(ispec)%SOUTER(iff,idd) = x1((iff-1)*ndir+idd)
            ENDDO
!           CLOSING THE LOOP
            spec%ADR(ispec)%SOUTER(iff,ndir+1) =
     &                    spec%ADR(ispec)%SOUTER(iff,1)
          ENDDO
!
!         RE-ORDERS ENERGY DENSITIES
!         IN LINE WITH RE_ORDERING OF DIRECTIONS ABOVE
!
          DO iff = 1,nf
            DO i = 1,ndir
              stock(i)=spec%ADR(ispec)%SOUTER(iff,i)
            ENDDO
            DO i = 1,ndir
              IF (i.GT.idec) THEN
                idd=ndir+idec-i+1
              ELSE
                idd=idec-i+1
              ENDIF
              spec%ADR(ispec)%SOUTER(iff,idd)=stock(i)
            ENDDO
            spec%ADR(ispec)%SOUTER(iff,ndir+1) =
     &                    spec%ADR(ispec)%SOUTER(iff,1)
          ENDDO
!
        ENDDO  ! ISPEC=1,NSPEC
!
!=======================================================================
!
        DEALLOCATE(x1,y1,stock)
        DEALLOCATE(varname,varunit)
!
      ELSE
        WRITE(lu,101) art_files(wacspe)%NAME
        DEALLOCATE(varname,varunit)
        CALL plante(1)
        stop
!
      ENDIF  ! (SPEC%N.GE.1)
!
!-----------------------------------------------------------------------
!
!     PRINTOUT FORMATS:
!
      WRITE(lu,301) tpstwc
!
301   FORMAT(/,1x,'GET_TOMSPEC_VALUE2 : READING TIME STEP ',1f9.2,'S')
!
201   FORMAT(/,1x,'GET_TOMSPEC_VALUE2 : NO SPECTRAL POINT FOUND LESS',
     &       ' THAN 3KM FROM REFERENCE POINT (',1f9.2,';',1f9.2,')',/,
     &       'PLEASE REVIEW')
!
101   FORMAT(/,1x,'GET_TOMSPEC_VALUE2 : NO SPECTRAL POINT IN THE',
     &       ' TOMAWAC FILE ',1a30,';',/,
     &       'PLEASE REVIEW')
!
!-----------------------------------------------------------------------
!
!     USER DEFINED FUNCTION TOTNRJ FOR CHECKS ONLY
!
!     IF(DEBUG.GT.0) THEN
!       DO I=1,NSPEC
!         CALL TOTNRJ(SPEC,I)
!       ENDDO
!     ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
      END