ecrspe.f

Go to the documentation of this file.

!                   *****************
                    SUBROUTINE ecrspe
!                   *****************
!
     &( f     , ndire , nf    , npoin2, lt ,    auxil ,
     &  noleo , nleo  , debres, date  , time  , knolg , mesh)
!
!***********************************************************************
! TOMAWAC   V6P3                                   15/06/2011
!***********************************************************************
!
!brief    WRITES OUT THE DIRECTIONAL VARIANCE SPECTRUM
!+                AT SELECTED NODES.
!+                (SERAPHIN BINARY FORMAT).
!
!history  OPTIMER
!+        28/08/2000
!+        V5P0
!+   CREATED
!
!history
!+        07/06/2001
!+        V5P2
!+
!
!history  M. BENOIT
!+        13/07/2004
!+        V5P5
!+   CORRECTED A BUG IN THE DECLARATION OF IPOBO WHEN PASSED
!
!history
!+
!+        V6P0
!+
!
!history  N.DURAND (HRW), S.E.BOURBAN (HRW)
!+        13/07/2010
!+        V6P0
!+   Translation of French comments within the FORTRAN sources into
!+   English comments
!
!history  N.DURAND (HRW), S.E.BOURBAN (HRW)
!+        21/08/2010
!+        V6P0
!+   Creation of DOXYGEN tags for automated documentation and
!+   cross-referencing of the FORTRAN sources
!
!history  G.MATTAROLO (EDF - LNHE)
!+        15/06/2011
!+        V6P1
!+   Translation of French names of the variables in argument
!
!history  A. LAUGEL & J-M HERVOUET (EDF - LNHE)
!+        22/11/2012
!+        V6P3
!+   Parallelism treated with files.
!
!history  E. GAGNAIRE-RENOU (EDF - LNHE)
!+        12/03/2013
!+        V6P3
!+   Print out the 1D frequential spectrum at (same) selected nodes.
!+   Scopgene format.
!
!history Y AUDOUIN (LNHE)
!+       25/05/2015
!+       V7P0
!+       Modification to comply with the hermes module
!
!history A JOLY (LNHE)
!+       16/02/2017
!+       V7P3
!+   In some instances, PROXIM could find a node in only one processor
!+   domain (and therefore NOLEO), but MESH%ELTCAR was in another.
!+   This case is now taken into account.
!
!history  J,RIEHME (ADJOINTWARE)
!+        November 2016
!+        V7P2
!+   Replaced EXTERNAL statements to parallel functions / subroutines
!+   by the INTERFACE_PARALLEL
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!| AUXIL          |<->| DIRECTIONAL SPECTRUM WORK TABLE
!| DATE           |-->| START DATE
!| DEBRES         |-->| LOGICAL INDICATING THE FIRST TIME STEP TO PRINT
!| F              |-->| VARIANCE DENSITY DIRECTIONAL SPECTRUM
!| ISLEO          |-->| ARRAY OF LOGICAL
!| KNOLG          |-->| ARRAY LINKING LOCAL TO GLOBAL INDEXES IN PARALL
!| NF             |-->| NUMBER OF FREQUENCIES
!| NK             |-->| DUMMY VARIABLE
!| NLEO           |-->| NUMBER OF SPECTRUM PRINTOUT POINTS
!| NOLEO          |-->| INDEX ARRAY OF SPECTRUM PRINTOUT POINTS
!| NDIRE          |-->| NUMBER OF DIRECTIONS
!| NPOIN2         |-->| NUMBER OF POINTS IN 2D MESH
!| TIME           |-->| START TIME
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
      USE bief
!
      USE interface_hermes
      USE declarations_tomawac, ONLY : deupi,stra31,stra32, teta, freq,
     &    titcas, at, luspe, namspe, luleo, fmtleo, namleo
!
      USE declarations_special
      USE interface_parallel, ONLY : p_max,p_sum
      IMPLICIT NONE
