wac_init.F

Go to the documentation of this file.

      SUBROUTINE wac_init
     & (part,impres,debres,date,time)
!
!***********************************************************************
! TOMAWAC   V7P3
!***********************************************************************
!
!brief    MAIN SUBROUTINE OF TOMAWAC (INTIALISATION PART)
!+               SOLVES THE EQUATION FOR THE
!+               DIRECTIONAL WAVE SPECTRUM
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
      USE bief
      USE couple_mod
      USE declarations_telemac
      USE declarations_tomawac
      USE interface_tomawac, ex_wac_init => wac_init
!
      USE declarations_special
      IMPLICIT NONE
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      LOGICAL, INTENT(INOUT) :: IMPRES, DEBRES
      INTEGER, INTENT(IN) :: PART
      INTEGER, INTENT(INOUT) :: DATE(3),TIME(3)
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER IREC, K, IDIRE, IFREQ, IP
      DOUBLE PRECISION :: LAMBD0
      DOUBLE PRECISION VITVEN,VITMIN
!
!-----------------------------------------------------------------------
!
!     MESH ORGANISATION - 2D LEVEL
!
      IF(debug.GT.0) WRITE(lu,*) 'APPEL DE LECLIM POUR MESH2D'
      CALL leclim(lifbor,itr31,itr31,itr31,fbor,
     &            tsder,tsder,tsder,tsder,tsder,tsder,
     &            nptfr,'WAC',.false., fmtgeo, lugeo,
     &            kent,kentu,ksort,kadh,klog,kinc,itr31,
     &            mesh,boundary_colour)
      IF(debug.GT.0) WRITE(lu,*) 'SORTIE DE LECLIM'
!
!
!     LAMBD00 is not initialised yet and can produce some Nan
!     Is it useful to have it as a keyword like in telemac2D ?
      lambd0=0.d0
      IF(debug.GT.0) WRITE(lu,*) 'APPEL DE INBIEF POUR MESH2D'
      CALL inbief(lifbor,klog,sitr31,sitr32,sitr33,
     &            lvmac,ielm2,lambd0,sphe,mesh,stsder,ststot,1,1,equa)
      IF(debug.GT.0) WRITE(lu,*) 'SORTIE DE INBIEF'
!
!     EXTENSION OF IKLE2 (SEE CALL TO POST_INTERP IN PROPA)
!
      CALL build_ikle_ext(ikle_ext%I,ikle_ext%DIM1,ikle2,nelem2)
!
!     MESH ORGANISATION - 3D LEVEL
!
      IF(debug.GT.0) WRITE(lu,*) 'APPEL DE LECLIM POUR MESH3D'
      CALL leclim (lifbor,itr31,itr31,itr31,fbor,
     &             tsder,tsder,tsder,tsder,tsder,tsder,
     &             nptfr,'WAC',.false., fmtgeo, lugeo,
     &             kent,kentu,ksort,kadh,klog,kinc,itr31,mesh3d)
      IF(debug.GT.0) WRITE(lu,*) 'SORTIE DE LECLIM'
!
      IF(debug.GT.0) WRITE(lu,*) 'APPEL DE INBIEF POUR MESH3D'
      CALL inbief(lifbor,klog,sitr31,sitr32,sitr33,
     &            lvmac,ielm3,lambd0,sphe,mesh3d,
     &            stsder,ststot,1,1,equa,mesh2d=mesh)
      IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE INBIEF'
!
!     3D IFABOR
!
      CALL ifabtom(mesh3d%IFABOR%I,nelem2,ndire-1)
