ecrspe.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\tomawac\ecrspe.f
00002 !
00096                      SUBROUTINE ECRSPE
00097 !                    *****************
00098 !
00099      &( F     , TETA  , NPLAN , FREQ  , NF    , NK    ,
00100      &  NPOIN2, AT    , AUXIL , NOLEO , NLEO  , NSCO  ,
00101      &  BINSCO, DEBRES, TITCAS, DATE  , TIME  , KNOLG , MESH,
00102      &  NSPE  , TISPEF)
00103 !
00104 !***********************************************************************
00105 ! TOMAWAC   V6P3                                   15/06/2011
00106 !***********************************************************************
00107 !
00108 !
00109 !
00110 !
00111 !
00112 !
00113 !
00114 !
00115 !
00116 !
00117 !
00118 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00119 !| AT             |-->| COMPUTATION TIME
00120 !| AUXIL          |<->| DIRECTIONAL SPECTRUM WORK TABLE
00121 !| BINSCO         |-->| SPECTRUM FILE FORMAT
00122 !| DATE           |-->| START DATE
00123 !| DEBRES         |-->| LOGICAL INDICATING THE FIRST TIME STEP TO PRINT
00124 !| F              |-->| VARIANCE DENSITY DIRECTIONAL SPECTRUM
00125 !| FREQ           |-->| DISCRETIZED FREQUENCIES
00126 !| INUTIL         |<->| WORK TABLE
00127 !| ISLEO          |-->| ARRAY OF LOGICAL
00128 !| KNOLG          |-->| ARRAY LINKING LOCAL TO GLOBAL INDEXES IN PARALL
00129 !| NF             |-->| NUMBER OF FREQUENCIES
00130 !| NK             |-->| DUMMY VARIABLE
00131 !| NLEO           |-->| NUMBER OF SPECTRUM PRINTOUT POINTS
00132 !| NOLEO          |-->| INDEX ARRAY OF SPECTRUM PRINTOUT POINTS
00133 !| NPLAN          |-->| NUMBER OF DIRECTIONS
00134 !| NPOIN2         |-->| NUMBER OF POINTS IN 2D MESH
00135 !| NSCO           |-->| LOGICAL UNIT NUMBER OF THE PUNCTUAL RESULTS FILE
00136 !| TETA           |-->| DISRETIZED DIRECTION
00137 !| TIME           |-->| START TIME
00138 !| TITCAS         |-->| TITLE
00139 !| TISPEF         |-->| NAME OF THE 1D SPECTRA RESULTS FILE
00140 !| NSPE           |-->| LOGICAL UNIT NUMBER FOR THE 1D SPECTRA FILE
00141 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00142 !
00143       USE BIEF
00144 !
00145       USE DECLARATIONS_TOMAWAC, ONLY : DEUPI
00146 !
00147       IMPLICIT NONE
00148 !
00149       INTEGER LNG,LU
00150       COMMON/INFO/ LNG,LU
00151 !
00152 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00153 !
00154       INTEGER, INTENT(IN)             :: NPOIN2,NLEO,NSCO,NF,NK,NPLAN
00155       INTEGER, INTENT(IN)             :: KNOLG(NPOIN2)
00156       INTEGER, INTENT(IN)             :: NOLEO(NLEO)
00157       INTEGER, INTENT(IN)             :: DATE(3),TIME(3)
00158       DOUBLE PRECISION, INTENT(IN)    :: AT
00159       DOUBLE PRECISION, INTENT(INOUT) :: AUXIL(NPLAN,NK)
00160       DOUBLE PRECISION, INTENT(IN)    :: F(NPOIN2,NPLAN,NF)
00161       DOUBLE PRECISION, INTENT(IN)    :: TETA(NPLAN),FREQ(NF)
00162       LOGICAL, INTENT(IN)             :: DEBRES
00163       CHARACTER(LEN=72), INTENT(IN)   :: TITCAS
00164       CHARACTER(LEN=*) , INTENT(IN)   :: BINSCO
00165       TYPE(BIEF_MESH), INTENT(INOUT)  :: MESH
00166       CHARACTER(LEN=144), INTENT(IN)  :: TISPEF
00167       INTEGER, INTENT(IN)             :: NSPE
00168 !
00169 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00170 !
00171       INTEGER  ISTAT , II    , JF    , K
00172       INTEGER  KAMP1 , KAMP2 , KAMP3 , KAMP4 , KAMP5 , KAMP6 , ILEO
00173       INTEGER  IBID(1), NELEM, NPSPE
00174       CHARACTER(LEN=72) C
00175       CHARACTER(LEN=32) TEXTE(99)
00176       CHARACTER(LEN=6)  NUM
00177       CHARACTER(LEN=2)  CC
00178       CHARACTER(LEN=1)  C1,C2,C3,C4,C5,C6
00179       TYPE(BIEF_MESH) MESHF
00180       LOGICAL         SORLEO(99)
00181       DOUBLE PRECISION AAT(1),DTETAR
00182       REAL W(1)
00183       CHARACTER(LEN=11) EXTENS
00184       EXTERNAL          EXTENS
00185 !
00186       INTEGER  P_IMAX
00187       EXTERNAL P_IMAX
00188 !
00189       DOUBLE PRECISION, ALLOCATABLE :: F_INTF(:,:)
00190 !
00191       SAVE
00192 !
00193 !-----------------------------------------------------------------------
00194 !
00195       DTETAR=DEUPI/DBLE(NPLAN)
00196       NPSPE=NF*NPLAN
00197       NELEM=(NF-1)*NPLAN
00198 !     SORLEO = .FALSE.
00199       DO ILEO=1,NLEO
00200         KAMP1=NOLEO(ILEO)
00201         IF(NCSIZE.GT.1) THEN
00202           IF(KAMP1.GT.0) KAMP1=KNOLG(NOLEO(ILEO))
00203           KAMP1=P_IMAX(KAMP1)
00204         ENDIF
00205         KAMP2=MOD(KAMP1,100000)
00206         KAMP3=MOD(KAMP2,10000)
00207         KAMP4=MOD(KAMP3,1000)
00208         KAMP5=MOD(KAMP4,100)
00209         KAMP6=MOD(KAMP5,10)
00210         CC=CHAR(48+ILEO/10)//CHAR(48+MOD(ILEO,10))
00211         C1=CHAR(48+KAMP1/100000)
00212         C2=CHAR(48+KAMP2/10000)
00213         C3=CHAR(48+KAMP3/1000)
00214         C4=CHAR(48+KAMP4/100)
00215         C5=CHAR(48+KAMP5/10)
00216         C6=CHAR(48+KAMP6)
00217         NUM=C1//C2//C3//C4//C5//C6
00218         TEXTE(ILEO)='F'//CC//' PT2D'//NUM//'  UNITE SI       '
00219         SORLEO(ILEO) = .TRUE.
00220       ENDDO
00221 !
00222 !     FOR THE FIRST PRINTED TIME STEP, WRITES OUT THE HEADER TO THE FILE
00223 !
00224       IF(DEBRES) THEN
00225 !
00226 !       CREATES MESHF, MESH ASSOCIATED WITH DISCRETISATION
00227 !       IN FREQUENCY AND DIRECTION
00228 !
00229         ALLOCATE(MESHF%TYPELM)
00230         ALLOCATE(MESHF%NELEM)
00231         ALLOCATE(MESHF%NPOIN)
00232         ALLOCATE(MESHF%IKLE)
00233         ALLOCATE(MESHF%IKLE%I(4*NELEM))
00234         ALLOCATE(MESHF%X)
00235         ALLOCATE(MESHF%Y)
00236         ALLOCATE(MESHF%NPTFR)
00237         ALLOCATE(MESHF%NBOR)
00238         ALLOCATE(MESHF%NBOR%I(NPSPE))
00239         ALLOCATE(MESHF%DIM)
00240         ALLOCATE(MESHF%KNOLG)
00241         ALLOCATE(MESHF%KNOLG%I(NPSPE))
00242 !
00243         ALLOCATE(F_INTF(NLEO,NF))
00244 !
00245         MESHF%NAME = 'MESH'
00246         MESHF%TYPELM = 20 !QUADRANGLE 2D MESH
00247         MESHF%NELEM  = NELEM
00248         MESHF%NPOIN  = NPSPE
00249         MESHF%DIM    = 2
00250         II=0
00251         DO JF=1,NF-1
00252           DO K=1,NPLAN
00253            II=II+1
00254            MESHF%IKLE%I(II)=MOD(II,NPLAN)+1+(JF-1)*NPLAN
00255           ENDDO
00256         ENDDO
00257         DO II=1,NELEM
00258           MESHF%IKLE%I(II+NELEM)=II
00259           MESHF%IKLE%I(II+2*NELEM)=II+NPLAN
00260           MESHF%IKLE%I(II+3*NELEM)=MESHF%IKLE%I(II)+NPLAN
00261         ENDDO
00262 !
00263 !       WRITES OUT THE ARRAYS X AND Y
00264 !
00265         ALLOCATE(MESHF%X%R(NPLAN*NF))
00266         ALLOCATE(MESHF%Y%R(NPLAN*NF))
00267         MESHF%NPTFR = 2*NPLAN
00268         DO JF=1,NF
00269           DO II=1,NPLAN
00270             MESHF%X%R(II+NPLAN*(JF-1))=FREQ(JF)*SIN(TETA(II))
00271             MESHF%Y%R(II+NPLAN*(JF-1))=FREQ(JF)*COS(TETA(II))
00272           ENDDO
00273         ENDDO
00274         MESHF%NBOR%I=0
00275         DO II = 1,NPLAN
00276           MESHF%NBOR%I(II) = II
00277         ENDDO
00278         DO II = NPLAN+1,2*NPLAN
00279           MESHF%NBOR%I(II)=NPLAN+1+NPSPE-II
00280         ENDDO
00281         MESHF%KNOLG%I = 0
00282 !
00283 !       IN PARALLEL ONLY PROCESSOR 0 CREATES THE FILE
00284 !
00285         IF(IPID.EQ.0) THEN
00286 !
00287 !         CREATES DATA FILE USING A GIVEN FILE FORMAT : FORMAT_RES.
00288 !         THE DATA ARE CREATED IN THE FILE: NRES, AND IS
00289 !         CHARACTERISED BY A TITLE AND NAME OF OUTPUT VARIABLES
00290 !         CONTAINED IN THE FILE.
00291 !
00292           CALL CREATE_DATASET(BINSCO, ! RESULTS FILE FORMAT
00293      &                        NSCO,   ! LU FOR RESULTS FILE
00294      &                        TITCAS, ! TITLE
00295      &                        NLEO,   ! MAX NUMBER OF OUTPUT VARIABLES
00296      &                        TEXTE,  ! NAMES OF OUTPUT VARIABLES
00297      &                        SORLEO) ! PRINT TO FILE OR NOT
00298 !
00299 !         WRITES THE MESH IN THE OUTPUT FILE
00300 !
00301           CALL WRITE_MESH(BINSCO, ! RESULTS FILE FORMAT
00302      &                    NSCO,   ! LU FOR RESULTS FILE
00303      &                    MESHF,  ! CHARACTERISES MESH
00304      &                    1,      ! NUMBER OF PLANES
00305      &                    DATE,   ! START DATE
00306      &                    TIME,   ! START TIME
00307      &                    0,0)    ! COORDINATES OF THE ORIGIN.
00308 !
00309           IF(TISPEF(1:1).NE.' ') THEN
00310             WRITE(NSPE,'(A1,A72)') '/', TITCAS
00311             WRITE(NSPE,'(I3)') NLEO
00312             DO ILEO=1,NLEO
00313               WRITE(NSPE,'(A32)') TEXTE(ILEO)
00314             ENDDO
00315             WRITE(NSPE,'(A19)') '0 0 0 0 0 0 0 0 0 0'
00316           ENDIF
00317         ENDIF
00318 !
00319       ENDIF
00320 !
00321 !     RECORDS THE CURRENT TIME STEP
00322 !
00323       IF(IPID.EQ.0) THEN
00324         AAT(1) = AT
00325         CALL ECRI2(AAT,IBID,C,1,'R4',NSCO,'STD',ISTAT)
00326         IF(LNG.EQ.1) WRITE(NSPE,1007) AAT
00327         IF(LNG.EQ.2) WRITE(NSPE,1008) AAT
00328       ENDIF
00329 1007  FORMAT('TEMPS = ',F13.5)
00330 1008  FORMAT('TIME  = ',F13.5)
00331 !
00332       IF(NCSIZE.GT.1) THEN
00333 !
00334 !       1) EVERY PROCESSOR WRITES ITS OWN POINTS
00335 !          MESH%ELTCAR IS USED AS FOR THE CHARACTERISTICS
00336 !
00337         DO ILEO=1,NLEO
00338           II=NOLEO(ILEO)
00339           IF(II.GT.0) THEN
00340           IF(MESH%ELTCAR%I(II).NE.0) THEN
00341             DO JF=1,NF
00342               DO K=1,NPLAN
00343                 AUXIL(K,JF)=F(II,K,JF)
00344               ENDDO
00345             ENDDO
00346             OPEN(99,FILE=EXTENS(NLEO,ILEO),
00347      &              FORM='UNFORMATTED',STATUS='NEW')
00348             CALL ECRI2(AUXIL,IBID,C,NPSPE,'R8',99,'STD',ISTAT)
00349             CLOSE(99)
00350           ENDIF
00351           ENDIF
00352         ENDDO
00353 !
00354 !       WAITING COMPLETION OF THE WORK BY ALL PROCESSORS
00355 !
00356         CALL P_SYNC
00357 !
00358 !       2) PROCESSOR 0 READS ALL FILES AND MERGES IN THE FINAL FILE
00359 !
00360         IF(IPID.EQ.0) THEN
00361           DO ILEO=1,NLEO
00362             OPEN(99,FILE=EXTENS(NLEO,ILEO),
00363      &              FORM='UNFORMATTED',STATUS='OLD')
00364             CALL LIT(AUXIL,W,IBID,C,NPSPE,'R8',99,'STD',ISTAT)
00365             CALL ECRI2(AUXIL,IBID,C,NPSPE,'R4',NSCO,'STD',ISTAT)
00366             DO JF=1,NF
00367               F_INTF(ILEO,JF)=0.D0
00368               DO K=1,NPLAN
00369                 F_INTF(ILEO,JF)=F_INTF(ILEO,JF)+AUXIL(K,JF)*DTETAR
00370               ENDDO
00371             ENDDO
00372             CLOSE(99,STATUS='DELETE')
00373           ENDDO
00374           DO JF=1,NF
00375             WRITE(NSPE,'(100(E10.4,2X))') FREQ(JF),
00376      &                                (F_INTF(ILEO,JF),ILEO=1,NLEO)
00377           ENDDO
00378         ENDIF
00379 !
00380       ELSE
00381 !
00382         DO ILEO=1,NLEO
00383           II=NOLEO(ILEO)
00384           DO JF=1,NF
00385             F_INTF(ILEO,JF)=0.D0
00386             DO K=1,NPLAN
00387               AUXIL(K,JF)=F(II,K,JF)
00388               F_INTF(ILEO,JF)=F_INTF(ILEO,JF)+F(II,K,JF)*DTETAR
00389             ENDDO
00390             IF(ABS(F_INTF(ILEO,JF)).LT.1.D-90) F_INTF(ILEO,JF)=0.D0
00391           ENDDO
00392           CALL ECRI2(AUXIL,IBID,C,NPSPE,'R4',NSCO,'STD',ISTAT)
00393         ENDDO
00394         DO JF=1,NF
00395           WRITE(NSPE,'(100(E10.4,2X))') FREQ(JF),
00396      &                                (F_INTF(ILEO,JF),ILEO=1,NLEO)
00397         ENDDO
00398 !
00399       ENDIF
00400 !
00401 !-----------------------------------------------------------------------
00402 !
00403       RETURN
00404       END

Generated on Fri Aug 31 2013 18:12:58 by S.E.Bourban (HRW) using doxygen 1.7.0