!
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER, INTENT(IN)             :: NPOIN2,NLEO,NF,NDIRE, LT
      INTEGER, INTENT(IN)             :: KNOLG(*),  NOLEO(nleo)
      INTEGER, INTENT(IN)             :: DATE(3),TIME(3)
      DOUBLE PRECISION, INTENT(INOUT) :: AUXIL(ndire,nf)
      DOUBLE PRECISION, INTENT(IN)    :: F(npoin2,ndire,nf)
      LOGICAL, INTENT(IN)             :: DEBRES
      TYPE(bief_mesh), INTENT(INOUT)  :: MESH
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER  ISTAT , II    , JF    , K    , II_ALL
      INTEGER  KAMP1 , KAMP2 , KAMP3 , KAMP4 , KAMP5 , KAMP6 , ILEO
      INTEGER  IBID(1), NELEM, NPSPE
      CHARACTER(LEN=72) C
      CHARACTER(LEN=32) TEXTE(nleo)
      CHARACTER(LEN=6)  NUM
      CHARACTER(LEN=5)  CC
      CHARACTER(LEN=1)  C1,C2,C3,C4,C5,C6
      INTEGER NUM1, NUM2, NUM3, NUM4, NUM5
      TYPE(bief_mesh) MESHF
      LOGICAL         SORLEO(nleo)
      DOUBLE PRECISION DTETAR
      REAL W(1)
      CHARACTER(LEN=11) EXTENS
      EXTERNAL          extens
      INTEGER :: ID
!
      DOUBLE PRECISION, ALLOCATABLE :: F_INTF(:,:)
!
!-----------------------------------------------------------------------
!
      dtetar=deupi/dble(ndire)
      npspe=nf*ndire
      nelem=(nf-1)*ndire
!     SORLEO = .FALSE.
      DO ileo=1,nleo
        kamp1=noleo(ileo)
        IF(ncsize.GT.1) THEN
          IF(kamp1.GT.0) kamp1=knolg(noleo(ileo))
          kamp1=p_max(kamp1)
        ENDIF
        kamp2=mod(kamp1,100000)
        kamp3=mod(kamp2,10000)
        kamp4=mod(kamp3,1000)
        kamp5=mod(kamp4,100)
        kamp6=mod(kamp5,10)
        c1=char(48+kamp1/100000)
        c2=char(48+kamp2/10000)
        c3=char(48+kamp3/1000)
        c4=char(48+kamp4/100)
        c5=char(48+kamp5/10)
        c6=char(48+kamp6)
        num=c1//c2//c3//c4//c5//c6
        ! Number of frequence
        num1=ileo
        num2=mod(num1,10000)
        num3=mod(num2,1000)
        num4=mod(num3,100)
        num5=mod(num4,10)
        c1=char(48+num1/10000)
        c2=char(48+num2/1000)
        c3=char(48+num3/100)
        c4=char(48+num4/10)
        c5=char(48+num5)
        cc=c1//c2//c3//c4//c5
        texte(ileo)='F'//cc//'PT2D'//num//'UNITE SI       '
        sorleo(ileo) = .true.
      ENDDO
!
!     FOR THE FIRST PRINTED TIME STEP, WRITES OUT THE HEADER TO THE FILE
!
      ALLOCATE(f_intf(nleo,nf))
      IF(debres) THEN
!
!     IN PARALLEL ONLY PROCESSOR 0 CREATES THE FILE
!
        IF(ipid.EQ.0) THEN
!
!       CREATES MESHF, MESH ASSOCIATED WITH DISCRETISATION
!       IN FREQUENCY AND DIRECTION
!
          ALLOCATE(meshf%TYPELM)
          ALLOCATE(meshf%NELEM)
          ALLOCATE(meshf%NPOIN)
          ALLOCATE(meshf%IKLE)
          ALLOCATE(meshf%IKLE%I(4*nelem))
          ALLOCATE(meshf%X)
          ALLOCATE(meshf%Y)
          ALLOCATE(meshf%NPTFR)
          ALLOCATE(meshf%NBOR)
          ALLOCATE(meshf%NBOR%I(2*ndire))
          ALLOCATE(meshf%DIM1)
          ALLOCATE(meshf%KNOLG)
          ALLOCATE(meshf%KNOLG%I(ndire*nf))
          ALLOCATE(meshf%X_ORIG)
          ALLOCATE(meshf%Y_ORIG)