!
!-----------------------------------------------------------------------
!
!     V6P2 Diffraction : FREEMESH METHOD
!
      IF(diffra.GT.0) THEN
        IF(ncsize.GT.1.AND.optder.EQ.1) THEN
          WRITE(lu,*) ''
          WRITE(lu,*) '***************************************'
          WRITE(lu,*) ' ATTENTION : DIFFRACTION               '
          WRITE(lu,*) ' OPTION FOR THE SECOND DERIVATIVES     '
          WRITE(lu,*) ' SET TO 2 IN PARALLEL MODE             '
          WRITE(lu,*) '***************************************'
        ENDIF
        WRITE(lu,*) '****************************************'
        WRITE(lu,*) 'DIFFRACTION IS TAKEN INTO ACCOUNT      '
        WRITE(lu,*) 'STARTING FROM TIME STEP ',nptdif
        IF(diffra.EQ.1) THEN
          WRITE(lu,*) 'MILD SLOPE EQUATION FORMULATION'
        ELSE
          WRITE(lu,*)'REVISED MILD SLOPE EQUATION FORMULATION'
        ENDIF
        WRITE(lu,*) '****************************************'
!
!    SETS UP OF THE SUBDOMAINS FOR THE FREEMSESH METHOD
!    AND CALCULATES THE INVERSE MATRICES FOR EACH SUBDOMAIN
!
        IF(optder.EQ.1) THEN
          IF(debug.GT.0) WRITE(lu,*) 'APPEL DE FREEMESH'
          CALL frmset( neigb, npoin2, nelem2, ikle2,
     &                 rk,    rx,     ry,     rxx, ryy)
          IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE FREEMESH'
        ENDIF
      ENDIF
!-----------------------------------------------------------------------
!
! LECTURE DE LA COTE DU FOND (ZF) SUR LE FICHIER DE GEOMETRIE
!
      IF(debug.GT.0) WRITE(lu,*) 'APPEL DE FONSTR'
      CALL fonstr(st1,szf,st2,st3, lugeo, fmtgeo, lufon, namfon,
     &            mesh,  1.d0,.true., 0, names_prive,sprive)
      IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE FONSTR'