!
!
          meshf%NAME = 'MESH'
          meshf%TYPELM = quadrangle_elt_type !TRIANGLE 2D MESH
          meshf%NELEM  = nelem
          meshf%NPOIN  = npspe
          meshf%DIM1   = 2
          meshf%X_ORIG = 0
          meshf%Y_ORIG = 0
          ii=0
          DO jf=1,nf-1
            DO k=1,ndire
              ii=ii+1
              meshf%IKLE%I(ii)=mod(ii,ndire)+1+(jf-1)*ndire
            ENDDO
          ENDDO
          DO ii=1,nelem
            meshf%IKLE%I(ii+nelem)=ii
            meshf%IKLE%I(ii+2*nelem)=ii+ndire
            meshf%IKLE%I(ii+3*nelem)=meshf%IKLE%I(ii)+ndire
          ENDDO
!
!       WRITES OUT THE ARRAYS X AND Y
!
          ALLOCATE(meshf%X%R(ndire*nf))
          ALLOCATE(meshf%Y%R(ndire*nf))
          meshf%NPTFR = 2*ndire
          DO jf=1,nf
            DO ii=1,ndire
              meshf%X%R(ii+ndire*(jf-1))=freq(jf)*sin(teta(ii))
              meshf%Y%R(ii+ndire*(jf-1))=freq(jf)*cos(teta(ii))
            ENDDO
          ENDDO
          meshf%NBOR%I=0
          DO ii = 1,ndire
            meshf%NBOR%I(ii) = ii
          ENDDO
          DO ii = ndire+1,2*ndire
            meshf%NBOR%I(ii)=ndire+1+npspe-ii
          ENDDO
          meshf%KNOLG%I = 0
          ALLOCATE(meshf%NDS(0:81,7))
          meshf%TYPELM = quadrangle_elt_type
          meshf%NDS(meshf%TYPELM+1,3) = 4

!
!         CREATES DATA FILE USING A GIVEN FILE FORMAT : FORMAT_RES.
!         THE DATA ARE CREATED IN THE FILE: NRES, AND IS
!         CHARACTERISED BY A TITLE AND NAME OF OUTPUT VARIABLES
!         CONTAINED IN THE FILE.
!
          IF (namleo(1:1).NE.' ') THEN
            CALL write_header(fmtleo, ! RESULTS FILE FORMAT
     &           luleo,          ! LU FOR RESULTS FILE
     &           titcas,        ! TITLE
     &           nleo,          ! MAX NUMBER OF OUTPUT VARIABLES
     &           texte,         ! NAMES OF OUTPUT VARIABLES
     &           sorleo)        ! PRINT TO FILE OR NOT

!
!         WRITES THE MESH IN THE OUTPUT FILE
!
            CALL write_mesh(fmtleo, ! RESULTS FILE FORMAT
     &           luleo,          ! LU FOR RESULTS FILE
     &           meshf,
     &           1,             ! NUMBER OF PLANES
     &           date,          ! START DATE
     &           time,          ! START TIME
     &           stra31,stra32, !
     &           .false., 0) ! PARALL, NPTIR
          ENDIF
!
          IF(namspe(1:1).NE.' ') THEN
            WRITE(luspe,'(A1,A72)') '/', titcas
            WRITE(luspe,'(I3)') nleo
            DO ileo=1,nleo
              WRITE(luspe,'(A32)') texte(ileo)
            ENDDO
            WRITE(luspe,'(A19)') '0 0 0 0 0 0 0 0 0 0'
          ENDIF
          DEALLOCATE(meshf%TYPELM)
          DEALLOCATE(meshf%NELEM)
          DEALLOCATE(meshf%NPOIN)
          DEALLOCATE(meshf%IKLE%I)
          DEALLOCATE(meshf%IKLE)
          DEALLOCATE(meshf%X%R)
          DEALLOCATE(meshf%X)
          DEALLOCATE(meshf%Y%R)
          DEALLOCATE(meshf%Y)
          DEALLOCATE(meshf%NPTFR)
          DEALLOCATE(meshf%NBOR%I)
          DEALLOCATE(meshf%NBOR)
          DEALLOCATE(meshf%DIM1)
          DEALLOCATE(meshf%KNOLG%I)
          DEALLOCATE(meshf%KNOLG)
          DEALLOCATE(meshf%NDS)
!
        ENDIF

      ENDIF
!
!     RECORDS THE CURRENT TIME STEP
!
      IF (namspe(1:1).NE.' ') THEN
        IF(ipid.EQ.0) THEN
          WRITE(luspe,1008) at
        ENDIF
      ENDIF
1008  FORMAT('TIME  = ',f13.5)
!
      IF(ncsize.GT.1) THEN
        CALL get_free_id(id)
!
!       1) EVERY PROCESSOR WRITES ITS OWN POINTS
!       MESH%ELTCAR IS USED AS FOR THE CHARACTERISTICS
!
        DO ileo=1,nleo
          ii=noleo(ileo)
          ii_all=p_sum(ii)
          IF(ii.GT.0) THEN
            IF((mesh%ELTCAR%I(ii).NE.0).OR.
     &          (ii.EQ.ii_all)) THEN
              DO jf=1,nf
                DO k=1,ndire
                  auxil(k,jf)=f(ii,k,jf)
                ENDDO
              ENDDO
              OPEN(id,file=extens(nleo,ileo),
     &             form='UNFORMATTED',status='NEW')
              CALL ecri2(auxil,ibid,c,npspe,'R8',id,'STD',istat)
              CLOSE(id)
            ENDIF
          ENDIF
        ENDDO
!
!       WAITING COMPLETION OF THE WORK BY ALL PROCESSORS
!
        CALL p_sync
!
!       2) PROCESSOR 0 READS ALL FILES AND MERGES IN THE FINAL FILE
!
        IF(ipid.EQ.0) THEN
          IF (namleo(1:1).NE.' ') THEN
            DO ileo=1,nleo
              OPEN(id,file=extens(nleo,ileo),
     &                form='UNFORMATTED',status='OLD')
              CALL lit(auxil,w,ibid,c,npspe,'R8',id,'STD',istat)
              CALL add_data(fmtleo,luleo,texte(ileo),at,lt,ileo.EQ.1,
     &                      auxil,npspe,istat)
              CALL check_call(istat,'ECRSPE:ADD_DATA')
              CLOSE(id,status='DELETE')
              DO jf=1,nf
                f_intf(ileo,jf)=0.d0
                DO k=1,ndire
                  f_intf(ileo,jf)=f_intf(ileo,jf)+auxil(k,jf)*dtetar
                ENDDO
              ENDDO
            ENDDO
          ENDIF
          IF (namspe(1:1).NE.' ') THEN
            DO jf=1,nf
              WRITE(luspe,'(100(E10.4,2X))') freq(jf),
     &             (f_intf(ileo,jf),ileo=1,nleo)
            ENDDO
          ENDIF
        ENDIF
      ELSE
        IF (namleo(1:1).NE.' ') THEN
          DO ileo=1,nleo
            ii=noleo(ileo)
            DO jf=1,nf
              DO k=1,ndire
                auxil(k,jf)=f(ii,k,jf)
              ENDDO
            ENDDO
            CALL add_data(fmtleo,luleo,texte(ileo),at,lt,ileo.EQ.1,
     &                    auxil,npspe,istat)
            CALL check_call(istat,'ECRSPE:ADD_DATA')
          ENDDO
        ENDIF
        IF (namspe(1:1).NE.' ') THEN
          DO ileo=1,nleo
            ii=noleo(ileo)
            DO jf=1,nf
              f_intf(ileo,jf)=0.d0
              DO k=1,ndire
                f_intf(ileo,jf)=f_intf(ileo,jf)+f(ii,k,jf)*dtetar
              ENDDO
              IF(abs(f_intf(ileo,jf)).LT.1.d-90) f_intf(ileo,jf)=0.d0
            ENDDO
          ENDDO
          DO jf=1,nf
            WRITE(luspe,'(100(E10.4,2X))') freq(jf),
     &            (f_intf(ileo,jf),ileo=1,nleo)
          ENDDO
        ENDIF
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      DEALLOCATE(f_intf)
      RETURN
      END