!
! CORRECTION EVENTUELLE DES VALEURS DU FOND (OU CALCUL DU FOND SI CELA
! N'A PAS ETE FAIT DANS FONSTR)
! EN STANDARD, TOM_CORFON NE FAIT RIEN (ATTENTION, ALLER CHERCHER
! LE TOM_CORFON DE TOMAWAC).
! DANS LE CAS DE COUPLAGE AVEC TELEMAC, ON LIT LE FOND A PARTIR DU
! MODELE TELEMAC ET TOM_CORFON N EST PAS UTILISE
!
      IF(part.EQ.wac_full_run.OR.part.EQ.wac_cpl_init.OR.
     &   part.EQ.wac_api_init)THEN
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE TOM_CORFON'
        CALL tom_corfon
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE TOM_CORFON'
      ENDIF
!
!     CALCUL DE LA PROFONDEUR D'EAU (TABLEAU DEPTH)
!
      IF(.NOT.proinf) THEN
        DO ip=1,npoin2
          depth(ip)=max(zrepos-zf(ip),0.9d0*promin)
        ENDDO
!     DO NOT UNDERSTAND 0.9
      ENDIF
!
!-----------------------------------------------------------------------
!
!     PREPARATION DES SORTIES GRAPHIQUES
!
!     CREATION DU JEU DE DONNEES POUR UN FORMAT DE FICHIER FORMAT_RES.
!     LE JEU DE DONNEES EST CREE DANS LE FICHIER NRES, ET EST DEFINI
!     PAR UN TITRE ET LES VARIABLES A ECRIRE.
!
      IF(namres.NE.' ') THEN
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE WRITE_HEADER'
        CALL write_header(fmtres, ! FORMAT FICHIER RESULTAT
     &                    lures,  ! LU FICHIER RESULTAT
     &                    titcas,     ! TITRE DE L'ETUDE
     &                    maxvar,     ! MAX VARIABLES SORTIE
     &                    texte,      ! NOMS VARIABLES SORTIE
     &                    sorleo)     ! SORTIE OU PAS DES VARIABLES
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE WRITE_HEADER'
!
!     ECRITURE DU MAILLAGE DANS LE FICHIER SORTIE :
!     SI ON EST ON PARALLEL, FAUT L'INDIQUER VIA NCSIZE ET NPTIR.
!     LES AUTRES INFORMATIONS SONT DANS MESH.
!     EN PLUS : DATE/TEMPS DE DEPART ET LES COORDONNEES DE L'ORIGINE.
!
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE WRITE_MESH'
        CALL write_mesh(fmtres, ! FORMAT FICHIER RESULTAT
     &                  lures,  ! LU FICHIER RESULTAT
     &                  mesh,
     &                  1,             ! NOMBRE DE PLAN /NA/
     &                  date,          ! DATE DEBUT
     &                  time,          ! HEURE DEBUT
     &                  stra31,stra32, ! WORKING ARRAYS
     &                  ncsize.GT.1, nptir,
     &                  ngeo=lugeo,
     &                  geoformat=fmtgeo)
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE WRITE_MESH'
      ENDIF
!
!-----------------------------------------------------------------------
! CONDITIONS INITIALES
!=====C INITIALISATION DES VECTEURS DE DISCRETISATION, DU COURANT,
!  2  C DU VENT ET DU SPECTRE DE VARIANCE.
!=====C===========================================================
      lt=0
      dtsi=dt/nsits
!-----------------------------------------------------------------------
!     INITIALISES TETA
!     BY DEFAULT THE DIRECTIONS OF PROPAGATION ARE EVENLY DISTRIBUTED
      DO idire = 1,ndire+1
        teta(idire) = (idire-1)*deupi/ndire
      ENDDO
!
!-----------------------------------------------------------------------
!
!     INITIALISES FREQ AND DFREQ, THE FREQUENCIES OF PROPAGATION
!     ARE DISTRIBUTED USING AN EXPONENTIAL LAW
!
      DO ifreq = 1,nf
        freq(ifreq) = f1*raisf**(ifreq-1)
      ENDDO
!-----------------------------------------------------------------------
!
!     INITIALISING DZHDT (BUT MAYBE REDONE IN LECSUI OR CONDIW)
!
      DO ip=1,npoin2
        dzhdt(ip)=0.d0
      ENDDO

!      RECEIVE DATA FROM TELEMAC
!                                                       WAC2
      IF ((part.EQ.0).AND.inclus(coupling,'TOMAWAC2')) THEN
        CALL receive_couple(1,npoin2,nvartel2tom,tel2tom)
        cpl_wac_data%U_TEL => u_tel
        cpl_wac_data%V_TEL => v_tel
        cpl_wac_data%H_TEL => h_tel
        cpl_wac_data%FX_WAC => fx_wac
        cpl_wac_data%FY_WAC => fy_wac
        cpl_wac_data%UV_WAC => uv_wac
        cpl_wac_data%VV_WAC => vv_wac
        cpl_wac_data%DIRMOY_TEL => dirmoy_tel
        cpl_wac_data%HM0_TEL => hm0_tel
        cpl_wac_data%TPR5_TEL => tpr5_tel
        cpl_wac_data%ORBVEL_TEL => orbvel_tel
      ENDIF
!
      IF(suit) THEN
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE LECSUI'
        CALL lecsui(f, ndire, nf, npoin2,
     &              vent,cousta.OR.part.EQ.wac_cpl_init ,
     &              lupre,fmtpre, maree.OR.part.EQ.wac_cpl_init,tsder)
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE LECSUI'
      ELSE
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE CONDIW'
        CALL condiw(part,
     &       cpl_wac_data%U_TEL, cpl_wac_data%V_TEL, cpl_wac_data%H_TEL)
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE CONDIW'
!       DEPTH MAY BE MODIFIED IN CONDIW
        IF(.NOT.proinf) THEN
          DO ip=1,npoin2
            IF(depth(ip).LT.promin) depth(ip)=0.9d0*promin
          ENDDO
        ENDIF
      ENDIF
!
      IF(raztim) at=0.d0
      IF(part.EQ.wac_cpl_init) at=cpl_wac_data%AT_TEL
!
      at0=at
!
      IF(.NOT.proinf) THEN
        DO ip=1,npoin2
          IF(depth(ip).LE.0.d0) THEN
            WRITE(lu,*) ''
            WRITE(lu,*) '**************************'
            WRITE(lu,*) ' ! NEGATIVE WATER DEPTH ! '
            WRITE(lu,*) '   END OF THE COMPUTATION '
            WRITE(lu,*) '**************************'
            CALL plante(1)
            stop
          ENDIF
        ENDDO
      ENDIF
!
!=====C
!  4  C CALCULS PREPARATOIRES POUR INTERACTIONS NON-LINEAIRES.
!=====C=======================================================
!.....DIA method (Hasselmann et al., 1985)
!
      IF(strif.EQ.1) THEN
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE PRENL1'
        CALL prenl1( iangnl, coefnl, ndire , nf , raisf , xlamd )
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE PRENL1'
!
!.....MDIA method (Tolman, 2004)
!
      ELSEIF (strif.EQ.2) THEN
!.....Setting parametres for MDIA
        xlamdi(1)=0.075d0
        xmumdi(1)=0.023d0
        xlamdi(2)=0.219d0
        xmumdi(2)=0.127d0
        xlamdi(3)=0.299d0
        xmumdi(3)=0.184d0
        xlamdi(4)=0.394d0
        xmumdi(4)=0.135d0
!
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE PRENL2'
        DO k=1,mdia
          CALL prenl2(ianmdi(1,1,k),coemdi(1,k),ndire,nf,raisf,
     &                xlamdi(k),xmumdi(k))
        ENDDO
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE PRENL2'
!
!.....GQM method (Lavrenov, 2001)
!
      ELSEIF(strif.EQ.3) THEN
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE PRENL3'
        CALL prenl3
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE PRENL3'
      ENDIF
!
      IF(stria.EQ.2) THEN
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE PREQT2'
        CALL preqt2
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE PREQT2'
      ENDIF
!
!=====C INITIALISATION DE LA CONTRAINTE DE HOULE, PUIS CALCUL DES
!  5  C VITESSE DE FROTTEMENT U*, RUGOSITE Z0 ET DIRECTION INITIALES.
!=====C==============================================================
!
!.....5.1 INITIALISATION DE LA CONTRAINTE DE HOULE INITIALE.
!     """"""""""""""""""""""""""""""""""""""""""""""""""""""
      CALL ov('X=C     ', x=tauwav, c=0.d0, dim1=npoin2)
!
!.....5.2 CALCUL DE U* ET Z0 SELON LA METHODE CONSIDEREE.
!     """""""""""""""""""""""""""""""""""""""""""""""""""
      IF (vent) THEN
        IF (svent.EQ.1) THEN
          IF(debug.GT.0) WRITE(lu,*) 'APPEL DE USTAR1'
          CALL ustar1( usold, z0old, tauwav, npoin2   )
          IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE USTAR1'
        ELSEIF (svent.GE.2) THEN
          IF(debug.GT.0) WRITE(lu,*) 'APPEL DE USTAR2'
          CALL ustar2(usold, npoin2)
          IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE USTAR2'
        ELSEIF (svent.EQ.0.AND.lvent.EQ.1) THEN
          IF(debug.GT.0) WRITE(lu,*) 'APPEL DE USTAR2'
          CALL ustar2(usold, npoin2)
          IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE USTAR2'
        ELSEIF (svent.EQ.0.AND.lvent.EQ.0.AND.smout.EQ.2) THEN
          IF(debug.GT.0) WRITE(lu,*) 'APPEL DE USTAR2'
          CALL ustar2(usold, npoin2)
          IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE USTAR2'
        ELSE
          WRITE(lu,*) 'PB IN WAC : WIND PRESENT, BUT SVENT NOT CORRECT'
          CALL plante(1)
          stop
        ENDIF
      ELSE
!       USOLD
        CALL os('X=0     ',x=susold)
!       USNEW
        CALL os('X=0     ',x=susnew)
      ENDIF
!
!.....5.3 CALCUL DE LA DIRECTION DU VENT
!     """"""""""""""""""""""""""""""""""
      vitmin=1.d-3
      IF (vent) THEN
        DO ip=1,npoin2
          vitven=sqrt(uv(ip)**2+vv(ip)**2)
          IF (vitven.GT.vitmin) THEN
            twold(ip)=atan2(uv(ip),vv(ip))
          ELSE
            twold(ip)=0.d0
          ENDIF
        ENDDO
      ENDIF
!
!=====C
!  6  C INITIALISATION DE CERTAINS TABLEAUX UTILES.
!=====C============================================
!
!     COUPLAGE TELEMAC-TOMAWAC si PART=0
!
      IF(debug.GT.0) WRITE(lu,*) 'APPEL DE INITAB'
      CALL initab( ibor, ifabor, nelem2, part)
      IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE INITAB'
!
      IF(debug.GT.0) WRITE(lu,*) 'APPEL DE IMPR'
      CALL impr(lisprd,lt,at,lt,3)
      IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE IMPR'
      IF (part.EQ.wac_cpl_init) THEN
!     ONLY FOR COUPLAGE BUT CAN INDUCE PROBLEM IN TELEMAC2D IF NOT DONE.
        CALL os('X=0     ',x=cpl_wac_data%FX_WAC)
        CALL os('X=0     ',x=cpl_wac_data%FY_WAC)
        CALL os('X=0     ',x=cpl_wac_data%UV_WAC)
        CALL os('X=0     ',x=cpl_wac_data%VV_WAC)
      ENDIF
!=====C
!  7  C AFFECTATION DES CONDITIONS AUX LIMITES A L'INSTANT INITIAL.
!=====C============================================================
      IF(debug.GT.0) WRITE(lu,*) 'APPEL DE LIMWAC'
      CALL limwac
     &(f   , fbor , nptfr,  ndire,    nf, npoin2,
     & kent, prive,  npriv,  wac_files(impspe))
      IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE LIMWAC'
!
!=====C CALCUL DES NOMBRES D'ONDE (XK), DE LA VITESSE DE GROUPE (CG) ET
!  8  C DU FACTEUR DE PASSAGE (B) EN SPECTRE DE VARIANCE EN (FR,TETA).
!=====C=================================================================
!
      IF(debug.GT.0) WRITE(lu,*) 'APPEL DE INIPHY'
      CALL iniphy ( xk, cg, b, npoin2, nf )
      IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE INIPHY'
!
!=====C
!  8b C MISE A ZERO DU SPECTRE SUR LES POINTS OU PROF < PROMIN
!=====C=======================================================
!
      IF(.NOT.proinf) THEN
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE ECRETE'
        IF (ecret) CALL ecrete(f, depth, npoin2, ndire, nf, promin)
!   SHOULD THINK OT THAT ....
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE ECRETE'
      ENDIF
!
!=====C
!  9  C SORTIES GRAPHIQUES (EVENTUELLES) A L'ETAT INITIAL.
!=====C===================================================
!
!.....9.1 CHOIX DES POINTS DE SORTIE DU SPECTRE DIRECTIONNEL.
!
!
      IF(debug.GT.0) WRITE(lu,*) 'APPEL DE PROXIM'
      IF(npleo.GT.0) THEN
        CALL proxim(noleo, xleo, yleo, x, y, npleo, npoin2,
     &        ikle2,nelem2,nelem2)
      ENDIF
      IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE PROXIM'
!
!.....9.2 TEST POUR SAVOIR SI ON IMPRIME OU PAS.
!
      impres=.false.
      debres=.false.
      IF(lt.EQ.gradeb) THEN
        impres=.true.
        debres=.true.
      ENDIF
!
      IF(impres) THEN
!
!.....9.3 IMPRESSION (EVENTUELLE) DES VARIABLES SUR LE MAILLAGE 2D.
!
!
!       THE VARIABLES ARE COMPUTED HERE WITH THE ORIGINAL SPECTRUM
!       DONE IN SPEINI, THERE IS NO CALL TRANSF BEFORE BECAUSE
!       CURRENTS ARE NOT TAKEN INTO ACCOUNT IN SPEINI
!
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE DUMP2D'
        CALL dump2d(f, npoin3*nf)
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE DUMP2D'
!
        IF(namres(1:1).NE.' ') THEN
          IF(debug.GT.0) WRITE(lu,*) 'APPEL DE BIEF_DESIMP'
          CALL bief_desimp(fmtres,varsor, npoin2,lures,at,
     &              lt,lisprd,graprd, sorleo,sorimp,maxvar,texte,0,0)
          IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE BIEF_DESIMP'
        ENDIF
!
!.....9.4 IMPRESSION (EVENTUELLE) DES SPECTRES DIRECTIONNELS.
!
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE ECRSPE'
        irec = (lt - gradeb)    ! Should be 0
        CALL ecrspe(f,     ndire , nf  , npoin2, irec, tsder, noleo,
     &              npleo, debres, date, time, mesh%KNOLG%I ,mesh)
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE ECRSPE'
      ENDIF
!
!     CASE OF TRIPLE COUPLING, INITIAL CONDITIONS
!
!                                                       WAC2
      IF (inclus(coupling,'TOMAWAC2')) THEN
        CALL os('X=0     ',x=fx_wac)
        CALL os('X=0     ',x=fy_wac)
      ENDIF
      IF ((inclus(coupling,'SISYPHE').OR.inclus(coupling,'GAIA'))
     &  .AND.part.EQ.wac_cpl_init) THEN
!       3 VARIABLES THAT WILL BE TRANSMITTED TO SISYPHE OR GAIA
!       ALL THIS IF BLOCK ADAPTED FROM DUMP2D
!       MEAN DIRECTION
        CALL tetmoy(cpl_wac_data%DIRMOY_TEL%R, f, ndire, nf, npoin2)
        IF(trigo) THEN
          DO ip=1,npoin2
            cpl_wac_data%DIRMOY_TEL%R(ip) =
     &          (pisur2-cpl_wac_data%DIRMOY_TEL%R(ip))*gradeg
          ENDDO
        ELSE
          DO ip=1,npoin2
            cpl_wac_data%DIRMOY_TEL%R(ip) =
     &          cpl_wac_data%DIRMOY_TEL%R(ip)*gradeg
          ENDDO
        ENDIF
!       SIGNIFICANT WAVE HEIGHT
        CALL totnrj(tra37, f, nf,ndire,npoin2)
        DO ip=1,npoin2
          cpl_wac_data%HM0_TEL%R(ip)=4.d0*sqrt(tra37(ip))
        ENDDO
!       TPR5
        CALL fpread(cpl_wac_data%TPR5_TEL%R, f, nf, ndire,
     &              npoin2, 5.d0)
        DO ip=1,npoin2
          cpl_wac_data%TPR5_TEL%R(ip)=
     &    1.d0/min(max(cpl_wac_data%TPR5_TEL%R(ip),freq(1)),freq(nf))
        ENDDO
!       ORBITAL VELOCITY SET TO 0.D0
        CALL os('X=0     ',x=cpl_wac_data%ORBVEL_TEL)
      ENDIF
!
!=====C
!  10 C PREPARATION DE LA PROPAGATION (REMONTEE DES CARACTERISTIQUES).
!=====C===============================================================
!
      IF(prop) THEN
!
        CALL impr(lisprd,lt,at,lt,1)
        CALL impr(lisprd,lt,at,lt,2)
!
        IF(debug.GT.0) WRITE(lu,*) 'APPEL DE PREPRO 1'
        CALL prepro
     & ( stsder, ststot, ikle2,  ibor, elt, eta, fre,
     &   xk,  cg,  itr01, npoin3, npoin2, nelem2,
     &   ndire,  nf, couran.OR.part.EQ.wac_cpl_init)
        IF(debug.GT.0) WRITE(lu,*) 'RETOUR DE PREPRO 1'
!
      ENDIF
!
!------------------------------------------------------------------
!
#if defined COMPAD
      CALL ad_tomawac_initialisation_end
#endif
!
!=======================================================================
!
!COUPLAGE : end cycle IF(PART.LE.0) pour couplage avec TELEMAC
      END SUBROUTINE wac_init