My Project
Functions/Subroutines | Variables
m_xnldata Module Reference

Functions/Subroutines

subroutine xnl_init (sigma, dird, nsigma, ndir, pftail, x_grav, depth, ndepth, jquad, iqgrid, ierror)
 
subroutine xnl_main (aspec, sigma, angle, nsig, ndir, depth, iquad, xnl, diag, iproc, ierror)
 
subroutine q_addtail (xnl, diag, nsig, na, pf_tail)
 
subroutine q_allocate
 
subroutine q_chkconfig
 
subroutine q_chkcons (xnl, nk, ndir, sum_e, sum_a, sum_mx, sum_my)
 
subroutine q_chkres (k1x, k1y, k2x, k2y, k3x, k3y, k4x, k4y, dep, sum_kx, sum_ky, sum_w)
 
subroutine q_cmplocus (ka, kb, km, kw, loclen)
 
subroutine q_ctrgrid (itask, igrid)
 
subroutine q_dscale (n, sigma, angle, nsig, nang, depth, grav_w, q_dfac)
 
subroutine q_error (err_type, err_name, err_msg)
 
subroutine q_getlocus (ik1, ia1, ik3, ia3, ifnd)
 
subroutine q_init
 
real function x_locus1 (k2)
 
real function x_locus2 (lambda)
 
subroutine q_locpos (ka, kb, km, kw, loclen)
 
subroutine q_makegrid
 
subroutine q_modify
 
subroutine q_nearest (ik, ia, w1, w2, w3, w4)
 
subroutine q_polar2 (kmin, kmax, kx_beg, ky_beg, kx_end, ky_end, loclen, ierr)
 
subroutine q_setconfig (iquad)
 
subroutine q_searchgrid (depth, igrid)
 
subroutine q_setversion
 
subroutine q_stack (mod_name)
 
subroutine q_summary
 
subroutine q_symmetry (k1x, k1y, k3x, k3y, k4x, k4y, symfac, nloc)
 
subroutine q_t13v4 (ik1, ia1, ik3, ia3, t13, diagk1, diagk3)
 
subroutine q_weight
 
subroutine q_loc_w1w3 (k1x, k1y, k3x, k3y, npts, k2x, k2y, k4x, k4y, s)
 
subroutine q_xnl4v4 (aspec, sigma, angle, nsig, nang, depth, xnl, diag, ierror)
 
real function x_cosk (k)
 
real function x_cple (k1x, k1y, k2x, k2y, k3x, k3y, k4x, k4y, iq_cple, depth, grav_w)
 
real function x_flocus (kxx, kyy)
 
real function x_jacobian (x2, y2, x4, y4)
 
real function x_disper (k, d)
 
real function xc_hh (w1x0, w1y0, w2x0, w2y0, w3x0, w3y0, z4x, z4y, h)
 
real function tanz (x)
 
real function cosz (x)
 
real function xc_webb (k1x, k1y, k2x, k2y, k3x, k3y, k4x, k4y, grav_w)
 

Variables

character(len=60) q_version
 
character(len=20) sub_name
 
character(len=20) qbase
 
character(len=20) qf_error
 
integer iufind
 
integer iscreen
 
integer luq_bqf
 
integer luq_cfg
 
integer luq_err
 
integer luq_fil
 
integer luq_grd
 
integer luq_int
 
integer luq_loc
 
integer luq_log
 
integer luq_prt
 
integer luq_trf
 
integer luq_tst
 
integer luq_txt
 
integer luq_t13
 
real q_grav
 
real qf_tail
 
real qf_krat
 
real qf_dmax
 
real qf_frac
 
integer iq_compact
 
integer iq_cple
 
integer iq_disp
 
integer iq_dscale
 
integer iq_filt
 
integer iq_gauleg
 
integer iq_geom
 
integer iq_grid
 
integer iq_integ
 
integer iq_interp
 
integer iq_locus
 
integer iq_log
 
integer iq_lump
 
integer iq_make
 
integer iq_mod
 
integer iq_prt
 
integer iq_search
 
integer iq_screen
 
integer iq_sym
 
integer iq_tail
 
integer iq_test
 
integer iq_trace
 
integer iq_trf
 
integer iq_t13
 
integer iq_xdia
 
character(len=17) aqname
 
character(len=17) bqname
 
character(len=17) lastquadfile
 
character(len=21) q_header
 
character(len=21) r_header
 
logical lq_grid
 
integer nkq
 
integer naq
 
integer ncirc
 
integer ia_k1
 
integer ik_k1
 
integer ia_k3
 
integer ik_k3
 
real fqmin
 
real fqmax
 
real q_sector
 
real q_dstep
 
integer, parameter mq_stack =10
 
integer mlocus
 
integer nlocus0
 
integer nlocus1
 
integer klocus
 
integer nlocus
 
integer nlocusx
 
real kqmin
 
real kqmax
 
real wk_max
 
real k0x
 
real k0y
 
real dk0
 
real krefx
 
real krefy
 
real k1x
 
real k1y
 
real k2x
 
real k2y
 
real k3x
 
real k3y
 
real k4x
 
real k4y
 
real px
 
real py
 
real pmag
 
real pang
 
real sang
 
real xang
 
real q
 
real kmin_loc
 
real kmax_loc
 
real kmid
 
real kmidx
 
real kmidy
 
real loc_crf
 
real loc_area
 
real loc_xz
 
real loc_yz
 
integer, dimension(:,:), allocatable quad_nloc
 
integer, dimension(:,:,:), allocatable quad_ik2
 
integer, dimension(:,:,:), allocatable quad_ia2
 
integer, dimension(:,:,:), allocatable quad_ik4
 
integer, dimension(:,:,:), allocatable quad_ia4
 
real, dimension(:,:,:), allocatable quad_w1k2
 
real, dimension(:,:,:), allocatable quad_w2k2
 
real, dimension(:,:,:), allocatable quad_w3k2
 
real, dimension(:,:,:), allocatable quad_w4k2
 
real, dimension(:,:,:), allocatable quad_w1k4
 
real, dimension(:,:,:), allocatable quad_w2k4
 
real, dimension(:,:,:), allocatable quad_w3k4
 
real, dimension(:,:,:), allocatable quad_w4k4
 
real, dimension(:,:,:), allocatable quad_zz
 
real, dimension(:,:,:), allocatable quad_t2
 
real, dimension(:,:,:), allocatable quad_t4
 
real, dimension(:,:,:), allocatable quad_sym
 
real, dimension(:,:,:), allocatable quad_jac
 
real, dimension(:,:,:), allocatable quad_cple
 
real, dimension(:,:,:), allocatable quad_ws
 
real, dimension(:), allocatable x2_loc
 
real, dimension(:), allocatable y2_loc
 
real, dimension(:), allocatable z_loc
 
real, dimension(:), allocatable s_loc
 
real, dimension(:), allocatable x4_loc
 
real, dimension(:), allocatable y4_loc
 
real, dimension(:), allocatable ds_loc
 
real, dimension(:), allocatable jac_loc
 
real, dimension(:), allocatable cple_loc
 
real, dimension(:), allocatable sym_loc
 
real, dimension(:), allocatable k_pol
 
real, dimension(:), allocatable c_pol
 
real, dimension(:), allocatable a_pol
 
real, dimension(:), allocatable x2_mod
 
real, dimension(:), allocatable y2_mod
 
real, dimension(:), allocatable x4_mod
 
real, dimension(:), allocatable y4_mod
 
real, dimension(:), allocatable z_mod
 
real, dimension(:), allocatable s_mod
 
real, dimension(:), allocatable ds_mod
 
real, dimension(:), allocatable jac_mod
 
real, dimension(:), allocatable cple_mod
 
real, dimension(:), allocatable sym_mod
 
real, dimension(:), allocatable k2m_mod
 
real, dimension(:), allocatable k2a_mod
 
real, dimension(:), allocatable k4m_mod
 
real, dimension(:), allocatable k4a_mod
 
real, dimension(:), allocatable wk_k2
 
real, dimension(:), allocatable wk_k4
 
real, dimension(:), allocatable wa_k2
 
real, dimension(:), allocatable wa_k4
 
real, dimension(:), allocatable wt_k2
 
real, dimension(:), allocatable wt_k4
 
integer, dimension(:), allocatable t_ik2
 
integer, dimension(:), allocatable t_ia2
 
integer, dimension(:), allocatable t_ik4
 
integer, dimension(:), allocatable t_ia4
 
real, dimension(:), allocatable t_w1k2
 
real, dimension(:), allocatable t_w2k2
 
real, dimension(:), allocatable t_w3k2
 
real, dimension(:), allocatable t_w4k2
 
real, dimension(:), allocatable t_w1k4
 
real, dimension(:), allocatable t_w2k4
 
real, dimension(:), allocatable t_w3k4
 
real, dimension(:), allocatable t_w4k4
 
real, dimension(:), allocatable t_zz
 
real, dimension(:), allocatable t_tail2
 
real, dimension(:), allocatable t_tail4
 
real, dimension(:), allocatable t_sym
 
real, dimension(:), allocatable t_cple
 
real, dimension(:), allocatable t_jac
 
real, dimension(:), allocatable t_ws
 
integer, dimension(:), allocatable r_ik2
 
integer, dimension(:), allocatable r_ia2
 
integer, dimension(:), allocatable r_ik4
 
integer, dimension(:), allocatable r_ia4
 
real, dimension(:), allocatable r_w1k2
 
real, dimension(:), allocatable r_w2k2
 
real, dimension(:), allocatable r_w3k2
 
real, dimension(:), allocatable r_w4k2
 
real, dimension(:), allocatable r_w1k4
 
real, dimension(:), allocatable r_w2k4
 
real, dimension(:), allocatable r_w3k4
 
real, dimension(:), allocatable r_w4k4
 
real, dimension(:), allocatable r_zz
 
real, dimension(:), allocatable r_jac
 
real, dimension(:), allocatable r_cple
 
real, dimension(:), allocatable r_sym
 
real, dimension(:), allocatable r_ws
 
real, dimension(:), allocatable r_tail2
 
real, dimension(:), allocatable r_tail4
 
real, dimension(:), allocatable dt13
 
real, dimension(:), allocatable q_xk
 
real, dimension(:), allocatable q_sk
 
real sk_max
 
real, dimension(:), allocatable q_k
 
real, dimension(:), allocatable q_dk
 
real, dimension(:), allocatable q_kpow
 
real, dimension(:), allocatable q_f
 
real, dimension(:), allocatable q_df
 
real, dimension(:), allocatable q_sig
 
real, dimension(:), allocatable q_dsig
 
real, dimension(:), allocatable q_cg
 
real, dimension(:), allocatable q_a
 
real, dimension(:), allocatable q_ad
 
real, dimension(:,:), allocatable a
 
real, dimension(:,:), allocatable nspec
 
real, dimension(:), allocatable nk1d
 
real, dimension(:,:), allocatable qnl
 
integer id_facmax
 
real q_dird1
 
real q_dird2
 
real q_depth
 
real q_maxdepth
 
real q_mindepth
 
real q_lambda
 
real q_scale
 
real eps_q
 
real eps_k
 
real rel_k
 
integer iq_stack
 
character(len=21), dimension(mq_stack) cstack
 
real crf1
 
integer iaref
 
integer iamax
 
integer iaq1
 
integer iaq2
 
integer iag1
 
integer iag2
 
real q_ang1
 
real q_ang2
 
real q_delta
 
real q_deltad
 
real q_ffac
 
real q_kfac
 
real qk_tail
 
real ff_tail
 
integer iq_type
 
integer iq_err
 
integer iq_warn
 
integer mk1a
 
integer mk1b
 
integer mk3a
 
integer mk3b
 

Function/Subroutine Documentation

◆ cosz()

real function m_xnldata::cosz ( real  x)

Definition at line 10746 of file swmod3.f90.

10746  real x
10747  if (x.gt.20.) x=25.
10748  cosz=cosh(x)
10749  return
Here is the caller graph for this function:

◆ q_addtail()

subroutine m_xnldata::q_addtail ( real, dimension(nsig,na), intent(inout)  xnl,
real, dimension(nsig,na), intent(inout)  diag,
integer, intent(in)  nsig,
integer, intent(in)  na,
real, intent(in)  pf_tail 
)

Definition at line 2609 of file swmod3.f90.

2609 !------------------------------------------------------------------------------
2610 !
2611 ! +-------+ ALKYON Hydraulic Consultancy & Research
2612 ! | | Gerbrant van Vledder
2613 ! | +---+
2614 ! | | +---+ Last update: 27 April 2004
2615 ! +---+ | | Release: 5.04
2616 ! +---+
2617 !
2618 !
2619 ! SWAN (Simulating WAves Nearshore); a third generation wave model
2620 ! Copyright (C) 2004-2005 Delft University of Technology
2621 !
2622 ! This program is free software; you can redistribute it and/or
2623 ! modify it under the terms of the GNU General Public License as
2624 ! published by the Free Software Foundation; either version 2 of
2625 ! the License, or (at your option) any later version.
2626 !
2627 ! This program is distributed in the hope that it will be useful,
2628 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
2629 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2630 ! GNU General Public License for more details.
2631 !
2632 ! A copy of the GNU General Public License is available at
2633 ! http://www.gnu.org/copyleft/gpl.html#SEC3
2634 ! or by writing to the Free Software Foundation, Inc.,
2635 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
2636 !
2637 !
2638 ! do not use m_xnldata
2639  implicit none
2640 !
2641 ! 0. Update history
2642 !
2643 ! 30/12/2003 Initial version
2644 ! 27/04/2004 Parameter FF_TAIL activated
2645 !
2646 ! 1. Purpose:
2647 !
2648 ! Add parametric tail of tranfer rate consistent with the nonlinear
2649 ! transfer rate in a parameteric spectral tail
2650 !
2651 ! 2. Method
2652 !
2653 !
2654 ! 3. Parameter list:
2655 !
2656 ! Type I/O Name Description
2657 !----------------------------------------------------------------------
2658 !
2659  integer, intent(in) :: nsig ! Number of wave numbers
2660  integer, intent(in) :: na ! Number of directions
2661  real, intent(inout) :: xnl(nsig,na) ! Non-linear transfer rate
2662  real, intent(inout) :: diag(nsig,na) ! Diagonal term
2663  real, intent(in) :: pf_tail ! power of tail of E(f)
2664 !
2665 !
2666 ! 4. Error messages
2667 !
2668 ! 5. Subroutines used
2669 !
2670 !
2671 ! 6. Called by:
2672 !
2673 ! XNL_MAIN
2674 !
2675 ! 7. Remarks
2676 !
2677 ! 8. Structure
2678 !
2679 ! 9. Switches
2680 !
2681 ! 10. Source code
2682 !------------------------------------------------------------------------------
2683 ! Local variables
2684 !
2685  integer ia,isig ! counters for directions and wave numbers
2686  integer isig_tail ! index of bin where tail starts
2687 !
2688  real xnl_tail(nsig) ! tail factors for transfer rate
2689  real diag_tail(nsig) ! tail factors for diagonal term
2690  real x_tail ! power in tail of nonlinear transfer rate
2691  real d_tail ! power in tail of diagonal term
2692  real sig_tail ! threshold sigma for start of parametric tail
2693 !-----------------------------------------------------------------------------
2694 !
2695  call q_stack('+q_addtail')
2696 !
2697 ! determine index where parametric tail starts
2698 !
2699  sig_tail = ff_tail*q_sig(nsig)
2700  do isig=1,nsig
2701  if(q_sig(isig)<sig_tail) isig_tail = isig
2702  end do
2703 !
2704  xnl_tail = 1.
2705  diag_tail = 1.
2706 !
2707 ! set tail factors
2708 !
2709  x_tail = 11+3*pf_tail-1
2710  d_tail = 12+2*pf_tail-1
2711 !
2712  if(iq_test>=2) then
2713  write(iscreen,'(a,2i4,2f8.2)') &
2714  'Q_ADDTAIL nsig,isig_tail,qf_tail:',nsig,isig_tail,pf_tail
2715  write(iscreen,'(a,3f8.2)') 'Q_ADDTAIL qf_tail, x_tail d_tail:', &
2716  pf_tail,x_tail,d_tail
2717  end if
2718 !
2719  do isig=isig_tail,nsig
2720  xnl_tail(isig) = (q_sig(isig)/q_sig(isig_tail))**x_tail
2721  diag_tail(isig) = (q_sig(isig)/q_sig(isig_tail))**d_tail
2722  end do
2723 !
2724 ! apply tail factors to transfer rate and diagonal term
2725 !
2726  do isig=isig_tail,nsig
2727  do ia=1,na
2728  xnl(isig,ia) = xnl(isig_tail,ia) *xnl_tail(isig)
2729  diag(isig,ia) = diag(isig_tail,ia)*diag_tail(isig)
2730  end do
2731  end do
2732 !
2733  9999 continue
2734 !
2735  call q_stack('-q_addtail')
2736  return
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_allocate()

subroutine m_xnldata::q_allocate ( )

Definition at line 2740 of file swmod3.f90.

2740 !------------------------------------------------------------------------------
2741 !
2742 ! +-------+ ALKYON Hydraulic Consultancy & Research
2743 ! | | Gerbrant van Vledder
2744 ! | +---+
2745 ! | | +---+ Last update: 24 December 2004
2746 ! +---+ | | Release: 5.04
2747 ! +---+
2748 !
2749 !
2750 ! SWAN (Simulating WAves Nearshore); a third generation wave model
2751 ! Copyright (C) 2004-2005 Delft University of Technology
2752 !
2753 ! This program is free software; you can redistribute it and/or
2754 ! modify it under the terms of the GNU General Public License as
2755 ! published by the Free Software Foundation; either version 2 of
2756 ! the License, or (at your option) any later version.
2757 !
2758 ! This program is distributed in the hope that it will be useful,
2759 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
2760 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2761 ! GNU General Public License for more details.
2762 !
2763 ! A copy of the GNU General Public License is available at
2764 ! http://www.gnu.org/copyleft/gpl.html#SEC3
2765 ! or by writing to the Free Software Foundation, Inc.,
2766 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
2767 !
2768 !
2769 ! do not use m_xnldata
2770  implicit none
2771 !
2772 !
2773 ! 0. Update history
2774 !
2775 ! 05/10/1999 initial version
2776 ! 25/11/1999 logging output added
2777 ! 10/01/2001 Inconsistency fixed
2778 ! 01/10/2001 Array's for k4-locus added
2779 ! 08/08/2002 Upgrade to release 4.0
2780 ! 20/08/2002 Internal action density spectrum added A
2781 ! 11/09/2002 q_kpow added
2782 ! 25/04/2003 Name modified from q_alloc -> q_allocate
2783 ! Triplet array added
2784 ! 02/05/2003 Bug fixed in allocate of triplet arrays
2785 ! 11/06/2003 Array SYM_LOC added
2786 ! Parameter KLOCUS introduced for actual maximum size of locus
2787 ! 16/06/2003 Loci information included, moved from Q_XNL4V4
2788 ! 08/08/2003 Value of MLOCUS modified, now 1.3*NLOCUS0, was 1.2
2789 ! 24/12/2003 Tail factors r/t_tail2/4 added
2790 !
2791 ! 1. Purpose:
2792 !
2793 ! Check configuration for non-linear transfer
2794 !
2795 ! 2. Method
2796 !
2797 ! Allocate data arrays
2798 !
2799 ! 3. Parameters used
2800 !
2801 ! 4. Error messaged
2802 !
2803 ! 5. Called by:
2804 !
2805 ! XNL_INIT
2806 !
2807 ! 6. Subroutines used
2808 !
2809 ! Q_STACK
2810 !
2811 ! 7. Remarks
2812 !
2813 ! 8. Stucture
2814 !
2815 ! 9. Switches
2816 !
2817 ! /S Subroutine tracing
2818 !
2819 ! 10. Source code
2820 !-------------------------------------------------------------------------------
2821 !
2822 ! Local variables
2823 !-------------------------------------------------------------------------------
2824  integer maq ! number of theta elements in grid matrix
2825  integer mkq ! number of k-elements in grid matrix
2826 !-------------------------------------------------------------------------------
2827  call q_stack('+q_allocate')
2828 !
2829  if(iq_geom==0) then
2830  mkq = nkq*(nkq+1)/2
2831  else
2832  mkq = nkq
2833  end if
2834 !
2835  maq = naq/2+1
2836  mlocus = 1.3*nlocus0
2837 !
2838  if(iq_log >=1) write(luq_log,'(a,4i4)') &
2839  'Q_ALLOCATE: mkq maq mlocus klocus:',mkq,maq,mlocus,klocus
2840 !
2841  if (allocated (q_xk)) deallocate (q_xk)
2842  allocate(q_xk(0:nkq))
2843  if (allocated (q_sk)) deallocate (q_sk)
2844  allocate(q_sk(0:nkq))
2845 !
2846  if (allocated (quad_nloc)) deallocate (quad_nloc)
2847  allocate (quad_nloc(mkq,maq))
2848  if (allocated (quad_ik2)) deallocate (quad_ik2)
2849  allocate (quad_ik2(mkq,maq,klocus))
2850  if (allocated (quad_ia2)) deallocate (quad_ia2)
2851  allocate (quad_ia2(mkq,maq,klocus))
2852  if (allocated (quad_ik4)) deallocate (quad_ik4)
2853  allocate (quad_ik4(mkq,maq,klocus))
2854  if (allocated (quad_ia4)) deallocate (quad_ia4)
2855  allocate (quad_ia4(mkq,maq,klocus))
2856  if (allocated (quad_w1k2)) deallocate (quad_w1k2)
2857  allocate (quad_w1k2(mkq,maq,klocus))
2858  if (allocated (quad_w2k2)) deallocate (quad_w2k2)
2859  allocate (quad_w2k2(mkq,maq,klocus))
2860  if (allocated (quad_w3k2)) deallocate (quad_w3k2)
2861  allocate (quad_w3k2(mkq,maq,klocus))
2862  if (allocated (quad_w4k2)) deallocate (quad_w4k2)
2863  allocate (quad_w4k2(mkq,maq,klocus))
2864  if (allocated (quad_w1k4)) deallocate (quad_w1k4)
2865  allocate (quad_w1k4(mkq,maq,klocus))
2866  if (allocated (quad_w2k4)) deallocate (quad_w2k4)
2867  allocate (quad_w2k4(mkq,maq,klocus))
2868  if (allocated (quad_w3k4)) deallocate (quad_w3k4)
2869  allocate (quad_w3k4(mkq,maq,klocus))
2870  if (allocated (quad_w4k4)) deallocate (quad_w4k4)
2871  allocate (quad_w4k4(mkq,maq,klocus))
2872  if (allocated (quad_zz)) deallocate (quad_zz)
2873  allocate (quad_zz(mkq,maq,klocus))
2874  if (allocated (quad_t2)) deallocate (quad_t2)
2875  allocate (quad_t2(mkq,maq,klocus))
2876  if (allocated (quad_t4)) deallocate (quad_t4)
2877  allocate (quad_t4(mkq,maq,klocus))
2878  if (allocated (quad_cple)) deallocate (quad_cple)
2879  allocate (quad_cple(mkq,maq,klocus))
2880  if (allocated (quad_jac)) deallocate (quad_jac)
2881  allocate (quad_jac(mkq,maq,klocus))
2882  if (allocated (quad_sym)) deallocate (quad_sym)
2883  allocate (quad_sym(mkq,maq,klocus))
2884  if (allocated (quad_ws)) deallocate (quad_ws)
2885  allocate (quad_ws(mkq,maq,klocus))
2886 !
2887  if (allocated(x2_loc)) deallocate(x2_loc)
2888  allocate (x2_loc(mlocus))
2889  if (allocated(y2_loc)) deallocate(y2_loc)
2890  allocate (y2_loc(mlocus))
2891  if (allocated(x4_loc)) deallocate(x4_loc)
2892  allocate (x4_loc(mlocus))
2893  if (allocated(y4_loc)) deallocate(y4_loc)
2894  allocate (y4_loc(mlocus))
2895  if (allocated(z_loc)) deallocate(z_loc)
2896  allocate (z_loc(mlocus))
2897  if (allocated(s_loc)) deallocate(s_loc)
2898  allocate (s_loc(mlocus))
2899  if (allocated(ds_loc)) deallocate(ds_loc)
2900  allocate (ds_loc(mlocus))
2901  if (allocated(jac_loc)) deallocate(jac_loc)
2902  allocate (jac_loc(mlocus))
2903  if (allocated(cple_loc)) deallocate(cple_loc)
2904  allocate (cple_loc(mlocus))
2905  if (allocated(a_pol)) deallocate(a_pol)
2906  allocate (a_pol(mlocus))
2907  if (allocated(c_pol)) deallocate(c_pol)
2908  allocate (c_pol(mlocus))
2909  if (allocated(k_pol)) deallocate(k_pol)
2910  allocate (k_pol(mlocus))
2911  if (allocated(sym_loc)) deallocate (sym_loc)
2912  allocate (sym_loc(mlocus))
2913 !
2914  if (allocated(x2_mod)) deallocate (x2_mod)
2915  allocate (x2_mod(mlocus))
2916  if (allocated(y2_mod)) deallocate (y2_mod)
2917  allocate (y2_mod(mlocus))
2918  if (allocated(x4_mod)) deallocate (x4_mod)
2919  allocate (x4_mod(mlocus))
2920  if (allocated(y4_mod)) deallocate (y4_mod)
2921  allocate (y4_mod(mlocus))
2922  if (allocated(z_mod)) deallocate (z_mod)
2923  allocate (z_mod(mlocus))
2924  if (allocated(s_mod)) deallocate (s_mod)
2925  allocate (s_mod(mlocus))
2926  if (allocated(ds_mod)) deallocate (ds_mod)
2927  allocate (ds_mod(mlocus))
2928  if (allocated(jac_mod)) deallocate (jac_mod)
2929  allocate (jac_mod(mlocus))
2930  if (allocated(cple_mod)) deallocate (cple_mod)
2931  allocate (cple_mod(mlocus))
2932  if (allocated(sym_mod)) deallocate (sym_mod)
2933  allocate (sym_mod(mlocus))
2934 !
2935  if (allocated(k2m_mod)) deallocate (k2m_mod)
2936  allocate (k2m_mod(mlocus))
2937  if (allocated(k2a_mod)) deallocate (k2a_mod)
2938  allocate (k2a_mod(mlocus))
2939  if (allocated(k4m_mod)) deallocate (k4m_mod)
2940  allocate (k4m_mod(mlocus))
2941  if (allocated(k4a_mod)) deallocate (k4a_mod)
2942  allocate (k4a_mod(mlocus))
2943 !
2944  if (allocated(wk_k2)) deallocate(wk_k2)
2945  allocate (wk_k2(mlocus))
2946  if (allocated(wa_k2)) deallocate(wa_k2)
2947  allocate (wa_k2(mlocus))
2948  if (allocated(wt_k2)) deallocate(wt_k2)
2949  allocate (wt_k2(mlocus))
2950  if (allocated(wk_k4)) deallocate(wk_k4)
2951  allocate (wk_k4(mlocus))
2952  if (allocated(wa_k4)) deallocate(wa_k4)
2953  allocate (wa_k4(mlocus))
2954  if (allocated(wt_k4)) deallocate(wt_k4)
2955  allocate (wt_k4(mlocus))
2956 !
2957 ! if (allocated(t_wk2)) deallocate (t_wk2)
2958 ! allocate (t_wk2(mlocus))
2959 ! if (allocated(t_wa2)) deallocate (t_wa2)
2960 ! allocate (t_wa2(mlocus))
2961 ! if (allocated(t_wt2)) deallocate (t_wt2)
2962 ! allocate (t_wt2(mlocus))
2963 ! if (allocated(t_wk4)) deallocate (t_wk4)
2964 ! allocate (t_wk4(mlocus))
2965 ! if (allocated(t_wa4)) deallocate (t_wa4)
2966 ! allocate (t_wa4(mlocus))
2967 ! if (allocated(t_wt4)) deallocate (t_wt4)
2968 ! allocate (t_wt4(mlocus))
2969 ! if (allocated(t_sym)) deallocate (t_sym)
2970 ! allocate (t_sym(mlocus))
2971 ! if (allocated(t_grad)) deallocate (t_grad)
2972 ! allocate (t_grad(mlocus))
2973 ! if (allocated(t_cple)) deallocate (t_cple)
2974 ! allocate (t_cple(mlocus))
2975 ! if (allocated(t_s)) deallocate (t_s)
2976 ! allocate (t_s(mlocus))
2977 ! if (allocated(t_ds)) deallocate (t_ds)
2978 ! allocate (t_ds(mlocus))
2979 !
2980 !------------------------------------------------------------------------------
2981 ! allocate data arrays for transformation of locus information
2982 ! and integration along locus
2983 !-----------------------------------------------------------------------------
2984  if (allocated(r_ik2)) deallocate (r_ik2)
2985  allocate (r_ik2(klocus))
2986  if (allocated(r_ia2)) deallocate (r_ia2)
2987  allocate (r_ia2(klocus))
2988  if (allocated(r_ik4)) deallocate (r_ik4)
2989  allocate (r_ik4(klocus))
2990  if (allocated(r_ia4)) deallocate (r_ia4)
2991  allocate (r_ia4(klocus))
2992  if (allocated(r_w1k2)) deallocate (r_w1k2)
2993  allocate (r_w1k2(klocus))
2994  if (allocated(r_w2k2)) deallocate (r_w2k2)
2995  allocate (r_w2k2(klocus))
2996  if (allocated(r_w3k2)) deallocate (r_w3k2)
2997  allocate (r_w3k2(klocus))
2998  if (allocated(r_w4k2)) deallocate (r_w4k2)
2999  allocate (r_w4k2(klocus))
3000  if (allocated(r_w1k4)) deallocate (r_w1k4)
3001  allocate (r_w1k4(klocus))
3002  if (allocated(r_w2k4)) deallocate (r_w2k4)
3003  allocate (r_w2k4(klocus))
3004  if (allocated(r_w3k4)) deallocate (r_w3k4)
3005  allocate (r_w3k4(klocus))
3006  if (allocated(r_w4k4)) deallocate (r_w4k4)
3007  allocate (r_w4k4(klocus))
3008  if (allocated(r_zz)) deallocate (r_zz)
3009  allocate (r_zz(klocus))
3010 !
3011  if (allocated(r_tail2)) deallocate (r_tail2)
3012  allocate (r_tail2(klocus))
3013  if (allocated(r_tail4)) deallocate (r_tail4)
3014  allocate (r_tail4(klocus))
3015  if (allocated(t_tail2)) deallocate (t_tail2)
3016  allocate (t_tail2(klocus))
3017  if (allocated(t_tail4)) deallocate (t_tail4)
3018  allocate (t_tail4(klocus))
3019 !
3020  if (allocated( r_cple)) deallocate (r_cple)
3021  allocate (r_cple(klocus))
3022  if (allocated( r_jac)) deallocate (r_jac)
3023  allocate (r_jac(klocus))
3024  if (allocated( r_ws)) deallocate (r_ws)
3025  allocate (r_ws(klocus))
3026  if (allocated( r_sym)) deallocate (r_sym)
3027  allocate (r_sym(klocus))
3028 !-------------------------------------------------------------------------------
3029  if (allocated(t_ik2)) deallocate (t_ik2)
3030  allocate (t_ik2(klocus))
3031  if (allocated(t_ia2)) deallocate (t_ia2)
3032  allocate (t_ia2(klocus))
3033  if (allocated(t_ik4)) deallocate (t_ik4)
3034  allocate (t_ik4(klocus))
3035  if (allocated(t_ia4)) deallocate (t_ia4)
3036  allocate (t_ia4(klocus))
3037  if (allocated(t_w1k2)) deallocate (t_w1k2)
3038  allocate (t_w1k2(klocus))
3039  if (allocated(t_w2k2)) deallocate (t_w2k2)
3040  allocate (t_w2k2(klocus))
3041  if (allocated(t_w3k2)) deallocate (t_w3k2)
3042  allocate (t_w3k2(klocus))
3043  if (allocated(t_w4k2)) deallocate (t_w4k2)
3044  allocate (t_w4k2(klocus))
3045  if (allocated(t_w1k4)) deallocate (t_w1k4)
3046  allocate (t_w1k4(klocus))
3047  if (allocated(t_w2k4)) deallocate (t_w2k4)
3048  allocate (t_w2k4(klocus))
3049  if (allocated(t_w3k4)) deallocate (t_w3k4)
3050  allocate (t_w3k4(klocus))
3051  if (allocated(t_w4k4)) deallocate (t_w4k4)
3052  allocate (t_w4k4(klocus))
3053  if (allocated(t_zz)) deallocate (t_zz)
3054  allocate (t_zz(klocus))
3055  if (allocated(t_cple)) deallocate (t_cple)
3056  allocate (t_cple(klocus))
3057  if (allocated(t_jac)) deallocate (t_jac)
3058  allocate (t_jac(klocus))
3059  if (allocated(t_ws)) deallocate (t_ws)
3060  allocate (t_ws(klocus))
3061  if (allocated(t_sym)) deallocate (t_sym)
3062  allocate (t_sym(klocus))
3063 !-------------------------------------------------------------------------------
3064  if (allocated(dt13)) deallocate (dt13)
3065  allocate(dt13(klocus))
3066 !
3067 !------------------- spectral grid data ------------------------
3068 !
3069  if (allocated(q_k)) deallocate (q_k)
3070  allocate (q_k(nkq))
3071  if (allocated(q_dk)) deallocate (q_dk)
3072  allocate (q_dk(nkq))
3073  if (allocated(q_kpow)) deallocate (q_kpow)
3074  allocate (q_kpow(nkq))
3075  if (allocated(q_f)) deallocate (q_f)
3076  allocate (q_f(nkq))
3077  if (allocated(q_df)) deallocate (q_df)
3078  allocate (q_df(nkq))
3079  if (allocated(q_sig)) deallocate (q_sig)
3080  allocate (q_sig(nkq))
3081  if (allocated(q_dsig)) deallocate (q_dsig)
3082  allocate (q_dsig(nkq))
3083  if (allocated(q_cg)) deallocate (q_cg)
3084  allocate (q_cg(nkq))
3085  if (allocated(q_a)) deallocate (q_a)
3086  allocate (q_a(naq))
3087  if (allocated(q_ad)) deallocate (q_ad)
3088  allocate (q_ad(naq))
3089 !
3090 !
3091  if (allocated(nspec)) deallocate (nspec)
3092  allocate (nspec(nkq,naq))
3093  if (allocated(a)) deallocate (a)
3094  allocate (a(nkq,naq))
3095  if (allocated(nk1d)) deallocate (nk1d)
3096  allocate (nk1d(nkq))
3097 !! if (allocated(qnl)) deallocate (qnl)
3098 !! allocate (qnl(nkq,naq))
3099 !
3100  if(iq_log >=1) then
3101  write(luq_log,'(a)') 'Q_ALLOCATE: size of arrays'
3102  write(luq_log,'(a,i4)') 'Q_ALLOCATE: mkq :',mkq
3103  write(luq_log,'(a,i4)') 'Q_ALLOCATE: maq :',maq
3104  write(luq_log,'(a,i4)') 'Q_ALLOCATE: nkq :',nkq
3105  write(luq_log,'(a,i4)') 'Q_ALLOCATE: naq :',naq
3106  write(luq_log,'(a,i4)') 'Q_ALLOCATE: mlocus:',mlocus
3107  write(luq_log,'(a,i4)') 'Q_ALLOCATE: klocus:',klocus
3108  end if
3109 !
3110  call q_stack('-q_allocate')
3111 !
3112  return
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_chkconfig()

subroutine m_xnldata::q_chkconfig ( )

Definition at line 3116 of file swmod3.f90.

3116 !------------------------------------------------------------------------------
3117 !
3118 ! +-------+ ALKYON Hydraulic Consultancy & Research
3119 ! | | Gerbrant van Vledder
3120 ! | +---+
3121 ! | | +---+ Last update: 7 May 2004
3122 ! +---+ | | Release: 5.0
3123 ! +---+
3124 !
3125 !
3126 ! SWAN (Simulating WAves Nearshore); a third generation wave model
3127 ! Copyright (C) 2004-2005 Delft University of Technology
3128 !
3129 ! This program is free software; you can redistribute it and/or
3130 ! modify it under the terms of the GNU General Public License as
3131 ! published by the Free Software Foundation; either version 2 of
3132 ! the License, or (at your option) any later version.
3133 !
3134 ! This program is distributed in the hope that it will be useful,
3135 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
3136 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3137 ! GNU General Public License for more details.
3138 !
3139 ! A copy of the GNU General Public License is available at
3140 ! http://www.gnu.org/copyleft/gpl.html#SEC3
3141 ! or by writing to the Free Software Foundation, Inc.,
3142 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
3143 !
3144 !
3145 ! 0. Update history
3146 !
3147 ! 28/12/1999 Initial version
3148 ! 05/10/1999 Test for iq_filt included
3149 ! 01/11/1999 Implicit none introduced
3150 ! 12/11/1999 Update of tests
3151 ! 22/11/1999 Update of tests
3152 ! 28/12/1999 Check of IQ_LOCUS added
3153 ! 02/01/2000 IQ_START removed
3154 ! 05/01/2000 IQ_INT added
3155 ! 08/08/2002 Upgrade to release 4
3156 ! 22/08/2002 Extra checks included
3157 ! 04/06/2003 parameter IQ_INT renamed IQ_INTEG
3158 ! Switches IQ_GAULEG, IQ_LUMP added
3159 ! 11/06/2003 Name changed from Q_CHKCFG to Q_CHKCONFIG
3160 ! Parameter iq_space removed
3161 ! 12/06/2003 Extra check on IMOD, KLOCUS and NLOCUS0
3162 ! 16/06/2003 Switch IQ_SYM added
3163 ! 27/04/2004 Check added for range of Q_DSTEP
3164 ! 07/05/2004 Check added for range of IQ_DSCALE
3165 !
3166 ! 1. Purpose:
3167 !
3168 ! Check configuration for computation of non-linear transfer
3169 !
3170 ! 2. Method
3171 !
3172 ! Check of each parameter setting
3173 !
3174 ! 3. Parameters used
3175 !
3176 ! 4. Error messages
3177 !
3178 ! 5. Called by:
3179 !
3180 ! XNL_INIT
3181 !
3182 ! 6. Subroutines used:
3183 !
3184 ! Q_ERROR
3185 !
3186 ! 7. Remarkds
3187 !
3188 ! 8. Structure
3189 !
3190 ! 9. Switches
3191 !
3192 ! /S enable subroutine tracing
3193 !
3194 ! 10. Source code
3195 !-------------------------------------------------------------------------------------------
3196 ! do not use m_xnldata
3197  implicit none
3198 !
3199  call q_stack('+Q_CHKCONFIG')
3200 !
3201  if(qf_tail > -1.) &
3202  call q_error('e','CONFIG','Incorrect power of spectral: qf_tail')
3203 !
3204  if(iq_cple < 1 .or. iq_cple > 3) &
3205  call q_error('e','CONFIG', &
3206  'Invalid option for coupling coefficient iq_cple')
3207 !
3208  if(iq_compact < 0 .or. iq_compact > 1) &
3209  call q_error('e','CONFIG','iq_compact /= 0,1')
3210 !
3211  if(iq_filt < 0 .or. iq_filt > 1) &
3212  call q_error('e','CONFIG','iq_filt /= 0,1')
3213 !
3214  if(iq_gauleg < 0) &
3215  call q_error('e','CONFIG','iq_gauleg <0')
3216 !
3217  if(iq_geom < 0 .or. iq_geom > 1) &
3218  call q_error('e','CONFIG','iq_geom /= 0,1')
3219 !
3220  if(iq_interp < 1 .or. iq_interp > 2) &
3221  call q_error('e','CONFIG','iq_interp /= 1,2')
3222 !
3223  if(iq_disp > 1 .and. iq_geom ==1) then
3224  call q_error('e','CONFIG', &
3225  'Invalid combination of iq_disp & iq_geom')
3226  write(luq_err,'(a,2i4)') 'Q_CHKCONFIG: iq_disp iq_geom:', &
3227  iq_disp,iq_geom
3228  end if
3229 !
3230  if(iq_dscale < 0 .or. iq_dscale>1) then
3231  call q_error('e','CONFIG','Invalid value for IQ_DSCALE')
3232  write(luq_err,'(a,i4)') 'Q_CHKCONFIG: iq_dscale:',iq_dscale
3233  end if
3234 !
3235  if(iq_lump>0 .and. iq_gauleg>0) then
3236  call q_error('e','CONFIG', &
3237  'Lumping and Gauss-Legendre interpolation not together')
3238  write(luq_err,'(a,2i4)') 'Q_CHKCONFIG: iq_lump iq_gauleg:', &
3239  iq_lump,iq_gauleg
3240  end if
3241 !
3242  if(iq_dscale < 0 .or. iq_dscale > 1) &
3243  call q_error('e','CONFIG', &
3244  'Incorrect value for IQ_DSCALE, (0,1)')
3245 !
3246  if(iq_disp < 1 .or. iq_disp >2 ) &
3247  call q_error('e','CONFIG', &
3248  'Incorrect value for IQ_DISP [DISP],(1,2) ')
3249 !
3250  if(iq_grid <1 .or. iq_grid > 3) &
3251  call q_error('e', &
3252  'CONFIG','Incorrect value for IQ_GRID, (1,2,3)')
3253 !
3254  if(iq_integ < 0 .or. iq_make > 3) then
3255  call q_error('e','CONFIG','Invalid value for iq_integ')
3256  write(luq_err,'(a,2i4)') 'Q_CHKCONFIG: iq_integ:',iq_integ
3257  end if
3258 !
3259  if(iq_log < 0) &
3260  call q_error('e','CONFIG','Incorrect value for IQ_LOG, (>=0) ')
3261 !
3262  if(iq_locus < 0 .or. iq_locus > 3) &
3263  call q_error('e', &
3264  'CONFIG','Incorrect specifier for locus method')
3265 !
3266  if(iq_lump<0) then
3267  call q_error('e','CONFIG','Invalid value for iq_lump')
3268  write(luq_err,'(1x,a,2i4)') 'iq_lump:',iq_lump
3269  end if
3270 !
3271  if(iq_make < 1 .or. iq_make > 3) then
3272  call q_error('e','CONFIG','Invalid value for iq_make')
3273  write(luq_err,'(a,2i4)') 'Q_CHKCONFIG: iq_make:',iq_make
3274  end if
3275 !
3276  if(iq_mod < 0 .or. iq_mod > 1) &
3277  call q_error('e', &
3278  'CONFIG','Incorrect value for IQ_MOD [MOD] (0,1)')
3279 !
3280  if(iq_mod==0 .and. klocus<nlocus0) then
3281  call q_error('e','CONFIG','klocus < nlocus0')
3282  write(luq_err,'(a)') &
3283  'Q_CHKCONFIG: Lumping or Gauss-Integration enabled when IMOD=0'
3284  end if
3285 !
3286  if(iq_prt < 0) &
3287  call q_error('e','CONFIG','Incorrect value for IQ_PRT, (>=0) ')
3288 !
3289 !! if(iq_search==1 .and. iq_type/=3)
3290 !! & call q_error('w','CONFIG','search option only active when IQUAD=3')
3291 !
3292  if(iq_sym <0 .or. iq_sym > 1) &
3293  call q_error('e','CONFIG','Incorrect value of IQ_SYM /=[0,1]')
3294 !
3295  if(iq_test < 0) &
3296  call q_error('e','CONFIG','Incorrect value for IQ_TEST, (>=0) ')
3297 !
3298  if(iq_trf < 0 .or. iq_trf > 3) &
3299  call q_error('e','CONFIG','Incorrect value for IQ_TRF ')
3300 !------------------------------------------------------------------------
3301 ! parameter settings
3302 !-----------------------------------------------------------------------
3303 !
3304  if(fqmin < 0) &
3305  call q_error('e','CONFIG','Incorrect value for FQMIN')
3306 !
3307  if(fqmax < 0) &
3308  call q_error('e','CONFIG','Incorrect value for FQMAX')
3309 !
3310  if(fqmax <= fqmin) &
3311  call q_error('e','CONFIG','fmax <= fmin')
3312 !
3313  if(nkq < 1) &
3314  call q_error('e','CONFIG','Number of wave numbers NKQ < 0')
3315 !
3316  if(naq < 1) &
3317  call q_error('e','CONFIG','Number of directions NKQ < 0')
3318 !
3319  if(nlocus0 < 6) &
3320  call q_error('e', &
3321  'CONFIG','Preferred number of points on locus NLOCUS0 < 6')
3322 !
3323  if(q_sector < 40. .or. q_sector > 180.) &
3324  call q_error('e','CONFIG', &
3325  'Sector too small (<40) or too large (>180)')
3326 !
3327  if(q_dstep <0.1 .or. q_dstep>1000) then
3328  call q_error('e','CONFIG', &
3329  'Value of Q_DSTEP outside range 0.1 - 1000')
3330  write(luq_err,'(a,f8.2)') 'Q_CHKCONFIG: Q_DSTEP:',q_dstep
3331  end if
3332 !
3333  call q_stack('-Q_CHKCONFIG')
3334 !
3335  return
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_chkcons()

subroutine m_xnldata::q_chkcons ( real, dimension(nk,ndir), intent(in)  xnl,
integer, intent(in)  nk,
integer, intent(in)  ndir,
real, intent(out)  sum_e,
real, intent(out)  sum_a,
real, intent(out)  sum_mx,
real, intent(out)  sum_my 
)

Definition at line 3339 of file swmod3.f90.

3339 !------------------------------------------------------------------------------
3340 !
3341 ! +-------+ ALKYON Hydraulic Consultancy & Research
3342 ! | | Gerbrant van Vledder
3343 ! | +---+
3344 ! | | +---+ Last Update: 13 Aug. 2002
3345 ! +---+ | | Release: 4.0
3346 ! +---+
3347 !
3348 !
3349 ! SWAN (Simulating WAves Nearshore); a third generation wave model
3350 ! Copyright (C) 2004-2005 Delft University of Technology
3351 !
3352 ! This program is free software; you can redistribute it and/or
3353 ! modify it under the terms of the GNU General Public License as
3354 ! published by the Free Software Foundation; either version 2 of
3355 ! the License, or (at your option) any later version.
3356 !
3357 ! This program is distributed in the hope that it will be useful,
3358 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
3359 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3360 ! GNU General Public License for more details.
3361 !
3362 ! A copy of the GNU General Public License is available at
3363 ! http://www.gnu.org/copyleft/gpl.html#SEC3
3364 ! or by writing to the Free Software Foundation, Inc.,
3365 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
3366 !
3367 !
3368 ! do not use m_xnldata
3369  implicit none
3370 !
3371 ! 0. Update history
3372 !
3373 ! 29/07/1999 Initial version
3374 ! 01/11/1999 Implicit none introduced
3375 ! 08/12/1999 Bug fixed in definition os momentum sum
3376 ! 13/08/2002 Upgrade to release 4.0
3377 !
3378 ! 1. Purpose:
3379 !
3380 ! Check conservation laws of non-linear transfer
3381 !
3382 ! 2. Method
3383 !
3384 ! The following conservation laws should be fulfilled:
3385 !
3386 ! Wave Energy SUME=0
3387 ! Wave Action SUMA=0
3388 ! Momentum vector SUMMX,SUMMY=0
3389 !
3390 !
3391 ! 3. Parameter list:
3392 !
3393 !Type I/O Name Description
3394 !
3395  integer, intent(in) :: nk ! number of wave numbers
3396  integer, intent(in) :: ndir ! number of directions
3397  real, intent(in) :: xnl(nk,ndir) ! transfer rate
3398  real, intent(out) :: sum_e ! sum of wave energy
3399  real, intent(out) :: sum_a ! sum of wave action
3400  real, intent(out) :: sum_mx ! sum of momentum in x-direction
3401  real, intent(out) :: sum_my ! sum of momentum in y-direction
3402 !
3403 ! 4. Error messages
3404 !
3405 ! 5. Called by:
3406 !
3407 ! XNL_MAIN
3408 !
3409 ! 6. Subroutines used
3410 !
3411 ! Q_STACK
3412 !
3413 ! 7. Remarks
3414 !
3415 ! 8. Structure
3416 !
3417 ! 9. Switches
3418 !
3419 ! 10. Source code
3420 !------------------------------------------------------------------------------
3421 ! Local variables
3422 !
3423  real aa ! action density
3424  real ee ! energy density
3425  real kk ! wave number
3426  real momx ! momentum in x-direction
3427  real momy ! momentum in y-direction
3428  real qq ! bin size
3429 !
3430  integer ia ! counter over directions
3431  integer ik ! counter over wave numbers
3432 !
3433 !------------------------------------------------------------------------------
3434 !
3435  call q_stack('+q_chklaw')
3436 !
3437 ! initialize summations
3438 !
3439  sum_a = 0.
3440  sum_e = 0.
3441  sum_mx = 0.
3442  sum_my = 0.
3443 !
3444  do ik=1,nkq
3445  qq = q_delta*q_dk(ik)
3446  kk = q_k(ik)
3447 !
3448  do ia = 1,naq
3449  aa = xnl(ik,ia)
3450  ee = aa*q_sig(ik)
3451  momx = aa*kk*cos(q_a(ia))
3452  momy = aa*kk*sin(q_a(ia))
3453 !
3454  sum_a = sum_a + aa*qq
3455  sum_e = sum_e + ee*qq
3456  sum_mx = sum_mx + momx*qq
3457  sum_my = sum_my + momy*qq
3458  end do
3459  end do
3460 !
3461  call q_stack('-q_chklaw')
3462 !
3463  return
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_chkres()

subroutine m_xnldata::q_chkres ( real, intent(in)  k1x,
real, intent(in)  k1y,
real, intent(in)  k2x,
real, intent(in)  k2y,
real, intent(in)  k3x,
real, intent(in)  k3y,
real, intent(in)  k4x,
real, intent(in)  k4y,
real, intent(in)  dep,
real, intent(out)  sum_kx,
real, intent(out)  sum_ky,
real, intent(out)  sum_w 
)

Definition at line 3468 of file swmod3.f90.

3468 !------------------------------------------------------------------------------
3469 !
3470 ! +-------+ ALKYON Hydraulic Consultancy & Research
3471 ! | | Gerbrant van Vledder
3472 ! | +---+
3473 ! | | +---+ Last update: 9 Aug. 2002
3474 ! +---+ | | Release: 4.0
3475 ! +---+
3476 !
3477 !
3478 ! SWAN (Simulating WAves Nearshore); a third generation wave model
3479 ! Copyright (C) 2004-2005 Delft University of Technology
3480 !
3481 ! This program is free software; you can redistribute it and/or
3482 ! modify it under the terms of the GNU General Public License as
3483 ! published by the Free Software Foundation; either version 2 of
3484 ! the License, or (at your option) any later version.
3485 !
3486 ! This program is distributed in the hope that it will be useful,
3487 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
3488 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3489 ! GNU General Public License for more details.
3490 !
3491 ! A copy of the GNU General Public License is available at
3492 ! http://www.gnu.org/copyleft/gpl.html#SEC3
3493 ! or by writing to the Free Software Foundation, Inc.,
3494 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
3495 !
3496 !
3497  implicit none
3498 !
3499 ! 0. Update history
3500 !
3501 ! 16/02/2001 Initial version
3502 ! 01/11/2001 Implicit none introduced
3503 ! 09/08/2002 Upgrade to release 4.0
3504 !
3505 ! 1. Purpose:
3506 !
3507 ! Check resonance conditions of 4 interacting wave numbers
3508 ! for a given water depth and dispersion relation
3509 !
3510 ! 2. Method
3511 !
3512 ! The sum of wave number vectors and associated radian frequencies
3513 ! are computed:
3514 !
3515 ! k1 + k2 - (k3 + k4)
3516 ! w1 + w2 - (w3 + w4)
3517 !
3518 ! in which w_i = g k_i tanh(k_i d)
3519 !
3520 ! 3. Parameter list:
3521 !
3522 ! Type I/O Name Description
3523 !----------------------------------------------------------------------
3524  real, intent(in) :: k1x ! x-component of wave number vector k1
3525  real, intent(in) :: k1y ! y-component of wave number vector k1
3526  real, intent(in) :: k2x ! x-component of wave number vector k2
3527  real, intent(in) :: k2y ! y-component of wave number vector k2
3528  real, intent(in) :: k3x ! x-component of wave number vector k3
3529  real, intent(in) :: k3y ! y-component of wave number vector k3
3530  real, intent(in) :: k4x ! x-component of wave number vector k4
3531  real, intent(in) :: k4y ! y-component of wave number vector k4
3532  real, intent(in) :: dep ! depth in m
3533  real, intent(out) :: sum_kx ! sum of x-components of quadruplet
3534  real, intent(out) :: sum_ky ! sum of y-components of quadruplet
3535  real, intent(out) :: sum_w ! sum of radian frequencies
3536 !
3537 ! 4. Error messages
3538 !
3539 ! 5. Subroutines used
3540 !
3541 ! X_DISPER
3542 !
3543 ! 6. Called by:
3544 !
3545 ! Q_MAKEGRID
3546 !
3547 ! 7. Remarks
3548 !
3549 ! 8. Structure
3550 !
3551 ! 9. Switches
3552 !
3553 ! 10. Source code
3554 !------------------------------------------------------------------------------
3555 ! Local variables
3556 !
3557  real w1,w2,w3,w4 ! radian frequecies of wave numbers
3558 !! real x_disper ! dispersion relation
3559  sum_kx = (k1x + k2x) - (k3x + k4x)
3560  sum_ky = (k1y + k2y) - (k3y + k4y)
3561 !
3562 ! compute radian frequency on the basis of current dispersion relation
3563 !
3564  w1 = x_disper(sqrt(k1x**2 + k1y**2),dep)
3565  w2 = x_disper(sqrt(k2x**2 + k2y**2),dep)
3566  w3 = x_disper(sqrt(k3x**2 + k3y**2),dep)
3567  w4 = x_disper(sqrt(k4x**2 + k4y**2),dep)
3568 !
3569  sum_w = w1 + w2 - (w3 + w4)
3570 !
3571  return
Here is the call graph for this function:

◆ q_cmplocus()

subroutine m_xnldata::q_cmplocus ( real, intent(out)  ka,
real, intent(out)  kb,
real, intent(out)  km,
real, intent(out)  kw,
real, intent(out)  loclen 
)

Definition at line 3575 of file swmod3.f90.

3575 !------------------------------------------------------------------------------
3576 !
3577 ! +-------+ ALKYON Hydraulic Consultancy & Research
3578 ! | | Gerbrant van Vledder
3579 ! | +---+
3580 ! | | +---+ Last update: 8 August 2003
3581 ! +---+ | | Release: 5.0
3582 ! +---+
3583 !
3584 !
3585 ! SWAN (Simulating WAves Nearshore); a third generation wave model
3586 ! Copyright (C) 2004-2005 Delft University of Technology
3587 !
3588 ! This program is free software; you can redistribute it and/or
3589 ! modify it under the terms of the GNU General Public License as
3590 ! published by the Free Software Foundation; either version 2 of
3591 ! the License, or (at your option) any later version.
3592 !
3593 ! This program is distributed in the hope that it will be useful,
3594 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
3595 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3596 ! GNU General Public License for more details.
3597 !
3598 ! A copy of the GNU General Public License is available at
3599 ! http://www.gnu.org/copyleft/gpl.html#SEC3
3600 ! or by writing to the Free Software Foundation, Inc.,
3601 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
3602 !
3603 !
3604 ! do not use m_xnldata
3605  use m_constants
3606  use serv_xnl4v5
3607  implicit none
3608 !-------------------------------------------------------------------------------
3609 ! 0. Update history
3610 !
3611 ! Date Description
3612 !
3613 ! 18/11/1999 Initial version
3614 ! 08/12/1999 Tracing of locus updated and Q_TRACE included
3615 ! 22/12/1999 Option Q_POLAR included
3616 ! 05/01/2000 LOCLEN added in interface
3617 ! 09/08/2002 Upgrade to release 4.0
3618 ! 10/09/2002 g added to interface with X_CPLE
3619 ! test output modified
3620 ! 12/06/2003 Call to Z_POYAREA added to check POLAR2
3621 ! 08/08/2003 Check on areas only for loci with k3m/k1m < 100
3622 ! Otherwise machine accuracy plays a role
3623 !
3624 ! 1. Purpose:
3625 !
3626 ! Compute locus function used for the determination of the
3627 ! resonnance condition
3628 !
3629 ! 2. Method
3630 !
3631 ! See ALKYON, 1999
3632 !
3633 ! 3. Parameter list:
3634 !
3635 !Type I/O Name Description
3636 !----------!----------------------------------------------------------------------------
3637  real, intent(out) :: ka,kb ! lowest and highest wave number magnitude of k2-locus
3638  real, intent(out) :: km ! wave number magnitude at mid point
3639  real, intent(out) :: kw ! half width of locus
3640  real, intent(out) :: loclen ! estimated length of locus
3641 !
3642 ! 4. Error messages
3643 !
3644 ! 5. Called by:
3645 !
3646 ! Q_MAKEGRID
3647 !
3648 ! 6. Subroutines used
3649 !
3650 ! z_zero1
3651 !
3652 !
3653 !
3654 ! 7. Remarks
3655 !
3656 ! 8. Structure
3657 !
3658 ! 9. Switches
3659 !
3660 ! 10. Source code
3661 !-------------------------------------------------------------------------------
3662 ! Local variables
3663 !-------------------------------------------------------------------------------
3664  real k1m ! magnitude of wave number k1
3665  real k3m ! magnitude of wave number k3
3666  real pcos,psin ! cosine and sine of normalize angle of P
3667  real klen ! total length of line locus for case w1=w3
3668 !
3669  real kx_beg ! x-component at start point
3670  real ky_beg ! y-component at start point
3671  real kx_end ! x-component at end point
3672  real ky_end ! y-component at end point
3673 !
3674  real dsp,dsm ! distances in plus and minus direction
3675  real sum ! total length of locus
3676 !
3677  real w1,w3 ! radian frequencies of wave numbers k1 and k3
3678  real eps ! local accuracy for determination of roots
3679  real area1 ! area of locus as computed
3680  real area2 ! area of locus as based on LOCPOS and ellipse
3681  real ratio ! maximum ratio between area1 and area2
3682 !
3683  integer ierr ! local error level
3684  integer iloc,jloc ! counters along locus
3685  integer itest ! local test level for test output to unit luqtst
3686  integer ip1 ! index +1
3687  integer im1 ! index -1
3688  integer jj ! counter
3689 !------------------------------------------------------------------------------
3690 ! function declarations
3691 !
3692 !! real x_disper ! dispersion relation
3693 !! real x_cple ! coupling coefficient
3694 !! real x_jacobian ! Jacobian term
3695 !------------------------------------------------------------------------------
3696  call q_stack('+q_cmplocus')
3697 !
3698 ! set initial values
3699 !
3700  eps = 10.*epsilon(1.) ! set accuracy 10 times machine accuracy
3701  itest = iq_test ! assign test level from overall setting
3702 !! itest = 1 ! (re)set local test level
3703 !
3704 ! compute characteristics of configuration
3705 !
3706  px = k1x - k3x
3707  py = k1y - k3y
3708  pmag = sqrt(px**2 + py**2)
3709  xang = atan2(-px,py)
3710  pang = atan2(py,px)
3711  k1m = sqrt(k1x**2 + k1y**2)
3712  k3m = sqrt(k3x**2 + k3y**2)
3713  w1 = x_disper(k1m,q_depth)
3714  w3 = x_disper(k3m,q_depth)
3715  q = w1-w3
3716 !
3717 ! compute cosine and sine of direction of P-vector
3718 ! reverse direction for the case q<0
3719 !
3720  if(q < 0) then
3721  sang = pang+2.*pih
3722  pcos = cos(pang+2.*pih)
3723  psin = sin(pang+2.*pih)
3724  else
3725  sang = pang
3726  pcos = cos(pang)
3727  psin = sin(pang)
3728  end if
3729 !
3730  if(itest >= 1) then
3731  write(luq_tst,'(a,4f11.5)') 'Q_CMPLOCUS: k1x/y k3x/y :', &
3732  k1x,k1y,k3x,k3y
3733  write(luq_tst,'(a,3f11.5)') 'Q_CMPLOCUS: Px Py Pmag :', &
3734  px,py,pmag
3735  write(luq_tst,'(a,3f11.4)') 'Q_CMPLOCUS: Pang Sang Xang :', &
3736  pang*rade,sang*rade,xang*rade
3737  write(luq_tst,'(a,2f11.5)') 'Q_CMPLOCUS: k1m,k3m :', &
3738  k1m,k3m
3739  write(luq_tst,'(a,f11.5)') 'Q_CMPLOCUS: q :',q
3740  end if
3741 !
3742 ! first solution along locus: k2 = k3
3743 !
3744 ! check for special case if q = 0
3745 !
3746  if (abs(q) < eps_q) then
3747 !
3748  call q_loc_w1w3(k1x,k1y,k3x,k3y,nlocus0,x2_loc,y2_loc,x4_loc, &
3749  y4_loc,s_loc)
3750  nlocus1 = nlocus0
3751  ds_loc = s_loc(2)-s_loc(1)
3752  klen = s_loc(nlocus0)
3753  ka = 0.
3754  kb = 0.
3755  km = 0.
3756  kw = 0.
3757  sang = xang
3758 !
3759  else
3760 !------------------------------------------------------------------------------
3761 ! compute characteristics of locus, such as its position in
3762 ! wave number space
3763 !------------------------------------------------------------------------------
3764 !
3765  call q_locpos(ka,kb,km,kw,loclen)
3766  if(iq_err/=0) goto 9999
3767 !
3768 ! compute position of start and end point for tracing
3769 ! the locus
3770 !
3771  kx_beg = ka*pcos
3772  ky_beg = ka*psin
3773  kx_end = kb*pcos
3774  ky_end = kb*psin
3775 !
3776 ! compute position of locus using polar method
3777 ! see Van Vledder (2000)
3778 !
3779 !% call q_polar(ka,kb,kx_beg,ky_beg,kx_end,ky_end,loclen,ierr)
3780  call q_polar2(ka,kb,kx_beg,ky_beg,kx_end,ky_end,loclen,ierr)
3781 !
3782 ! check area of locus by a simple test (added 12 June 2003)
3783 !
3784  call z_polyarea(x2_loc,y2_loc,nlocus1,area1)
3785  area2 = 2.*pih*(kb-ka)*0.5*kw
3786  ratio = max(area1/area2,area2/area1)
3787 !
3788  if(iq_test>=2 .and.ratio>1.5) then
3789  write(luq_tst,'(a,4i4,2e12.4,4f12.5)') &
3790  'Q_CMPLOCUS: Area1/2:',ik_k1,ia_k1,ik_k3,ia_k3,area1,area2, &
3791  ratio,ka,kb,kw
3792  if(ik_k1==1 .and. ia_k1==1 .and. ik_k3==8 .and. ia_k3==9) then
3793  do iloc = 1,nlocus1
3794  write(luq_prt,'(i4,4f12.5)') iloc,x2_loc(iloc), &
3795  y2_loc(iloc),sqrt(x2_loc(iloc)**2 + y2_loc(iloc)),&
3796  atan2(y2_loc(iloc),x2_loc(iloc))*rade
3797  end do
3798  end if
3799  end if
3800 !
3801  if(ratio>1.5 .and. k3m/k1m < 100.) then
3802  call q_error('e','LOCUS','Severe problem in POLAR2')
3803  write(luq_err,'(a)') 'Q_CMPLOCUS: ratio > 1.5'
3804 !
3805  if(iq_test>=2) then
3806  write(luq_tst,'(2i5)') nlocus1,2
3807  do iloc = 1,nlocus1
3808  write(luq_tst,'(2f12.5)') x2_loc(iloc),y2_loc(iloc)
3809  end do
3810  end if
3811  goto 9999
3812  end if
3813 !
3814 ! 01/10/2001
3815 ! compute position of k4 locus by a simple translation
3816 !
3817  do iloc=1,nlocus1
3818  x4_loc(iloc) = x2_loc(iloc) + px
3819  y4_loc(iloc) = y2_loc(iloc) + py
3820  end do
3821 !
3822  end if
3823 !
3824  if (iq_test >=2) write(luq_tst,'(a,4f12.5,i4)') &
3825  'Q_CMPLOCUS: k1x/y k3x/y nlocus:',k1x,k1y,k3x,k3y,nlocus1
3826 !----------------------------------------------------------------------------------
3827 ! compute characteristics around locus
3828 !----------------------------------------------------------------------------------
3829 !
3830  s_loc(1) = 0.
3831  sum = 0
3832 !
3833  do iloc=1,nlocus1
3834 !
3835 ! compute step sizes
3836 !
3837  if (abs(q) < eps_q) then
3838 !
3839 ! for this case the sum of ds_loc is unequal to s_loc(nlocus1)
3840 !
3841  sum = s_loc(nlocus1)
3842  else
3843 !
3844 ! compute indices of previous and next index on locus
3845 !
3846  ip1 = iloc+1
3847  if (ip1 > nlocus1) ip1 = 1
3848  im1 = iloc-1
3849  if (im1 < 1) im1 = nlocus1
3850 !
3851  dsp = sqrt((x2_loc(iloc)-x2_loc(ip1))**2 + &
3852  (y2_loc(iloc)-y2_loc(ip1))**2)
3853  dsm = sqrt((x2_loc(iloc)-x2_loc(im1))**2 + &
3854  (y2_loc(iloc)-y2_loc(im1))**2)
3855  if(iloc < nlocus1) s_loc(iloc + 1) = s_loc(iloc) + dsp
3856  ds_loc(iloc) = 0.5*(dsp + dsm)
3857  sum = sum+ds_loc(iloc)
3858  end if
3859 !
3860 ! compute gradient/Jacobian terms along locus
3861 !
3862  jac_loc(iloc) = x_jacobian(x2_loc(iloc),y2_loc(iloc), &
3863  x4_loc(iloc),y4_loc(iloc))
3864 !
3865 ! compute coupling coefficients along locus
3866 !
3867  k2x = x2_loc(iloc)
3868  k2y = y2_loc(iloc)
3869  k4x = x4_loc(iloc)
3870  k4y = y4_loc(iloc)
3871 !
3872  cple_loc(iloc) = x_cple(k1x,k1y,k2x,k2y,k3x,k3y,k4x,k4y, &
3873  iq_cple,q_depth,q_grav)
3874 !
3875  end do
3876 !
3877  if(itest >= 2) then
3878  do iloc = 1,nlocus1
3879  write(luq_tst,'(a,i4,4f10.5,2e12.5)') &
3880  'Q_CMPLOCUS: k2x k2y ds s jac cp:', &
3881  iloc,x2_loc(iloc),y2_loc(iloc),ds_loc(iloc),s_loc(iloc), &
3882  jac_loc(iloc),cple_loc(iloc)
3883  end do
3884  end if
3885  if(itest >= 1) write(luq_tst,'(a,2f10.5)') &
3886  'Q_CMPLOCUS: length of locus:',sum, &
3887  s_loc(nlocus1)+dsp !0.5*(ds_loc(1)+ds_loc(nlocus1))
3888 !
3889  9999 continue
3890 !
3891  call q_stack('-q_cmplocus')
3892 !
3893  return
all_vars::km
real(sp), dimension(:,:), allocatable, target km
Definition: mod_main.f90:1293
mod_time::abs
Definition: mod_time.f90:64
serv_xnl4v5::z_polyarea
subroutine z_polyarea(xpol, ypol, npol, area)
Definition: swmod3.f90:996
m_constants
Definition: swmod3.f90:22
ice_constants::pih
real(kind=dbl_kind) pih
Definition: ice_constants.f90:206
lims::kb
integer kb
Definition: mod_main.f90:64
ocpcomm4::itest
integer itest
Definition: swmod1.f90:536
m_constants::rade
real rade
Definition: swmod3.f90:40
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_ctrgrid()

subroutine m_xnldata::q_ctrgrid ( integer, intent(in)  itask,
integer, intent(out)  igrid 
)

Definition at line 3897 of file swmod3.f90.

3897 !------------------------------------------------------------------------------
3898 !
3899 ! +-------+ ALKYON Hydraulic Consultancy & Research
3900 ! | | Gerbrant van Vledder
3901 ! | +---+
3902 ! | | +---+ Last update: 27 April 2004
3903 ! +---+ | | Release: 5.04
3904 ! +---+
3905 !
3906 !
3907 ! SWAN (Simulating WAves Nearshore); a third generation wave model
3908 ! Copyright (C) 2004-2005 Delft University of Technology
3909 !
3910 ! This program is free software; you can redistribute it and/or
3911 ! modify it under the terms of the GNU General Public License as
3912 ! published by the Free Software Foundation; either version 2 of
3913 ! the License, or (at your option) any later version.
3914 !
3915 ! This program is distributed in the hope that it will be useful,
3916 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
3917 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3918 ! GNU General Public License for more details.
3919 !
3920 ! A copy of the GNU General Public License is available at
3921 ! http://www.gnu.org/copyleft/gpl.html#SEC3
3922 ! or by writing to the Free Software Foundation, Inc.,
3923 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
3924 !
3925 !
3926 ! do not use m_xnldata
3927  use m_fileio
3928  implicit none
3929 !------------------------------------------------------------------------------
3930 ! 0. Update history
3931 !
3932 ! Version Date Modification
3933 !
3934 ! 29/07/1999 Initial version
3935 ! 11/10/1999 Error messages via module
3936 ! 12/10/1999 File I/O of interaction grid files added, and consistency check
3937 ! 25/10/1999 Contents of q_header extended with iq_grid & iq_start & nlocus0
3938 ! 27/10/1999 Close statement after reading BQF file
3939 ! 01/11/1999 Close statments after call of Q_GRID
3940 ! 03/11/1999 Parameter IQ_MAKE included
3941 ! 22/11/1999 Use of z_fileio modified, use parameter IUERR if an attempt
3942 ! to open a non-existing file was made
3943 ! 30/11/1999 Extra messages to logging file when file are closed
3944 ! 03/01/2000 IQ_START replaced by IQ_LOCUS
3945 ! 12/01/2001 Output parameter IGRID added
3946 ! igrid=0: a proper grid exists or has been made, and will be read
3947 ! =1: grid file does not exist
3948 ! =2: grid file exists, but it is incorrect
3949 ! 8/08/2002 Upgrade to release 4.0
3950 ! 15/08/2002 Bug fixed ininitialisation of igrid
3951 ! 19/08/2002 header extended with parameter IQ_INTERP
3952 ! 20/08/2002 wave number array replaced by sigma array in grid file
3953 ! 22/08/2002 Extra i/o check when reading BQF file
3954 ! 23/08/2002 retrieve number of point on locus from BQF file
3955 ! 09/09/2002 aqfile and bqfile 5 units for depth
3956 ! 10/09/2002 new algorithm for coding depth
3957 ! Test added to avoid rereading of last read/generated BQF file
3958 ! 08/10/2002 Output to test file made conditional
3959 ! 05/09/2003 Water depth for creating and testing BQF file DSTEP dependend
3960 ! 09/09/2003 Bug fixed in assigning IGRID=0 when BQF still in memory
3961 ! 13/09/2003 When BFQ incorrupt, it is deleted and a new one is created
3962 ! Bug fixed in setting of s_depth when iq_disp==1
3963 ! 24/12/2003 QUAD_T2 and QUAD_T4 always in BQF
3964 ! 30/12/2003 Bug fixed in reading test data from BQF
3965 ! 27/04/2004 Bug fixed when depth < q_dstep
3966 !
3967 ! 1. Purpose:
3968 !
3969 ! Control of interaction grid administration
3970 !
3971 ! 2. Method
3972 !
3973 ! 3. Parameters used
3974 !
3975  integer, intent(in) :: itask ! task to perform by Q_CTRGRID
3976 ! ==1: read and check header block
3977 ! ==2: read and write grid file, according to
3978 ! setting of IQ_MAKE
3979  integer, intent(out) :: igrid ! status of grid checking
3980 ! ==0: a proper grid exists
3981 ! ==1: grid file does not exist
3982 ! ==2: grid file exists, but it is incorrect
3983 ! ==3: read error in accessing grid information
3984 !
3985 ! 4. Error messages
3986 !
3987 ! 5. Called by:
3988 !
3989 ! XNL_INIT
3990 ! Q_SEARCHGRID
3991 !
3992 ! 6. Subroutines used
3993 !
3994 ! Q_STACK
3995 ! Q_ERROR
3996 ! Q_MAKEGRID
3997 !
3998 ! 7. Remarks
3999 !
4000 ! The generation of the database file depend on the control varaible of IQ_MAKE
4001 ! if IQ_MAKE==1, make a grid when needed
4002 ! 2, always make grid
4003 ! 3, make a grid and stop, useful for test purposes
4004 !
4005 ! The maximum number of points on the locus, as stored in the BQF file
4006 ! is read from the header and stored in the variable NLOCUS
4007 !
4008 ! 8. Structure
4009 !
4010 ! Make header of grid file
4011 ! Construct name of grid file
4012 ! Check existence of grid file
4013 ! if grid file exists
4014 ! read header
4015 ! check header
4016 ! read first data block
4017 ! check first data block
4018 ! - directions
4019 ! - wave numbers
4020 ! - depth
4021 ! set status of grid file
4022 ! else
4023 ! set status of grid file
4024 ! end if
4025 !
4026 ! set status of generating/reading grid file
4027 !
4028 ! if make new grid
4029 ! compute grid parameters
4030 ! write grid parameters to file
4031 ! else
4032 ! read grid parameters from file
4033 ! end if
4034 !
4035 !
4036 ! 9. Switches
4037 !
4038 ! 10. Source code
4039 !-------------------------------------------------------------------------------
4040 ! Local variables
4041 !
4042  integer iaz,ikz,jaz,jkz ! counters for checking header of BQF file
4043  integer iz_geom,iz_disp,iz_cple ! values as read in BQF file
4044  integer naz ! number of directions in BQF file
4045  integer nkz ! number of wave numbers in BQF file
4046  integer idep,jdep ! coding for depth in BQF file
4047 !
4048  logical lbqf ! flag for existence of BQF file
4049  real s_depth ! (stepped) depth
4050  real q_depth_saved ! save input water depth, needed after call to Q_MAKEGRID
4051  real z_depth ! water depth in BQF file
4052  real, allocatable :: z_ad(:),z_sig(:) ! directions and radian frequencies of grid in BQF file
4053  integer ierr,iuerr ! error variables
4054 !------------------------------------------------------------------------------
4055 !
4056  call q_stack('+q_ctrgrid')
4057 !
4058 ! echo input arguments
4059 !
4060  if(iq_prt>=1) write(luq_prt,'(a,i4,f16.3)') &
4061  'Q_CTRGRID: input arguments: itask depth:',itask,q_depth
4062 !
4063  q_depth_saved = q_depth
4064 !
4065 ! generate header of BQF file
4066 !
4067  q_header = '000000000000000000000'
4068 ! 123456789012345678901
4069 ! 1 2
4070  write(q_header,'(3i3.3,6i2.2)') naq,nkq,nlocus0, &
4071  iq_grid,iq_geom,iq_disp,iq_cple,iq_locus,iq_interp
4072 !
4073  if(iq_prt>=2) then
4074  write(luq_prt,'(2a)') 'Q_CTRGRID: header info:',trim(q_header)
4075  write(luq_prt,'(a,3i5)') 'Q_CTRGRID: naq nkq nlocus0:',naq,nkq, &
4076  nlocus0
4077  write(luq_prt,'(a,3i3)') 'Q_CTRGRID: iq_grid,iq_geom,iq_disp:', &
4078  iq_grid,iq_geom,iq_disp
4079  write(luq_prt,'(a,3i3)') &
4080  'Q_CTRGRID: iq_cple,iq_locus,iq_interp:',iq_cple,iq_locus, &
4081  iq_interp
4082  end if
4083 !
4084 !------------------------------------------------------------------------------
4085 ! construct name of grid file
4086 !
4087  if(iq_disp==1) then
4088  bqname = 'quad99999.bqf'
4089  s_depth = q_maxdepth
4090 !
4091  elseif(iq_disp==2) then
4092 !
4093 !---------------------------------------------------------------------------------------------
4094 ! generate code for actual depth
4095 !---------------------------------------------------------------------------------------------
4096  idep = int(q_depth/q_dstep+0.5)
4097  idep = max(1,idep)
4098  jdep = idep*int(10.*q_dstep)
4099  jdep = max(1,jdep)
4100  jdep = min(99999,jdep)
4101 !
4102  s_depth = real(idep)*q_dstep
4103 !
4104  if(iq_prt>=2) write(luq_prt,'(a,3f10.2,2i6)') &
4105  'Q_CTRGRID: q_depth q_dstep s_depth idep jdep:', &
4106  q_depth,q_dstep,s_depth,idep,jdep
4107 !
4108  bqname = 'quad00000.bqf'
4109  write(bqname(5:9),'(i5.5)') min(int(q_maxdepth*10),jdep)
4110 !
4111  else
4112  call q_error('e','DISPER','Incorrect value for IQ_DISP')
4113  write(luq_err,'(a,i4)') 'IQ_DISP=',iq_disp
4114  goto 9999
4115  end if
4116 !
4117 !
4118 !-------------------------------------------------------------------------------------------
4119 ! Compare LASTQUADFILE with bqname
4120 ! if equal skip reading of BQF file, including checks of header
4121 !-------------------------------------------------------------------------------------------
4122  if(iq_prt>=2) write(luq_prt,'(4a)') &
4123  'Q_CTRGRID: Last and actual BQF file: ', &
4124  trim(lastquadfile),' & ',trim(bqname)
4125 !
4126  if(lastquadfile==bqname) then
4127  if(iq_screen>0) write(iscreen,'(2a)') &
4128  'Q_CTRGRID: Rereading of bqfile skipped: ',lastquadfile
4129  if(iq_prt>=1) write(luq_prt,'(2a)') &
4130  'Q_CTRGRID: Rereading of bqfile skipped: ',lastquadfile
4131  igrid = 0
4132  goto 9999
4133  end if
4134 !-------------------------------------------------------------------------------------------
4135  if(iq_prt >= 2) then
4136  write(luq_prt,'(2a)') 'Q_CTRGRID: Header line of grid file:', &
4137  trim(q_header)
4138  write(luq_prt,'(2a)') 'Q_CTRGRID: Name of BINARY grid file:', &
4139  trim(bqname)
4140  end if
4141 !------------------------------------------------------------------------------
4142 !
4143 ! check if binary data file exists
4144 !
4145  tempfile=bqname
4146  call z_fileio(tempfile,'OU',iufind,luq_bqf,iuerr) ! binary quadruplet file
4147 !
4148  if(iq_prt >= 2) write(luq_prt,'(2a,2x,2i4)') &
4149  'Q_CTRGRID: BQNAME:',trim(bqname),luq_bqf,iuerr
4150 !
4151  if(itask==2 .and. iq_make==2) luq_bqf=-1
4152 !
4153 ! if the file exists,
4154 ! read header information
4155 ! check header of file
4156 ! end
4157 !
4158 ! If header is incorrect, set flag IQ_GRID to TRUE for generating new grid
4159 !
4160  if(luq_bqf > 0 .and. iuerr ==0) then
4161  if(iq_prt >= 2) then
4162  write(luq_prt,'(2a)') &
4163  'Q_CTRGRID: Binary grid file detected: ',trim(bqname)
4164  write(luq_prt,'(a,i4)') 'Q_CTRGRID: Connected to unit:', &
4165  luq_bqf
4166  end if
4167 !
4168 !
4169 ! grid file exists, unless proven otherwise
4170 !---------------------------------------------------------------------------------
4171 !
4172  lq_grid = .false.
4173  igrid = 0
4174  read(luq_bqf,iostat=ierr) r_header
4175  if(ierr/=0) then
4176  call q_error('w','READBQF','Read error for header in BQF file')
4177  write(luq_err,'(a)') 'BQF file deleted'
4178  tempfile=bqname
4179  call z_fileio(tempfile,'DU',iufind,luq_bqf,iuerr) ! binary quadruplet file
4180  igrid = 3
4181  lq_grid = .true.
4182  else
4183  read(r_header,'(6x,i3)') nlocus
4184 !
4185  if(iq_prt>=2) then
4186  write(luq_prt,'(a,2i4)') 'Q_CTRGRID: luq_bqf ierr:',luq_bqf, &
4187  ierr
4188  write(luq_prt,'(2a)') 'Q_CTRGRID: r_header: ',trim(r_header)
4189  end if
4190 
4191  if(iq_prt >= 1) then
4192  write(luq_prt,'(4a)') 'Q_CTRGRID: bqname : ',trim(bqname)
4193  write(luq_prt,'(4a)') 'Q_CTRGRID: q_header: ',trim(q_header)
4194  write(luq_prt,'(4a)') 'Q_CTRGRID: r_header: ',trim(r_header)
4195  end if
4196  end if
4197 !-----------------------------------------------------------------------------
4198 ! check header of grid file
4199 !-----------------------------------------------------------------------------
4200 !
4201  if(trim(r_header)/=trim(q_header).and. .not.lq_grid) then
4202  lq_grid = .true.
4203  igrid = 2
4204  if(iq_prt >=2) then
4205  write(luq_prt,'(a,1x,a)') &
4206  'Q_CTRGRID: Header in binary quad file :', &
4207  trim(r_header)
4208  write(luq_prt,'(a,1x,a)') &
4209  'Q_CTRGRID: Expected header of binary quad file:', &
4210  trim(q_header)
4211  write(luq_prt,'(a)') 'Q_CTRGRID: The file headers disagree'
4212  write(luq_prt,'(a)') &
4213  'Q_CTRGRID: A new grid will be generated'
4214  end if
4215  end if
4216 !------------------------------------------------------------------------------
4217 ! check other parts of binary grid file
4218 !
4219  if(.not.lq_grid) then
4220  read(luq_bqf) naz,nkz
4221  allocate (z_sig(nkz),z_ad(naz))
4222  read(luq_bqf) z_sig
4223  read(luq_bqf) z_ad
4224  read(luq_bqf) iz_geom,iz_disp,iz_cple
4225  read(luq_bqf) z_depth
4226 !
4227  if(iq_prt >=2) then
4228  write(luq_prt,'(a)') 'Q_CTRGRID: Contents of BQF file'
4229  write(luq_prt,'(2a)') 'Q_CTRGRID: Header:',trim(r_header)
4230  write(luq_prt,'(a,i4)') 'Q_CTRGRID: NK:',nkz
4231  write(luq_prt,'(a,i4)') 'Q_CTRGRID: NA:',naz
4232  end if
4233  end if
4234 !---------------------------------------------------------------------------------------
4235 ! check spectral interaction grid and depth for consistency
4236 !---------------------------------------------------------------------------------------
4237  if(.not. lq_grid) then
4238  do iaz = 1,naz
4239  if(abs(q_ad(iaz)-z_ad(iaz)) > 0.01) then
4240  write(luq_prt,'(a)') 'Q_CTRGRID: Directions do not agree'
4241  do jaz=1,naz
4242  write(luq_prt,'(1x,a,i4,2f10.3)') 'iaz q_ad z_ad:',jaz, &
4243  q_ad(jaz),z_ad(jaz)
4244  end do
4245  lq_grid = .true.
4246  igrid = 2
4247  exit
4248  end if
4249  end do
4250  end if
4251 !
4252  if(.not. lq_grid) then
4253  do ikz = 1,nkz
4254  if(abs(q_sig(ikz)-z_sig(ikz)) > 0.01) then
4255  write(luq_prt,'(a)') 'Q_CTRGRID: Wave numbers do not agree'
4256  do jkz=1,nkz
4257  write(luq_prt,'(1x,a,i4,2f10.3)') 'ikz q_k z_sig:',jkz, &
4258  q_sig(jkz),z_sig(jkz)
4259  end do
4260  lq_grid = .true.
4261  igrid = 2
4262  exit
4263  end if
4264  end do
4265  end if
4266 !
4267 ! compare water depths
4268 !
4269  if(abs(z_depth-s_depth) > 0.09 .and. iq_disp > 1 .and. &
4270  .not. lq_grid) then
4271  write(luq_prt,'(a)') 'Q_CTRGRID: Water depths do not agree'
4272  write(luq_prt,'(a,2f16.2)') 'Q_CTRGRID: q_depth z_depth:', &
4273  q_depth,z_depth
4274  lq_grid = .true.
4275  igrid = 2
4276  end if
4277 !
4278  if(lq_grid) then
4279  close(luq_bqf)
4280  if(iq_log >= 1) write(luq_log,'(a)') &
4281  'Q_CTRGRID: Existing BQF-file invalid, it will be closed'
4282  end if
4283 !
4284  else
4285  lq_grid = .true.
4286  igrid = 1
4287  end if
4288 !------------------------------------------------------------------------------
4289  if(itask==1) then
4290  if(luq_bqf>0) call z_fclose(luq_bqf)
4291  goto 9999
4292  end if
4293 !-----------------------------------------------------------------------------
4294 ! if lq_grid==true a new grid has to be generated
4295 ! if not, read the grid information into memory
4296 ! or iq_make==2 always make an interaction grid
4297 ! or iq_make==3 as 2, plus stop after making grid
4298 !
4299  if(lq_grid .or. iq_make==2 .or. iq_make==3) then
4300 !
4301  if(luq_bqf>0) call z_fclose(luq_bqf)
4302  tempfile=bqname
4303  call z_fileio(tempfile,'UU',iufind,luq_bqf,iuerr) ! binary quadruplet file
4304 !
4305  if(iq_log >= 1) then
4306  write(luq_log,*)
4307  write(luq_log,'(a)') 'Q_CTRGRID: New grid will be generated'
4308  write(luq_log,'(a,a)') 'Q_CTRGRID: Name of BQF file:', &
4309  trim(bqname)
4310  write(luq_log,'(a,i4)') 'Q_CTRGRID: '//trim(bqname)// &
4311  ' connected to :',luq_bqf
4312  end if
4313 !
4314  if(iq_screen >= 1) write(iscreen,'(2a)') &
4315  'Q_CTRGRID: Generating wave number grid for '// &
4316  'quadruplet interactions: ',trim(bqname)
4317 !
4318  q_depth = s_depth
4319  call q_makegrid
4320  q_depth = q_depth_saved
4321 !
4322  if(iq_err /=0) then
4323  lastquadfile = 'quad_err_.bqf'
4324  goto 9999
4325  end if
4326 !
4327  igrid = 0
4328 !
4329  close(luq_bqf)
4330 !
4331  if(iq_log >=1) then
4332  write(luq_log,'(a,i4)') 'Q_CTRGRID: '//trim(bqname)// &
4333  ' disconnected from:',luq_bqf
4334  end if
4335 !
4336  if(iq_screen >=1) write(iscreen,'(a)') &
4337  'Q_CTRGRID: Grid generation completed succesfully'
4338 !----------------------------------------------------------------------------------------
4339 !
4340 ! check of header and spectral grid succesfull
4341 ! such that data can be read from BQF file
4342 !----------------------------------------------------------------------------------------
4343 !
4344  else
4345  if(iq_screen >= 1) write(iscreen,'(2a)') &
4346  'Q_CTRGRID: Reading existing grid: ',trim(bqname)
4347  if(iq_prt >= 1) write(luq_prt,'(2a)') &
4348  'Q_CTRGRID: Existing grid will be read:',trim(bqname)
4349  if(iq_log >= 1) write(luq_log,'(2a)') &
4350  'Q_CTRGRID: Existing grid will be read:',trim(bqname)
4351 !
4352  read(luq_bqf) quad_nloc
4353  read(luq_bqf) quad_ik2
4354  read(luq_bqf) quad_ia2
4355  read(luq_bqf) quad_ik4
4356  read(luq_bqf) quad_ia4
4357  read(luq_bqf) quad_w1k2
4358  read(luq_bqf) quad_w2k2
4359  read(luq_bqf) quad_w3k2
4360  read(luq_bqf) quad_w4k2
4361  read(luq_bqf) quad_w1k4
4362  read(luq_bqf) quad_w2k4
4363  read(luq_bqf) quad_w3k4
4364  read(luq_bqf) quad_w4k4
4365  read(luq_bqf) quad_zz
4366  read(luq_bqf) quad_t2
4367  read(luq_bqf) quad_t4
4368 
4369 
4370  read(luq_bqf,iostat=ierr) quad_jac
4371  if(ierr/=0) then
4372  call q_error('e','READBQF', &
4373  'Read error for test data in BQF file')
4374  write(luq_err,'(a)') &
4375  'BQF file probably generated with test option off'
4376  igrid = 3
4377  goto 9999
4378  end if
4379  read(luq_bqf) quad_cple
4380  read(luq_bqf) quad_sym
4381  read(luq_bqf) quad_ws
4382 !
4383  lastquadfile = bqname
4384 !
4385  close(luq_bqf)
4386 !
4387  if(iq_log >=1) then
4388  write(luq_log,'(a,i4)') 'Q_CTRGRID: '//trim(bqname)// &
4389  ' disconnected from:',luq_bqf
4390  end if
4391 
4392  end if
4393 !
4394  9999 continue
4395  if(iq_prt>=1) write(luq_prt,'(a,i4,f10.2)') &
4396  'Q_CTRGRID: on exit igrid & q_depth:',igrid,q_depth
4397 !
4398  if (allocated(z_ad)) deallocate(z_ad,z_sig)
4399 !
4400  if(iq_screen > 2) write(iscreen,'(2a,2x,f12.2)') &
4401  'Q_CTRGRID: On exit LASTQUADFILE & q_depth: ',lastquadfile, &
4402  q_depth
4403  if(iq_prt >=2) write(luq_prt,'(2a,2x,f12.2)') &
4404  'Q_CTRGRID: On exit LASTQUADFILE & q_depth: ',lastquadfile, &
4405  q_depth
4406 !
4407  call q_stack('-q_ctrgrid')
4408 !
4409  return
mod_time::abs
Definition: mod_time.f90:64
m_fileio::z_fileio
subroutine z_fileio(filename, qual, iufind, iunit, iostat)
Definition: swmod3.f90:147
m_fileio::z_fclose
subroutine z_fclose(iunit)
Definition: swmod3.f90:446
m_fileio::tempfile
character(len=80) tempfile
Definition: swmod3.f90:142
m_fileio
Definition: swmod3.f90:74
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_dscale()

subroutine m_xnldata::q_dscale ( real, dimension(nsig,nang), intent(in)  n,
real, dimension(nsig), intent(in)  sigma,
real, dimension(nang), intent(in)  angle,
integer, intent(in)  nsig,
integer, intent(in)  nang,
real, intent(in)  depth,
real, intent(in)  grav_w,
real, intent(out)  q_dfac 
)

Definition at line 4413 of file swmod3.f90.

4413 !------------------------------------------------------------------------------
4414 !
4415 ! +-------+ ALKYON Hydraulic Consultancy & Research
4416 ! | | Gerbrant van Vledder
4417 ! | +---+
4418 ! | | +---+ Last update: 23 Aug. 2002
4419 ! +---+ | | Release: 5.0
4420 ! +---+
4421 !
4422 !
4423 ! SWAN (Simulating WAves Nearshore); a third generation wave model
4424 ! Copyright (C) 2004-2005 Delft University of Technology
4425 !
4426 ! This program is free software; you can redistribute it and/or
4427 ! modify it under the terms of the GNU General Public License as
4428 ! published by the Free Software Foundation; either version 2 of
4429 ! the License, or (at your option) any later version.
4430 !
4431 ! This program is distributed in the hope that it will be useful,
4432 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
4433 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
4434 ! GNU General Public License for more details.
4435 !
4436 ! A copy of the GNU General Public License is available at
4437 ! http://www.gnu.org/copyleft/gpl.html#SEC3
4438 ! or by writing to the Free Software Foundation, Inc.,
4439 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
4440 !
4441 !
4442  use serv_xnl4v5
4443  implicit none
4444 !
4445 ! 0. Update history
4446 !
4447 ! Date Modification
4448 !
4449 ! 25/02/1999 Initial version
4450 ! 2/12/1999 Result modified if total energy <= 0
4451 ! Cosmetic changes
4452 ! 13/08/2002 Upgrade to release 4.0
4453 ! 23/09/2002 Mean wave number multiplied by 0.75
4454 !
4455 ! 1. Purpose:
4456 !
4457 ! Compute scaling factor for nonlinear transfer in finite depth
4458 !
4459 ! 2. Method
4460 !
4461 ! Compute mean wave number km
4462 !
4463 ! Compute scale factor based on parameterized function of (km*d)
4464 ! according to Herterich and Hasselmann
4465 ! and parameterisation from WAM model
4466 !
4467 !
4468 ! 3. Interface parameter list:
4469 !
4470 ! Type I/O Name Description
4471 !-------------------------------------------------------------------------
4472  integer, intent (in) :: nsig ! Number of sigma-values
4473  integer, intent (in) :: nang ! Number of directions
4474  real, intent(in) :: n(nsig,nang) ! N(nsig,nang) Action density
4475  real, intent(in) :: sigma(nsig) ! sigma values
4476  real, intent(in) :: angle(nang) ! directions in (radians)
4477  real, intent(in) :: depth ! Depth (m)
4478  real, intent(in) :: grav_w ! Gravitational acceleration
4479  real, intent(out) :: q_dfac ! scale factor
4480 !
4481 ! 4. Error messages
4482 !
4483 ! 5. Called by:
4484 !
4485 ! XNL_MAIN
4486 !
4487 ! 6. Subroutines used
4488 !
4489 ! x_wnumb
4490 ! z_steps
4491 ! q_stack
4492 !
4493 ! 7. Remarks
4494 !
4495 ! 8. Structure
4496 !
4497 ! 9. Switches
4498 !
4499 ! 10. Source code
4500 !------------------------------------------------------------------------------
4501 ! local variables
4502 !
4503  real w ! radian frequency
4504  real kk ! local wave number
4505  real sqkk ! square root of local wave number
4506  real dnn ! summation quantity
4507  real kms ! mean wave number
4508  real kd ! depth*mean wave number product
4509  real sum0 ! summation variable for total energy
4510  real sumk ! summation variable for wave number
4511  real delta ! directional step, in radians
4512 !
4513  integer isig ! counter over sigma loop
4514  integer iang ! counter over direction loop
4515 !
4516 ! functions
4517 !!! real z_wnumb ! function to compute wave number
4518 !
4519 ! temporary data
4520 !
4521  real dsigma(nsig) ! step size of sigma array, used for integration
4522 !------------------------------------------------------------------------------
4523 !
4524  call q_stack('+q_dscale')
4525 !
4526  call z_steps(sigma,dsigma,nsig) ! compute step size of sigma's
4527  delta = angle(2)-angle(1) ! compute directional step (radians)
4528 !
4529  sum0 = 0.
4530  sumk = 0.
4531 !
4532 ! compute sums for total energy andwave number
4533 !
4534  do isig = 1,nsig
4535  w = sigma(isig)
4536  kk = z_wnumb(w,depth,grav_w) ! compute wave number for given sigma,depth
4537  sqkk = sqrt(kk)
4538  do iang=1,nang
4539  dnn = n(isig,iang)*dsigma(isig)*delta
4540  sum0 = sum0 + dnn
4541  sumk = sumk + 1./sqkk*dnn
4542  end do
4543  end do
4544 !
4545 ! compute mean wave number and scale factor based
4546 ! on the WAM approximation
4547 !
4548  if(sum0 > 0) then
4549  kms = (sum0/sumk)**2
4550  kd = max(0.5,0.75*kms*depth)
4551  q_dfac = 1+5.5/kd*(1.-5./6.*kd)*exp(-5./4.*kd)
4552  if(iq_test>=1) write(luq_tst,'(a,3f10.4)') 'Q_DSCALE kms,kd, &
4553  q_dfac:', &
4554  kms,kd,q_dfac
4555 ! pause
4556  else
4557  kms = 0.
4558  kd = 0.
4559  q_dfac = 1.
4560  end if
4561 !
4562  call q_stack('-q_dscale')
4563 !
4564  return
all_vars::w
real(sp), dimension(:,:), allocatable, target w
Definition: mod_main.f90:1279
swcomm3::grav_w
real grav_w
Definition: swmod1.f90:1721
serv_xnl4v5::z_steps
subroutine z_steps(x, dx, nx)
Definition: swmod3.f90:1107
lims::n
integer n
Definition: mod_main.f90:55
m_genarr::depth
real, dimension(:), allocatable, save depth
Definition: swmod2.f90:768
serv_xnl4v5::z_wnumb
real function z_wnumb(w, d, grav_w)
Definition: swmod3.f90:1467
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_error()

subroutine m_xnldata::q_error ( character(len=1), intent(in)  err_type,
character(len=*), intent(in)  err_name,
character(len=*), intent(in)  err_msg 
)

Definition at line 4568 of file swmod3.f90.

4568 !------------------------------------------------------------------------------
4569 !
4570 ! +-------+ ALKYON Hydraulic Consultancy & Research
4571 ! | | Gerbrant van Vledder
4572 ! | +---+
4573 ! | | +---+ Last update 8 Aug. 2002
4574 ! +---+ | | Release: 4.0
4575 ! +---+
4576 !
4577 !
4578 ! SWAN (Simulating WAves Nearshore); a third generation wave model
4579 ! Copyright (C) 2004-2005 Delft University of Technology
4580 !
4581 ! This program is free software; you can redistribute it and/or
4582 ! modify it under the terms of the GNU General Public License as
4583 ! published by the Free Software Foundation; either version 2 of
4584 ! the License, or (at your option) any later version.
4585 !
4586 ! This program is distributed in the hope that it will be useful,
4587 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
4588 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
4589 ! GNU General Public License for more details.
4590 !
4591 ! A copy of the GNU General Public License is available at
4592 ! http://www.gnu.org/copyleft/gpl.html#SEC3
4593 ! or by writing to the Free Software Foundation, Inc.,
4594 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
4595 !
4596 !
4597 ! do not use m_xnldata
4598  use m_fileio
4599  implicit none
4600 !
4601 ! 0. Update history
4602 !
4603 ! 0.01 22/06/1999 Initial version
4604 ! 0.02 20/07/1999 Error message included
4605 ! 0.03 24/09/1999 Full message read from file Q_ERROR.TXT
4606 ! input argument ERR_NAME added
4607 ! 0.04 13/10/1999 Reading of multiple lines in Q_ERROR.TXT file
4608 ! 0.05 26/11/1999 Layout modified
4609 ! 0.06 30/11/1999 Extra output added, also to screen
4610 ! 4.01 08/08/2002 Upgrade to release 4
4611 !
4612 ! 1. Purpose:
4613 !
4614 ! Error handling routine, produces a warning to an error
4615 ! that has occured prints the error message and print
4616 ! module stack to trace the origin of the error/
4617 !
4618 ! 3. Parameter list:
4619 !
4620 !Type I/O Name Description
4621 !------------------------------------------------------------------------------
4622  character(len=1), intent(in) :: err_type ! type of error
4623 ! w or W: Warning or non-terminating error
4624 ! e or E: terminating error
4625  character(len=*), intent(in) :: err_name ! reference to error message
4626  character(len=*), intent(in) :: err_msg ! Optional additional error message
4627 !
4628 ! 4. Error messages
4629 !
4630 ! 5. Called by:
4631 !
4632 ! All q_** subroutines
4633 !
4634 ! 6. Subroutines used
4635 !
4636 ! 7. Remarks
4637 !
4638 ! The reference to an error message is stored in the
4639 ! string ERR_NAME. For each error number an associated
4640 ! error is given.
4641 !
4642 ! No call is made to subroutine q_trace to avoid
4643 ! infinite recursion
4644 !
4645  character(len=80) qline ! Input line from file with error messges
4646  integer ntext ! number of text line
4647  integer iend ! indicator for end of line
4648  integer iutxt ! unit number for text file
4649  integer iuerr ! indicator for error
4650  integer j_stack ! counter in printing stack
4651  integer ispace ! indicates that first character of line is space
4652 !
4653  tempfile = trim(qbase)//'.err'
4654  call z_fileio(tempfile,'UF',iufind,luq_err,iuerr) ! error messages
4655 !
4656 ! logging of unit number
4657 !
4658  if(iq_log >= 1) write(luq_log,'(a,i4)') &
4659  'Q_ERROR: '//trim(qbase)//'.ERR connected to unit:',luq_err
4660 !
4661 ! write general information, when the first error or
4662 !
4663  if(iq_warn ==0 .and. iq_err==0) then
4664  write(luq_err,'(a)') q_version
4665  write(luq_err,'(a)') &
4666  '------------------------------------------------------------'
4667  end if
4668 !
4669 ! check type of error
4670 !
4671  if(index('wW',err_type) > 0) then
4672  iq_warn = iq_warn + 1
4673  write(luq_err,'(a,i4)') 'Warning or non-terminating error:', &
4674  iq_warn
4675  write(luq_err,'(a,a)') 'Name of error:',trim(err_name)
4676 !
4677  elseif(index('eE',err_type) > 0) then
4678  iq_err = iq_err + 1
4679  write(luq_err,'(a,i4)') 'Terminating error:',iq_err
4680  write(luq_err,'(a,a)') 'Name of error:',trim(err_name)
4681  write(*,'(1x,a,i4)') 'Terminating error:',iq_err
4682  write(*,'(1x,a,a)') 'Name of error:',trim(err_name)
4683  end if
4684 !
4685 ! search explanation of error message in the file
4686 ! QF_ERROR, set in XNL_INIT
4687 !
4688  ntext = len_trim(err_name)
4689 !
4690  if(ntext > 0) then
4691  tempfile=qf_error
4692  call z_fileio(tempfile,'OF',iufind,luq_txt,iutxt)
4693 !
4694  if(iutxt < 0) then
4695  if(iq_log > 0) write(luq_log,'(3a)') &
4696  'Q_ERROR: File ',trim(qf_error), &
4697  ' does not exist in current directory'
4698 !
4699  else
4700  if(iq_log >= 1) write(luq_log,'(a,i4)') &
4701  'Q_ERROR: File Q_ERROR.TXT connected to unit:',luq_txt
4702  iend=0
4703 !
4704 ! scan all lines in the text file with error messages
4705 !
4706  do while (iend==0)
4707  read(luq_txt,'(a)',iostat=iend) qline
4708  if(iend==0) then
4709 !
4710 ! check code word exists in text file
4711 !
4712  if(qline(1:ntext) == err_name(1:ntext)) then
4713  write(luq_err,*)
4714  write(luq_err,'(a)') &
4715  'Explanation of error, and recommended action'
4716  write(luq_err,'(a)') &
4717  '--------------------------------------------'
4718  write(luq_err,'(a)') trim(qline)
4719 !
4720 ! read following lines until end of file or a non-space in column 1
4721 !
4722  ispace = 1
4723  do while (ispace ==1)
4724  read(luq_txt,'(a)',iostat=iend) qline
4725 !
4726 ! check conditions
4727 !
4728  if(iend==0) then
4729  if(qline(1:1) == ' ') then
4730  write(luq_err,'(a)') trim(qline)
4731  else
4732  ispace = 0
4733  end if
4734  else
4735  ispace = 0
4736  end if
4737  end do
4738  end if
4739  end if
4740  end do
4741 !
4742 ! close text file with error messages
4743 !
4744  close(luq_txt)
4745  if(iq_log >= 1) write(luq_log,'(3a,i4)') &
4746  'q_error: file ',trim(qf_error),' disconnected from unit:', &
4747  luq_txt
4748  end if
4749  end if
4750 !
4751  if(len_trim(err_msg) > 0) then
4752  write(luq_err,*)
4753  write(luq_err,'(a)') 'additional message from point of occurrence:'
4754  write(luq_err,'(a)') trim(err_msg)
4755  write(luq_err,*)
4756  end if
4757 !
4758 ! print stack of subroutines to trace the location where the
4759 ! error occurred
4760 !
4761  write(luq_err,'(a)') 'trace of error'
4762  write(luq_err,'(a)') '--------------'
4763  do j_stack=1,iq_stack
4764  write(luq_err,'(1x,i4,2x,a)') j_stack,trim(cstack(j_stack))
4765  end do
4766 !
4767  write(luq_err,*)
4768 !
4769  if(iq_warn > 10) stop 'too many warnings'
4770 !
4771  return
control::iend
integer(itime) iend
Definition: mod_main.f90:853
m_fileio::z_fileio
subroutine z_fileio(filename, qual, iufind, iunit, iostat)
Definition: swmod3.f90:147
m_fileio::tempfile
character(len=80) tempfile
Definition: swmod3.f90:142
m_fileio
Definition: swmod3.f90:74
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_getlocus()

subroutine m_xnldata::q_getlocus ( integer, intent(in)  ik1,
integer, intent(in)  ia1,
integer, intent(in)  ik3,
integer, intent(in)  ia3,
integer, intent(out)  ifnd 
)

Definition at line 4775 of file swmod3.f90.

4775 !------------------------------------------------------------------------------
4776 !
4777 ! +-------+ ALKYON Hydraulic Consultancy & Research
4778 ! | | Gerbrant van Vledder
4779 ! | +---+
4780 ! | | +---+ Last update: 24 December 2003
4781 ! +---+ | | Release: 5.0
4782 ! +---+
4783 !
4784 !
4785 ! SWAN (Simulating WAves Nearshore); a third generation wave model
4786 ! Copyright (C) 2004-2005 Delft University of Technology
4787 !
4788 ! This program is free software; you can redistribute it and/or
4789 ! modify it under the terms of the GNU General Public License as
4790 ! published by the Free Software Foundation; either version 2 of
4791 ! the License, or (at your option) any later version.
4792 !
4793 ! This program is distributed in the hope that it will be useful,
4794 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
4795 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
4796 ! GNU General Public License for more details.
4797 !
4798 ! A copy of the GNU General Public License is available at
4799 ! http://www.gnu.org/copyleft/gpl.html#SEC3
4800 ! or by writing to the Free Software Foundation, Inc.,
4801 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
4802 !
4803 !
4804 ! do not use m_xnldata
4805  use m_constants
4806  use serv_xnl4v5
4807 !----------------------------------------------------------------------------------
4808  implicit none
4809 !
4810 ! 0. Update history
4811 !
4812 ! 25/02/1999 Initial version
4813 ! 15/04/1999 Extra parameter IFND to indicate if a
4814 ! reference locus exists in the data base
4815 ! 19/07/1999 Restructured and some bugs removed
4816 ! 20/07/1999 Option added to compute locus directly, no database
4817 ! or scaling involved. IFND < 0
4818 ! 15/10/1999 Information to transformation file updated
4819 ! 16/10/1999 Equation for computing address for storage updated
4820 ! 25/10/1999 Transformations updated
4821 ! 28/10/1999 Local variables ia1 and ia3 may not be changed, temp. variables
4822 ! it1 and it3 included
4823 ! 29/10/1999 Use of IQ_TRF modified
4824 ! EPSK introduced to check equality of loci
4825 ! 28/12/1999 A_CMPLOC renamed to Q_CMPLOC
4826 ! 03/01/2000 IQ_START replaced by IQ_LOCUS
4827 ! 05/01/2000 Interface with Q_CMPLOC modified
4828 ! 08/08/2002 Upgrade to release 4.0
4829 ! 13/08/2002 Indexing in terms of integers and real weights
4830 ! upgrade to release 4.0
4831 ! 19/08/2002 Bug fixed in transforming CASE 6
4832 ! Interpolation option added
4833 ! 12/06/2003 Parameter t_ws set equal to r_ws
4834 ! 13/06/2003 Parameter t_cple, t_jac and t_sym assigned
4835 ! Bug fixed in nearest bin approach, symmetry regained
4836 ! 27/08/2003 Short-cut when number of points on locus is ZERO
4837 ! 24/12/2003 Tail factors for k2 and k4 addied
4838 !
4839 ! 1. Purpose:
4840 !
4841 ! Retrieve locus from basic locus as stored in the database
4842 !
4843 ! 2. Method
4844 !
4845 ! In the case of geometric scaling, k-scaling is used using scale laws
4846 ! described by Tracy
4847 !
4848 ! Directional transformation using linear transformations, shifting and mirror
4849 ! imaging.
4850 !
4851 !
4852 ! 3. Parameter list:
4853 !
4854 !Type I/O name Description
4855 !------------------------------------------------------------------------------
4856  integer, intent(in) :: ik1 ! k-index of wave number k1
4857  integer, intent(in) :: ia1 ! theta-index of wave number k1
4858  integer, intent(in) :: ik3 ! k-index of wave number k3
4859  integer, intent(in) :: ia3 ! theta-index of wave number k3
4860  integer, intent(out) :: ifnd ! indicator if reference locus exists in database
4861 !
4862 ! 4. Error messages
4863 !
4864 ! 5. Called by
4865 !
4866 ! Q_T13V4
4867 !
4868 ! 6. Subroutines used
4869 !
4870 ! 7. Remarks
4871 !
4872 ! 8. Structure
4873 !
4874 ! 9. Switches
4875 !
4876 ! 10. Source code
4877 !------------------------------------------------------------------------------
4878 ! Local variables
4879 !
4880  integer it1,it3 ! work indices for directions, copy of ia1 and ia3
4881  integer idir ! switch to indicate if locus should be inverted
4882  integer itrans ! type of transformation
4883  integer iloc,jloc ! counters along locus
4884  integer iadif,ikdif ! difference in angular and k-index
4885  integer ja1r,ja3r
4886  integer imirror ! extra step when locus is mirrorred
4887 !
4888  integer ibeta,kdif
4889  integer nloc ! number of points on locus
4890 !
4891  integer ierr
4892  integer kmem ! index for storing 2-d matrix in 1-d array
4893  integer amem ! index for storing direction of reference wave number k3
4894 !
4895  real lambda ! geometric scale factor
4896  real j_lambda ! scale factor for Jacobian term
4897  real c_lambda ! scale factor for coupling coefficient
4898  real zz_lambda ! combined scale factor
4899 !
4900  real xt2(nlocus),yt2(nlocus) ! xy-components of test k2-locus
4901  real xt4(nlocus),yt4(nlocus) ! xy-components of test k4-locus
4902  real wk,wa,vk,va
4903 !! \A
4904 !! real x_kfunc ! real function to compute wave number
4905 !! \Z
4906 !
4907  integer ikmin,ja1,ja3,jk1,jk3,itmin
4908  integer ibdif,nhalf
4909  integer iaq,ikq ! counters for loop over direction and wave numbers
4910 !------------------------------------------------------------------------------
4911 !
4912 !! data i_getloc /0/ ! Initialise counter
4913 !-------------------------------------------------------------------------------------
4914  call q_stack('+q_getlocus')
4915 !
4916 !------------------------------------------------------------------------------
4917 ! initialisations
4918 !------------------------------------------------------------------------------
4919 !
4920  it1 = ia1
4921  it3 = ia3
4922 !
4923  imirror = 1
4924  imirror = 2 - iq_interp
4925 !
4926  ikmin = min(ik1,ik3) ! compute minimum of wave number index
4927  ikdif = abs(ik1-ik3) ! compute difference between wave number indices
4928 !
4929  if (iq_geom ==0) then
4930  jk1 = min(ik1,ik3)
4931  jk3 = max(ik1,ik3)
4932  else
4933  jk1 = 1
4934  jk3 = ikdif + 1 ! compute k-index of wave number k3 relative to reference wave number
4935  end if
4936 !
4937  itmin = min(it1,it3) ! compute minimum angle of k1 and k3
4938  iadif = abs(it1-it3) ! difference index
4939  ja1 = 1 ! index of direction of reference wave number k1
4940  ja3 = iadif+iaref ! compute theta-index of direction of wave number k3
4941 !
4942  if(iq_test >=1) write(luq_tst,'(a,6i4)') &
4943  'Q_GETLOCUS: it1,it3,itmin,iadif,ja1,ja3:',it1,it3,itmin,iadif, &
4944  ja1,ja3
4945 !------------------------------------------------------------------------------
4946 ! circle grid, modify ranges and transformation variables
4947 !------------------------------------------------------------------------------
4948 !
4949  if (iq_grid==3) then
4950  nhalf = naq/2
4951  if (iadif > nhalf) then
4952  if(it1 > nhalf) it1 = it1 - naq
4953  if(it3 > nhalf) it3 = it3 - naq
4954  end if
4955  itmin = min(it1,it3)
4956  ibdif = (naq - abs(naq-2*abs(it1-it3)))/2 ! compute shortest difference in indices
4957  ! while taking care of periodicity
4958  ja3 = ibdif + 1
4959  iadif = ibdif
4960  end if
4961 !
4962  ja1r = 1
4963  ja3r = iadif + 1
4964  amem = iadif + 1 ! compute index of reference wave number k3 in interaction grid
4965 !
4966 !------------------------------------------------------------------------------
4967 ! obtain k-index of reference wave number
4968 !------------------------------------------------------------------------------
4969 !
4970  if(iq_geom==0) then
4971  kmem = (jk3-jk1+1) - (jk1-2*nkq-2)*(jk1-1)/2
4972  else
4973  kmem = ikdif+1
4974  end if
4975 !
4976  if(iq_test >=2) write(luq_tst,'(a,6i5)') &
4977  'Q_GETLOCUS: ik1 ia1 ik3 ia3 kmem amem:',ik1,ia1,ik3,ia3,kmem,amem
4978 !
4979 !------------------------------------------------------------------------------
4980 ! check memory indexing
4981 !------------------------------------------------------------------------------
4982 !
4983  if (amem > iamax) then
4984  ifnd = 0
4985  call q_error('e','MEMORY','Incorrect addres')
4986  write(luq_err,'(a,2i4)') 'Q_GETLOCUS: iamax,amem:',iamax,amem
4987  goto 9999
4988  end if
4989 !
4990 !-----------------------------------------------------------------------------
4991 ! retrieve info from reference locus
4992 ! get actual number of valid points along locus (NLOCUSZ)
4993 ! depending on value of switch IQ_COMPACT
4994 !------------------------------------------------------------------------------
4995 !
4996  nloc = quad_nloc(kmem,amem)
4997  if(iq_test>=2) write(luq_tst,'(a,i4)') 'Q_GETLOCUS: nloc:',nloc
4998  nlocusx = nloc
4999 !
5000 ! short-cut when number of NON-ZERO points on locus is ZERO [27/8/2003]
5001 !
5002  if(nlocusx==0) goto 9999
5003 !
5004  r_ik2(1:nloc) = quad_ik2(kmem,amem,1:nloc)
5005  r_ia2(1:nloc) = quad_ia2(kmem,amem,1:nloc)
5006  r_ik4(1:nloc) = quad_ik4(kmem,amem,1:nloc)
5007  r_ia4(1:nloc) = quad_ia4(kmem,amem,1:nloc)
5008 !
5009  r_w1k2(1:nloc) = quad_w1k2(kmem,amem,1:nloc)
5010  r_w2k2(1:nloc) = quad_w2k2(kmem,amem,1:nloc)
5011  r_w3k2(1:nloc) = quad_w3k2(kmem,amem,1:nloc)
5012  r_w4k2(1:nloc) = quad_w4k2(kmem,amem,1:nloc)
5013 !
5014  r_w1k4(1:nloc) = quad_w1k4(kmem,amem,1:nloc)
5015  r_w2k4(1:nloc) = quad_w2k4(kmem,amem,1:nloc)
5016  r_w3k4(1:nloc) = quad_w3k4(kmem,amem,1:nloc)
5017  r_w4k4(1:nloc) = quad_w4k4(kmem,amem,1:nloc)
5018 !
5019  r_zz(1:nloc) = quad_zz(kmem,amem,1:nloc)
5020 !
5021  r_tail2(1:nloc) = quad_t2(kmem,amem,1:nloc)
5022  r_tail4(1:nloc) = quad_t4(kmem,amem,1:nloc)
5023 !
5024  r_jac(1:nloc) = quad_jac(kmem,amem,1:nloc)
5025  r_cple(1:nloc) = quad_cple(kmem,amem,1:nloc)
5026  r_sym(1:nloc) = quad_sym(kmem,amem,1:nloc)
5027  r_ws(1:nloc) = quad_ws(kmem,amem,1:nloc)
5028 !
5029 !------------------------------------------------------------------------------
5030  kdif = ikmin - 1
5031  if(iq_geom==0) then
5032  lambda = 1.
5033  kdif = 0.
5034  else
5035  lambda = q_kfac**(ikmin-1.)
5036  end if
5037 !
5038  j_lambda = 1./sqrt(lambda)
5039  c_lambda = lambda**6
5040 !
5041 ! compute combined scale factor
5042 !
5043  zz_lambda = lambda*c_lambda/j_lambda
5044 !
5045 !------------------------------------------------------------------------------
5046 ! select case to transform reference locus
5047 !
5048 ! Transformation of weights reduces to an addition or subtraction
5049 ! because of log-spacing of wave numbers in the case of deep water
5050 ! and geometric scaling
5051 !
5052  if(ik3 > ik1 .and. it3 >= it1) then ! Case 1
5053  itrans = 1
5054  t_ik2(1:nloc) = kdif + r_ik2(1:nloc)
5055  t_ik4(1:nloc) = kdif + r_ik4(1:nloc)
5056  ibeta = itmin-iaref
5057  t_ia2(1:nloc) = r_ia2(1:nloc) + ibeta
5058  t_ia4(1:nloc) = r_ia4(1:nloc) + ibeta
5059  idir = 1
5060  t_w1k2(1:nloc) = r_w1k2(1:nloc)
5061  t_w2k2(1:nloc) = r_w2k2(1:nloc)
5062  t_w3k2(1:nloc) = r_w3k2(1:nloc)
5063  t_w4k2(1:nloc) = r_w4k2(1:nloc)
5064  t_w1k4(1:nloc) = r_w1k4(1:nloc)
5065  t_w2k4(1:nloc) = r_w2k4(1:nloc)
5066  t_w3k4(1:nloc) = r_w3k4(1:nloc)
5067  t_w4k4(1:nloc) = r_w4k4(1:nloc)
5068 !
5069  elseif(ik3 > ik1 .and. it3 < it1) then ! Case 2
5070  itrans = 2
5071  t_ik2(1:nloc) = kdif + r_ik2(1:nloc)
5072  t_ik4(1:nloc) = kdif + r_ik4(1:nloc)
5073  ibeta = int(q_ad(ia1)/q_deltad+0.01)
5074  t_ia2(1:nloc) = ibeta + 2.*iaref - r_ia2(1:nloc) -imirror
5075  t_ia4(1:nloc) = ibeta + 2.*iaref - r_ia4(1:nloc) -imirror
5076  t_w1k2(1:nloc) = r_w3k2(1:nloc)
5077  t_w2k2(1:nloc) = r_w4k2(1:nloc)
5078  t_w3k2(1:nloc) = r_w1k2(1:nloc)
5079  t_w4k2(1:nloc) = r_w2k2(1:nloc)
5080  t_w1k4(1:nloc) = r_w3k4(1:nloc)
5081  t_w2k4(1:nloc) = r_w4k4(1:nloc)
5082  t_w3k4(1:nloc) = r_w1k4(1:nloc)
5083  t_w4k4(1:nloc) = r_w2k4(1:nloc)
5084  idir = -1 ! according to theory
5085 ! idir = 1 ! as it should be to get symmetry
5086 !
5087  elseif(ik1 > ik3 .and. it3 >= it1) then ! Case 3
5088  itrans = 3
5089  t_ik2(1:nloc) = kdif + r_ik4(1:nloc)
5090  t_ik4(1:nloc) = kdif + r_ik2(1:nloc)
5091  ibeta = int(q_ad(ia3)/q_deltad+0.01)
5092  t_ia2(1:nloc) = ibeta + 2.*iaref - r_ia4(1:nloc) -imirror
5093  t_ia4(1:nloc) = ibeta + 2.*iaref - r_ia2(1:nloc) -imirror
5094  t_w1k2(1:nloc) = r_w3k2(1:nloc)
5095  t_w2k2(1:nloc) = r_w4k2(1:nloc)
5096  t_w3k2(1:nloc) = r_w1k2(1:nloc)
5097  t_w4k2(1:nloc) = r_w2k2(1:nloc)
5098  t_w1k4(1:nloc) = r_w3k4(1:nloc)
5099  t_w2k4(1:nloc) = r_w4k4(1:nloc)
5100  t_w3k4(1:nloc) = r_w1k4(1:nloc)
5101  t_w4k4(1:nloc) = r_w2k4(1:nloc)
5102  idir = 1
5103 !
5104  elseif(ik1 > ik3 .and. it1 > it3) then ! Case 4
5105  itrans = 4
5106  t_ik2(1:nloc) = kdif + r_ik4(1:nloc)
5107  t_ik4(1:nloc) = kdif + r_ik2(1:nloc)
5108  ibeta = itmin-iaref
5109  t_ia2(1:nloc) = ibeta + r_ia4(1:nloc)
5110  t_ia4(1:nloc) = ibeta + r_ia2(1:nloc)
5111  idir = -1
5112  t_w1k2(1:nloc) = r_w1k2(1:nloc)
5113  t_w2k2(1:nloc) = r_w2k2(1:nloc)
5114  t_w3k2(1:nloc) = r_w3k2(1:nloc)
5115  t_w4k2(1:nloc) = r_w4k2(1:nloc)
5116  t_w1k4(1:nloc) = r_w1k4(1:nloc)
5117  t_w2k4(1:nloc) = r_w2k4(1:nloc)
5118  t_w3k4(1:nloc) = r_w3k4(1:nloc)
5119  t_w4k4(1:nloc) = r_w4k4(1:nloc)
5120 !
5121  elseif(ik1==ik3 .and. it3 > it1) then ! Case 5
5122  itrans = 5
5123  t_ik2(1:nloc) = kdif + r_ik2(1:nloc)
5124  t_ik4(1:nloc) = kdif + r_ik4(1:nloc)
5125  ibeta = itmin-iaref
5126  t_ia2(1:nloc) = r_ia2(1:nloc) + ibeta
5127  t_ia4(1:nloc) = r_ia4(1:nloc) + ibeta
5128  idir = 1
5129  t_w1k2(1:nloc) = r_w1k2(1:nloc)
5130  t_w2k2(1:nloc) = r_w2k2(1:nloc)
5131  t_w3k2(1:nloc) = r_w3k2(1:nloc)
5132  t_w4k2(1:nloc) = r_w4k2(1:nloc)
5133  t_w1k4(1:nloc) = r_w1k4(1:nloc)
5134  t_w2k4(1:nloc) = r_w2k4(1:nloc)
5135  t_w3k4(1:nloc) = r_w3k4(1:nloc)
5136  t_w4k4(1:nloc) = r_w4k4(1:nloc)
5137 !
5138  elseif(ik1==ik3 .and. it1 > it3) then ! Case 6
5139  itrans = 6
5140  t_ik2(1:nloc) = kdif + r_ik4(1:nloc)
5141  t_ik4(1:nloc) = kdif + r_ik2(1:nloc)
5142  ibeta = int(q_ad(ia1)/q_deltad+0.01)
5143  t_ia2(1:nloc) = ibeta + 2.*iaref - r_ia2(1:nloc) -imirror
5144  t_ia4(1:nloc) = ibeta + 2.*iaref - r_ia4(1:nloc) -imirror
5145 !! ibeta = itmin-iaref
5146 !! t_ia2(1:nloc) = r_ia4(1:nloc) + ibeta
5147 !! t_ia4(1:nloc) = r_ia2(1:nloc) + ibeta
5148  idir = -1
5149  t_w1k2(1:nloc) = r_w3k2(1:nloc)
5150  t_w2k2(1:nloc) = r_w4k2(1:nloc)
5151  t_w3k2(1:nloc) = r_w1k2(1:nloc)
5152  t_w4k2(1:nloc) = r_w2k2(1:nloc)
5153  t_w1k4(1:nloc) = r_w3k4(1:nloc)
5154  t_w2k4(1:nloc) = r_w4k4(1:nloc)
5155  t_w3k4(1:nloc) = r_w1k4(1:nloc)
5156  t_w4k4(1:nloc) = r_w2k4(1:nloc)
5157  end if
5158 !
5159  t_zz(1:nloc) = lambda*c_lambda/j_lambda * r_zz(1:nloc)
5160 !
5161  t_tail2(1:nloc) = r_tail2(1:nloc)
5162  t_tail4(1:nloc) = r_tail4(1:nloc)
5163 !
5164  t_ws(1:nloc) = r_ws(1:nloc)
5165  t_jac(1:nloc) = r_jac(1:nloc)*j_lambda
5166  t_cple(1:nloc) = r_cple(1:nloc)*c_lambda
5167  t_sym(1:nloc) = r_sym(1:nloc)
5168 !
5169  ifnd = 1
5170 !
5171 !------------------------------------------------------------------------------
5172  if(iq_trf>=1.and.(ik1>=mk1a .and. ik1<=mk1b) .and. &
5173  (ik3>=mk3a .and. ik3<=mk3b)) then
5174  write(luq_trf,'(a)') '! ik1 ia1 ik3 ia3'
5175  write(luq_trf,'(a)') '! k1x k1y k3x k3y'
5176  write(luq_trf,'(a)') &
5177  '! itrans kmem amem kdif iaref ibeta imirror it1 it3'
5178  write(luq_trf,'(a)') '! lambda depth'
5179  write(luq_trf,'(a)') '! nlocus'
5180  write(luq_trf,'(a)') '! k2x k2y k4x k4y ds jac cple sym zz'
5181 !
5182  write(luq_trf,'(a1,2i3.3,a1,2i3.3,a1)') '(',ik1,ia1,'-',ik3, &
5183  ia3,')'
5184  write(luq_trf,'(4f10.4)') q_k(ik1)*cos(q_a(ia1)), &
5185  q_k(ik1)*sin(q_a(ia1)), &
5186  q_k(ik3)*cos(q_a(ia3)), &
5187  q_k(ik3)*sin(q_a(ia3))
5188  write(luq_trf,'(9i5)') itrans,kmem,amem,kdif,iaref,ibeta, &
5189  imirror,it1,it3
5190  write(luq_trf,'(2f10.3)') lambda,q_depth
5191 !
5192  where(t_ia2 < 1)
5193  t_ia2 = t_ia2 + ncirc
5194  end where
5195 !
5196  where(t_ia2 > ncirc)
5197  t_ia2 = t_ia2 - ncirc
5198  end where
5199 !
5200  where(t_ia4 < 1)
5201  t_ia4 = t_ia4 + ncirc
5202  end where
5203 !
5204  where(t_ia4 > ncirc)
5205  t_ia4 = t_ia4 - ncirc
5206  end where
5207  if(iq_trf==2) then
5208  write(luq_trf,'(a)') '#TRF1#'
5209  write(luq_trf,'(2i5)') nlocusx,8
5210  do iloc=1,nlocusx
5211  write(luq_trf,'(3i6,4f10.4,e13.5)') iloc,r_ik2(iloc), &
5212  r_ia2(iloc), &
5213  r_w1k2(iloc),r_w2k2(iloc),r_w3k2(iloc),r_w4k2(iloc), &
5214  r_zz(iloc)
5215  end do
5216 !
5217  write(luq_trf,'(a)') '#TRF2#'
5218  write(luq_trf,'(2i5)') nlocusx,8
5219  do iloc=1,nlocusx
5220  write(luq_trf,'(3i6,4f10.4,e13.5)') iloc,t_ik2(iloc), &
5221  t_ia2(iloc), &
5222  t_w1k2(iloc),t_w2k2(iloc),t_w3k2(iloc),t_w4k2(iloc), &
5223  t_zz(iloc)
5224  end do
5225  end if
5226 !
5227  if(iq_trf>=3) then
5228  write(luq_trf,'(a)') '#TRF3#'
5229  write(luq_trf,'(2i5)') nlocusx,9
5230  do iloc=1,nlocus
5231  wk = t_w2k2(iloc) + t_w4k2(iloc)
5232  wa = t_w3k2(iloc) + t_w4k2(iloc)
5233  vk = q_k(t_ik2(iloc)) + wk*q_sk(t_ik2(iloc))
5234  va = q_a(t_ia2(iloc)) + wa*q_delta
5235  xt2(iloc) = vk*cos(va)
5236  yt2(iloc) = vk*sin(va)
5237 !
5238  wk = t_w2k4(iloc) + t_w4k4(iloc)
5239  wa = t_w3k4(iloc) + t_w4k4(iloc)
5240  vk = q_k(t_ik4(iloc)) + wk*q_sk(t_ik4(iloc))
5241  va = q_a(t_ia4(iloc)) + wa*q_delta
5242  xt4(iloc) = vk*cos(va)
5243  yt4(iloc) = vk*sin(va)
5244  write(luq_trf,'(5f10.4,5e13.5)') xt2(iloc),yt2(iloc), &
5245  xt4(iloc),yt4(iloc), &
5246  t_ws(iloc),t_cple(iloc),t_jac(iloc),t_sym(iloc), &
5247  t_zz(iloc)
5248  end do
5249  end if
5250 !
5251  end if
5252 !
5253  9999 continue
5254 !
5255  call q_stack('-q_getlocus')
5256 !
5257  return
all_vars::va
real(sp), dimension(:), allocatable, target va
Definition: mod_main.f90:1104
mod_time::abs
Definition: mod_time.f90:64
m_constants
Definition: swmod3.f90:22
m_snl4::lambda
real, dimension(:), allocatable, save, public lambda
Definition: swmod2.f90:373
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_init()

subroutine m_xnldata::q_init ( )

Definition at line 5261 of file swmod3.f90.

5261 !------------------------------------------------------------------------------
5262 !
5263 ! +-------+ ALKYON Hydraulic Consultancy & Research
5264 ! | | Gerbrant van Vledder
5265 ! | +---+
5266 ! | | +---+ Last update: 22 December 2003
5267 ! +---+ | | Release: 5.0
5268 ! +---+
5269 !
5270 !
5271 ! SWAN (Simulating WAves Nearshore); a third generation wave model
5272 ! Copyright (C) 2004-2005 Delft University of Technology
5273 !
5274 ! This program is free software; you can redistribute it and/or
5275 ! modify it under the terms of the GNU General Public License as
5276 ! published by the Free Software Foundation; either version 2 of
5277 ! the License, or (at your option) any later version.
5278 !
5279 ! This program is distributed in the hope that it will be useful,
5280 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
5281 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
5282 ! GNU General Public License for more details.
5283 !
5284 ! A copy of the GNU General Public License is available at
5285 ! http://www.gnu.org/copyleft/gpl.html#SEC3
5286 ! or by writing to the Free Software Foundation, Inc.,
5287 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
5288 !
5289 !
5290 ! do not use m_xnldata
5291  use m_fileio
5292  use m_constants
5293  use serv_xnl4v5
5294  implicit none
5295 !--------------------------------------------------------------------------------
5296 ! 0. Update history
5297 !
5298 ! 25/02/1999 Initial version
5299 ! 13/10/1999 Error handling improved
5300 ! 18/10/1999 Test output to MATCHK.GRD added
5301 ! 21/10/1999 Extra output to MATCHK.GRD, iaref=1 for circle grids
5302 ! 01/11/1999 Allocatable arrays Q_XK and Q_SK added
5303 ! 14/02/2001 Version ready for WAVEWATCH III
5304 ! 8/08/2002 Release 4.
5305 ! 16/08/2002 Group velocity computed
5306 ! 22/08/2002 First and last used defined direction accounted for
5307 ! 11/09/2002 Call of Q_ALOC moved to higher level, viz. XNL_INIT
5308 ! q_kpow initialized
5309 ! 25/09/2002 User defined directions used in the case of a sector grid
5310 ! 22/12/2003 sk_max increased from 50 to 500
5311 !
5312 ! 1. Purpose:
5313 !
5314 ! Initializing module for quadruplets
5315 ! and setting default settings
5316 !
5317 ! 2. Method
5318 !
5319 ! Conversion of power of spectral tail from E(f) to N(k) using the following
5320 ! relations:
5321 !
5322 ! E(f) ~ f^qf_tail
5323 !
5324 ! N(k) ~ k^qk_tail
5325 !
5326 ! qk_tail = qf_tail/2 -1
5327 !
5328 ! See also Note 13 of G.Ph. van Vledder
5329 !
5330 ! 3. Parameter list:
5331 !
5332 ! Name I/O Type Description
5333 !
5334 !
5335 ! 4. error meassage
5336 !
5337 ! 5. Called by
5338 !
5339 ! XNL_INIT
5340 !
5341 ! 6. Subroutines used
5342 !
5343 ! Q_STACK
5344 ! Z_CMPCG
5345 ! Z_STEPS
5346 ! Z_WNUMB
5347 !
5348 ! 7. Remarks
5349 !
5350 ! 8. Structure
5351 !
5352 ! 9. Switches
5353 !
5354 ! /S Enable subroutine tracing
5355 !
5356 ! 10. Source code
5357 !------------------------------------------------------------------------------------------
5358 ! Local variables
5359 !
5360  integer iaq,ikq ! counters for loops over directions and wave numbers
5361  real ff ! frequency
5362 !!!real z_wnumb ! service function to compute wave number
5363 !
5364  integer iuerr ! error indicator for i/o
5365 !------------------------------------------------------------------------------
5366 !
5367  call q_stack('+q_init')
5368 !
5369 ! set general settings
5370 !
5371 ! convert power of E(f) f^qf_tail to power of N(k) k^qk_tail
5372 ! See Note 13 of G.Ph. van Vledder
5373 !
5374  qk_tail = (qf_tail-2.)/2. ! power of spectral tail, of N(k)
5375 !
5376  if(iq_prt >=2) then
5377  write(luq_prt,*)
5378  write(luq_prt,'(a,f6.1)') 'Q_INIT: E(f)_tail: ',qf_tail
5379  write(luq_prt,'(a,f6.1)') 'Q_INIT: N(k)_tail: ',qk_tail
5380  end if
5381 !
5382 ! set absolute and relative accuracies
5383 !
5384  eps_q = 0.001 ! absolute accuracy for check of q==0
5385  eps_k = 1.e-5 ! absolute accuracy for equality check of k
5386  rel_k = 0.001 ! relative accuracy for equality check of k
5387 !
5388  sk_max = 500. ! set maximum waver number
5389  wk_max = real(nkq+0.9999) ! set maximum wave number index
5390 !
5391 ! compute frequency and wave number grid
5392 ! assume that frequencies are always geometrically spaced,
5393 ! in the case of deep water this also holds for the wave numbers
5394 !
5395  q_ffac = (fqmax/fqmin)**real(1./(nkq-1.)) ! geometric spacing factor of frequencies
5396 !
5397  ff = fqmin ! set minimum frequency
5398 !
5399  if(iq_prt>=2) then
5400  write(luq_prt,*)
5401  write(luq_prt,'(a)') 'Basic wave numbers, frequencies'
5402  end if
5403 !
5404  do ikq=1,nkq ! Generate wave number dependent variables
5405  q_f(ikq) = ff ! Frequency
5406  q_sig(ikq) = ff*4.*pih ! Radian frequency
5407  q_k(ikq) = z_wnumb(q_sig(ikq),q_depth,q_grav) ! compute wave number
5408  q_kpow(ikq) = (q_k(1)/q_k(ikq))**7.5 ! used in filtering
5409  ff = ff*q_ffac ! Increase frequency
5410 !
5411  call z_cmpcg(q_sig(ikq),q_depth,q_grav,q_cg(ikq))
5412  if(iq_prt >= 2) then
5413  write(luq_prt,'(a,i4,3f10.5,e12.4)') &
5414  'Q_INIT: ikq f sigma k k^p:', &
5415  ikq,q_f(ikq),q_sig(ikq),q_k(ikq),q_kpow(ikq)
5416  end if
5417  end do
5418 !
5419 ! compute characteristics of extended k-array
5420 !
5421  if(iq_prt>=2) then
5422  write(luq_prt,*)
5423  write(luq_prt,'(a)') 'Extended wave numbers and spacing'
5424  end if
5425 !
5426  do ikq=0,nkq
5427  if(ikq==0) then
5428  q_xk(ikq) = 0.
5429  q_sk(ikq) = q_k(1)
5430  elseif(ikq==nkq) then
5431  q_xk(ikq) = q_k(ikq)
5432  q_sk(ikq) = sk_max
5433  else
5434  q_xk(ikq) = q_k(ikq)
5435  q_sk(ikq) = q_k(ikq+1) - q_k(ikq)
5436  end if
5437 !
5438  end do
5439 !
5440 !
5441  kqmin = q_k(1)
5442  kqmax = q_k(nkq)
5443  q_kfac = (kqmax/kqmin)**real(1./(nkq-1)) ! this value makes only sense in the
5444  ! case of deep water, IQ_DISP==1
5445 !
5446 ! compute step size of frequency grids and wave number grid
5447 !
5448  call z_steps(q_f, q_df, nkq) ! step size of frequencies
5449  call z_steps(q_sig,q_dsig,nkq) ! step size of radian frequencies
5450  call z_steps(q_k, q_dk, nkq) ! step size of wave numbers
5451 !
5452  if(iq_prt >= 2) then
5453  write(luq_prt,*)
5454  write(luq_prt,'(a)') 'Q_INIT: Additional information'
5455  write(luq_prt,'(a,f8.1)') 'Q_depth (m):',q_depth
5456  write(luq_prt,'(a,i3)') 'Number of frequencies:',nkq
5457  write(luq_prt,'(a,f8.4)') 'Geometric f-spacing factor:',q_ffac
5458  write(luq_prt,'(a,f8.4)') 'Geometric k-spacing factor:',q_kfac
5459  write(luq_prt,'(a,2f8.3)') 'fmin fmax (Hz):',fqmin,fqmax
5460  write(luq_prt,'(a,2f8.3)') 'kmin kmax (Hz):',kqmin,kqmax
5461  write(luq_prt,*)
5462 !
5463  write(luq_prt,*) ' i f df sig '// &
5464  'dsig k dk cg'
5465 !
5466  do ikq=1,nkq
5467  write(luq_prt,'(1x,i4,7f10.4)') &
5468  ikq,q_f(ikq),q_df(ikq),q_sig(ikq),q_dsig(ikq),q_k(ikq), &
5469  q_dk(ikq),q_cg(ikq)
5470  end do
5471  end if
5472 !
5473 ! =============== D I R E C T I O N S ===============================================
5474 !
5475 ! the directions in the array ANGLE are running from 1 to NAQ
5476 ! for a sector definition the middle direction has index IAREF
5477 !
5478 ! compute index IAREF of middle wave direction for sector grids
5479 !
5480  if(iq_grid ==1 .or. iq_grid==2) then
5481  iaref = (naq/2)+1
5482  elseif(iq_grid==3) then
5483  iaref = 1
5484  end if
5485 !
5486  if(iq_prt >= 2) write(luq_prt,'(a,i4)') &
5487  'Q_INIT: Index of first direction for reference:',iaref
5488 !
5489 ! set loops indices
5490 !
5491  if(iq_grid==1) then ! symmetric sector
5492  iaq1 = iaref
5493  iaq2 = naq
5494 !
5495 ! non-symmetric sector and full circle
5496 !
5497  elseif(iq_grid==2 .or. iq_grid==3) then
5498  iaq1 = 1
5499  iaq2 = naq
5500  end if
5501 !
5502  if(iq_prt >= 2) write(luq_prt,'(a,2i4)') &
5503  'Q_INIT: Range of indices for loop over directions:',iaq1,iaq2
5504 !
5505 ! generate directions, given in degrees
5506 !
5507  q_sector = 0.5*(abs(q_dird1) + abs(q_dird2))
5508 !
5509  if(iq_grid==1 .or. iq_grid==2) then ! define symmetric sector
5510  q_deltad = 2.*q_sector/real(naq-1.) ! delta in degrees
5511  q_ang1 = -q_sector ! degrees
5512  q_ang2 = q_sector ! degrees
5513  if(iq_prt>0) write(luq_prt,'(a)') &
5514  'Q_INIT: take care of q_dird1 and check if sector is OK'
5515 !
5516  elseif(iq_grid==3) then ! full sector
5517  q_deltad = 360./real(naq) ! degrees
5518  q_ang1 = 0 ! degrees
5519  q_ang2 = 360.-q_delta ! degrees
5520  end if
5521 !
5522  q_delta = q_deltad*dera ! directional step in radians
5523  ncirc = 2.00001*2.*pih/q_delta ! number of directions on circle
5524 !
5525  if(iq_prt >= 2) then
5526  write(luq_prt,'(a,3f10.3)') 'Q_INIT: d(1),d(n),dsector:', &
5527  q_dird1,q_dird2,q_sector
5528  write(luq_prt,'(a,f6.2,a)') 'Q_INIT: Angular step :', &
5529  q_deltad,' degrees'
5530  write(luq_prt,'(a,2f8.2,i4,a)') 'Q_INIT: ang1 ang2 nang :', &
5531  q_ang1,q_ang2,naq,' degrees'
5532  write(luq_prt,'(a,i4)') 'Q_INIT: #Angles on circle:', &
5533  ncirc
5534  write(luq_prt,*)
5535  end if
5536 !
5537 ! generate directions arrays, given in degrees and radians
5538 !
5539  do iaq=1,naq
5540  q_ad(iaq) = q_ang1 + q_deltad*(iaq-1.)
5541  q_a(iaq) = q_ad(iaq)*dera
5542  if(iq_prt >= 2) then
5543  write(luq_prt,'(a,i4,f10.4,f10.2)') 'Q_INIT: iaq q_a q_ad:', &
5544  iaq,q_a(iaq),q_ad(iaq)
5545  if(iaq==naq) write(luq_prt,*)
5546  end if
5547  end do
5548 !
5549 ! set loop indices for generation of grid
5550 ! for sector grids and circle grids
5551 !
5552  if(iq_grid==1 .or. iq_grid==2) then
5553  iag1 = iaref
5554  iag2 = naq
5555 !
5556 ! circle grid
5557 !
5558  elseif(iq_grid==3) then
5559  iag1 = 1
5560  iag2 = naq/2+1
5561  end if
5562 !
5563  iamax = iag2-iag1+1
5564 !-------------------------------------------------------------------------
5565  if(iq_test>=1) then
5566  write(luq_tst,'(a,3i4)') 'Q_INIT: iq_grid iaref iamax:', &
5567  iq_grid,iaref,iamax
5568  write(luq_tst,'(a,4i4)') 'Q_INIT: iaq1 iaq2 iag1 iag2:', &
5569  iaq1,iaq2,iag1,iag2
5570  end if
5571 !
5572  if(iq_trf>0) then
5573  write(luq_trf,'(a)') '#GRIDINFO#'
5574  write(luq_trf,'(2i4)') nkq,naq
5575  write(luq_trf,'(10f8.4)') q_k
5576  write(luq_trf,'(10f8.2)') q_a*rade
5577  end if
5578 !
5579  call q_stack('-q_init')
5580 !
5581  return
mod_time::abs
Definition: mod_time.f90:64
m_constants
Definition: swmod3.f90:22
serv_xnl4v5::z_cmpcg
subroutine z_cmpcg(sigma, depth, grav_w, cg)
Definition: swmod3.f90:710
ice_constants::pih
real(kind=dbl_kind) pih
Definition: ice_constants.f90:206
serv_xnl4v5::z_steps
subroutine z_steps(x, dx, nx)
Definition: swmod3.f90:1107
m_constants::dera
real dera
Definition: swmod3.f90:39
serv_xnl4v5::z_wnumb
real function z_wnumb(w, d, grav_w)
Definition: swmod3.f90:1467
m_constants::rade
real rade
Definition: swmod3.f90:40
m_fileio
Definition: swmod3.f90:74
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_loc_w1w3()

subroutine m_xnldata::q_loc_w1w3 ( real, intent(in)  k1x,
real, intent(in)  k1y,
real, intent(in)  k3x,
real, intent(in)  k3y,
integer, intent(in)  npts,
real, dimension(npts), intent(out)  k2x,
real, dimension(npts), intent(out)  k2y,
real, dimension(npts), intent(out)  k4x,
real, dimension(npts), intent(out)  k4y,
real, dimension(npts), intent(out)  s 
)

Definition at line 9255 of file swmod3.f90.

9255 !-----------------------------------------------------------------
9256 !
9257 ! +-------+ ALKYON Hydraulic Consultancy & Research
9258 ! | | Gerbrant van Vledder
9259 ! | +---+
9260 ! | | +---+ Last update: 11 June 2003
9261 ! +---+ | | Release: 5.0
9262 ! +---+
9263 !
9264 !
9265 ! SWAN (Simulating WAves Nearshore); a third generation wave model
9266 ! Copyright (C) 2004-2005 Delft University of Technology
9267 !
9268 ! This program is free software; you can redistribute it and/or
9269 ! modify it under the terms of the GNU General Public License as
9270 ! published by the Free Software Foundation; either version 2 of
9271 ! the License, or (at your option) any later version.
9272 !
9273 ! This program is distributed in the hope that it will be useful,
9274 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
9275 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9276 ! GNU General Public License for more details.
9277 !
9278 ! A copy of the GNU General Public License is available at
9279 ! http://www.gnu.org/copyleft/gpl.html#SEC3
9280 ! or by writing to the Free Software Foundation, Inc.,
9281 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
9282 !
9283 !
9284  implicit none
9285 !
9286 ! 0. Update history
9287 !
9288 ! 15/04/2002 Initial version
9289 ! 20/08/2002 Direction of k1 may be non-zero
9290 ! 27/08/2002 Singular solution crosses origin
9291 ! 11/06/2003 Length of locus fixed to 3
9292 !
9293 ! 1. Purpose:
9294 !
9295 ! Compute locus for the special case w1=w3
9296 !
9297 ! 2. Method
9298 !
9299 ! For this case, the k2-locus consists of a straight line
9300 !
9301 ! 3. Parameter used:
9302 !
9303  integer, intent(in) :: npts ! Number of points
9304  real, intent(in) :: k1x ! x-component of wave number k1
9305  real, intent(in) :: k1y ! y-component of wave number k1
9306  real, intent(in) :: k3x ! x-component of wave number k3
9307  real, intent(in) :: k3y ! y-component of wave number k3
9308 !
9309  real, intent(out) :: k2x(npts) ! x-component of wave number k2
9310  real, intent(out) :: k2y(npts) ! y-component of wave number k2
9311  real, intent(out) :: k4x(npts) ! x-component of wave number k4
9312  real, intent(out) :: k4y(npts) ! y-component of wave number k4
9313  real, intent(out) :: s(npts) ! distance along locus
9314 !
9315 ! 4. Error messages
9316 !
9317 ! 5. Caled by:
9318 !
9319 ! Q_CMPLOCUS
9320 !
9321 ! 6. Subroutines used
9322 !
9323 ! 7. Remarks
9324 !
9325 ! Routine based on modified version of routine SHLOCX of Resio and Tracy
9326 ! On 15/4/2002 a bug fixed in computation of THR when angle of k3 is larger than 90°
9327 !
9328 ! In addition, the assumption that k1y=0 and thus dir1=0 is removed
9329 ! In bug fix of 20/8/2002 this restriction is removed.
9330 !
9331 ! 8. Structure
9332 !
9333 ! Compute angle of symmetry axis
9334 ! Compute distance between 2 lines of solution
9335 ! compute wave numbers along locus
9336 ! rotate angles
9337 !
9338 ! 9. Switches
9339 !
9340 ! 10. Source code
9341 !------------------------------------------------------------------------------
9342 ! Local variables
9343 !
9344  integer ipt ! counter of points along locus
9345 !
9346  real dirs ! angle of symmetry axis
9347  real dir1 ! direction of wave number k1
9348  real dir3 ! direction of wave number k3
9349  real dk0 ! step size along locus
9350  real xk0 ! x-component
9351  real yk0 ! y-component
9352  real w2 ! radian frequency
9353  real xx2,yy2 ! values along k2-locus
9354  real xx4,yy4 ! values along k4-locus
9355  real k1m ! magnitude of wave number k1
9356 !------------------------------------------------------------------------------
9357 !
9358 ! dirs is the angle of rotation from the x-axis to the "bisecting" angle
9359 !
9360  dir1 = atan2(k1y,k1x)
9361  dir3 = atan2(k3y,k3x)
9362  dirs = 0.5*(180-abs(180-abs(dir3-dir1)))
9363  k1m = sqrt(k1x**2 + k1y**2)
9364 !
9365 ! k1x is the total length of the wavenumber vector
9366 ! xk0 is the length of this vector in the rotated coordinate system
9367 !
9368  xk0 = k1m * cos(dirs)
9369  yk0 = k1m * sin(dirs)
9370 !
9371 ! Specify step size for solution of singular case
9372 !
9373 !! dk0 = 0.11 ! Removed on 11/6/2003, this value is used in original WRT code
9374 !! dk0 = kqmax/real(npts-1.) this value depends on actual grid
9375  dk0 = 3./real(npts-1.) ! this is test value
9376 !
9377 ! modify rotation angle
9378 !
9379  dirs = dirs + dir1
9380 !
9381 ! generate sequence of parallel lines
9382 ! rotate lines over modified angle DIRS
9383 !
9384  do ipt=1,npts
9385 ! w2 = real(ipt-1.)*dk0 ! removed on Aug. 27 2002
9386 !
9387  w2 = 2.*real(ipt-npts/2)*dk0 ! create line on both sides of origin
9388  xx2 = w2*xk0
9389  yy2 = yk0
9390  k2x(ipt) = xx2*cos(dirs) - yy2*sin(dirs)
9391  k2y(ipt) = yy2*cos(dirs) + xx2*sin(dirs)
9392  xx4 = xx2
9393  yy4 = -yy2
9394  k4x(ipt) = xx4*cos(dirs) - yy4*sin(dirs)
9395  k4y(ipt) = yy4*cos(dirs) + xx4*sin(dirs)
9396  s(ipt) = real(ipt-1)*dk0*xk0
9397  end do
9398 !
9399  return
mod_time::abs
Definition: mod_time.f90:64
all_vars::s
real(sp), dimension(:,:), allocatable, target s
Definition: mod_main.f90:1288
control::ipt
integer ipt
Definition: mod_main.f90:922
Here is the caller graph for this function:

◆ q_locpos()

subroutine m_xnldata::q_locpos ( real, intent(out)  ka,
real, intent(out)  kb,
real, intent(out)  km,
real, intent(out)  kw,
real, intent(out)  loclen 
)

Definition at line 5807 of file swmod3.f90.

5807 !------------------------------------------------------------------------------
5808 !
5809 ! +-------+ ALKYON Hydraulic Consultancy & Research
5810 ! | | Gerbrant van Vledder
5811 ! | +---+
5812 ! | | +---+ Last update: 14 Oct. 2002
5813 ! +---+ | | Release: 5.0
5814 ! +---+
5815 !
5816 !
5817 ! SWAN (Simulating WAves Nearshore); a third generation wave model
5818 ! Copyright (C) 2004-2005 Delft University of Technology
5819 !
5820 ! This program is free software; you can redistribute it and/or
5821 ! modify it under the terms of the GNU General Public License as
5822 ! published by the Free Software Foundation; either version 2 of
5823 ! the License, or (at your option) any later version.
5824 !
5825 ! This program is distributed in the hope that it will be useful,
5826 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
5827 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
5828 ! GNU General Public License for more details.
5829 !
5830 ! A copy of the GNU General Public License is available at
5831 ! http://www.gnu.org/copyleft/gpl.html#SEC3
5832 ! or by writing to the Free Software Foundation, Inc.,
5833 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
5834 !
5835 !
5836 ! do not use m_xnldata
5837  use m_constants
5838  use serv_xnl4v5, only: z_root2
5839 !
5840  implicit none
5841 !
5842 ! 0. Update history
5843 !
5844 ! Version Date Description
5845 !
5846 ! 03/12/1999 Initial version
5847 ! 09/08/2002 Upgrade to release 4.0
5848 ! 29/08/2002 Error handling z_root2 relaxed and some write statements modified
5849 ! 07/10/2002 Initialisation of QSQ replaced
5850 !
5851 ! 1. Purpose:
5852 !
5853 ! Compute characteristics of locus used to optimize its acutal computation
5854 !
5855 ! 2. Method
5856 !
5857 ! 3. Parameter list:
5858 !
5859 !Type I/O Name Description
5860 !-----------------------------------------------------------------
5861  real, intent (out) :: ka ! minimum k along symmetry axis
5862  real, intent (out) :: kb ! maximum k along symmetry axis
5863  real, intent (out) :: km ! wave number at midpoint
5864  real, intent (out) :: kw ! half width of locus at midpoint
5865  real, intent (out) :: loclen ! estimated length of locus
5866 !
5867 ! 4. Error messages
5868 !
5869 ! 5. Called by:
5870 !
5871 ! Q_CMPLOCUS
5872 !
5873 ! 6. Subroutines used
5874 !
5875 ! z_zero2 Root finding method
5876 ! x_locus1 Function of locus geometry, along symmetry axis
5877 ! x_locus2 Function of locus geometry, perpendicular to symmetry axis
5878 ! x_flocus Locus function
5879 !
5880 ! 7. Remarks
5881 !
5882 ! 8. Structure
5883 !
5884 ! 9. Switches
5885 !
5886 ! /S enable subroutine tracing
5887 ! /T enable test output
5888 !
5889 ! 10. Source code
5890 !------------------------------------------------------------------------------
5891 ! Local variables
5892 !
5893  real kp ! wave number at peak
5894  real kpx,kpy ! wave number at peak maximum
5895  real zp ! value of locus function at maximum
5896  real za,zb ! (test) value of locus function at kmin & kmax
5897  real zz1,zz2 ! intermediate function values in interation process
5898  real kk1,kk2 ! start values for finding root of locus equation
5899  real kk1x,kk1y ! wave number components at one side of root
5900  real kk2x,kk2y ! wave number components at other side of root
5901  real beta1,beta2 ! parameters specifying cross component
5902  real betaw ! parameter specifying iterated cross component
5903  real kwx,kwy ! wave number at side of locus
5904  real zw ! function value at (kwx,kwy)
5905  real a1,a2,b1,b2 ! constants in polynomial approximation of elliptic function
5906  real aa,bb,mm,mm1 ! semi-major exis of ellips and derived parameters
5907 !
5908  real eps ! local machine accuracy for determination of roots
5909  real bacc ! accuracy for determination of beta
5910  real kacc ! accuracy for determination of wave number roots
5911  real qs ! (w1-w3)/sqrt(g)
5912  real qsq ! gs^2
5913 !
5914 ! Function declaration
5915 !
5916 ! real z_root2 ! root finding using Ridders method
5917 !
5918  integer ierr ! local error indicator, used in function Z-ZERO1
5919  integer itest ! local test level for test output
5920  integer lutest ! unit for test output in service routines
5921  integer iter ! local iteration number
5922  integer maxiter ! maximum number of iteration for determining starting points
5923 !
5924 ! function declarations
5925 !! real, external :: x_locus2 ! locus function perpendicular to symmetry axis
5926 !! real x_flocus ! 2-d locus function
5927 !---------------------------------------------------------------------------------
5928 ! assign test options
5929 !
5930  itest = iq_test ! assign test level
5931  lutest = 0 ! assign default, no test output in service routines
5932 !
5933  itest = 0 ! reset local test level
5934  if(itest > 0) lutest=luq_tst ! assign unit for test output
5935 !
5936  call q_stack('+q_locpos')
5937 !
5938 ! set initial values
5939 !
5940  eps = epsilon(1.) ! determine machine accurcy
5941  maxiter = 20 ! maximum number of iterations
5942 !
5943 ! compute location of maximum, located at k_2 = P
5944 !
5945  kpx = -px
5946  kpy = -py
5947  kp = sqrt(kpx**2 + kpy**2)
5948  zp = x_locus1(kp)
5949 !
5950 ! find location of points A and B on locus
5951 ! for deep water, explicit relations are available
5952 !
5953  if(iq_disp==1) then
5954  qs = q/sqrtg
5955  qsq = qs*qs
5956  if(qs < 0) then
5957  ka = 0.5*(-qs+sqrt(2.0*pmag-qsq))
5958  ka = ka**2
5959  kb = (pmag+qsq)/(2.*qs)
5960  kb = kb**2
5961  za = x_locus1(ka)
5962  zb = x_locus1(kb)
5963  else
5964  ka = 0.5*(-qs+sqrt(2.0*pmag-qsq))
5965  ka = -ka**2
5966  kb = (pmag-qsq)/(2.*qs)
5967  kb = kb**2
5968  za = x_locus1(ka)
5969  zb = x_locus1(kb)
5970  end if
5971 !
5972  if(itest >= 1) write(luq_tst,'(a,6e12.5)') &
5973  'Q_LOCPOS: q,pmag,ka,kb,za,zb:',qs,pmag,ka,kb,za,zb
5974 !
5975 ! find location of points A and B on locus
5976 ! for water of finite depth, an iteration process is applied to
5977 ! determine the zero-crossings of the locus function
5978 !
5979  else
5980 !
5981  if(q<0) then
5982 !
5983 ! set two start points to locate position of wave number ka
5984 !
5985  kk1 = 0.
5986  kk2 = kp
5987 !
5988 ! search root by Ridder's method
5989 !
5990  kacc = 10.*max(kk1,kk2)*eps
5991  ka = z_root2(x_locus1,kk1,kk2,kacc,lutest,ierr)
5992 !
5993  if(ierr > 0) then
5994  if(itest>=2) write(luq_tst,'(a,i4)') &
5995  'Q_LOCPOS/Z_ROOT2/IERR/1=',ierr
5996  end if
5997 !
5998  if(itest >= 1) write(luq_tst,'(a,4f12.5)') &
5999  'Q_LOCPOS: q kk1 kk2 kmin:',q,kk1,kk2,ka
6000 !
6001 ! determine start points to locate position of wave number kb
6002 !
6003  kk1 = kp
6004  kk2 = kp
6005  zz1 = zp
6006  zz2 = zp
6007  iter = 0
6008 !
6009 ! ensure that two points are found on either side of zero-crossing
6010 !
6011  do while (zz1*zz2 >= 0 .and. iter < maxiter)
6012  iter = iter + 1
6013  kk2 = kk2*2
6014  zz2 = x_locus1(kk2)
6015  if(itest >= 2) write(luq_tst,'(a,i4,3f12.5,2e13.5)') &
6016  'Q_LOCPOS iter q kk1/2 zz1/2:',iter,q,kk1,kk2,zz1,zz2
6017  end do
6018 !
6019  if(iter>=maxiter) then
6020  call q_error('e','Start kb','Too many iterations needed')
6021  goto 9999
6022  end if
6023 !
6024 ! search root by Ridders method
6025 !
6026  kacc = 10.*max(kk1,kk2)*eps
6027  kb = z_root2(x_locus1,kk1,kk2,kacc,lutest,ierr)
6028  if(ierr>0 .and. itest>=2) write(luq_tst,'(a,i4)') &
6029  'q_locpos/z_root2/ierr/2=',ierr
6030 !
6031 !==================================================================
6032 ! find positions for ka and kb for the case q > 0
6033 !
6034  else
6035 !
6036 ! set two start points to locate position of wave number ka
6037 !
6038  kk1 = 0.
6039  kk2 = -kp
6040  zz1 = x_locus1(kk1)
6041  zz2 = x_locus1(kk2)
6042  iter = 0
6043 !
6044 ! ensure that two points are found on either side of zero-crossing
6045 !
6046 .and. do while (zz1*zz2 >= 0 iter < maxiter)
6047  iter = iter + 1
6048  kk2 = kk2*2
6049  zz2 = x_locus1(kk2)
6050  if(itest >= 2) write(luq_tst,'(a,i4,3f12.5,2e12.5)') &
6051  'q_locpos: iter q kk1/2 zz1/2:',iter,q,kk1,kk2,zz1,zz2
6052  end do
6053 !
6054  if(iter>=maxiter) then
6055  call q_error('e','start ka','too many iterations needed')
6056  goto 9999
6057  end if
6058 !
6059 ! search root by Ridder's method
6060 !
6061  kacc = 10.*max(abs(kk1),abs(kk2))*eps
6062  ka = z_root2(x_locus1,kk1,kk2,kacc,lutest,ierr)
6063  if(ierr > 0 .and. itest>=2) write(luq_tst,'(a,i4)') &
6064  'Q_LOCPOS/Z_ROOT2/IERR/3=',ierr
6065 !
6066 ! determine start points to locate position of wave number kb
6067 !
6068  kk1 = 0
6069  kk2 = kp
6070  zz1 = x_locus1(kk1)
6071  zz2 = x_locus1(kk2)
6072  iter = 0
6073 !
6074 ! ensure that two points are found on either side of zero-crossing
6075 !
6076  do while (zz1*zz2 >= 0 .and. iter < maxiter)
6077  iter = iter + 1
6078  kk2 = kk2*2
6079  zz2 = x_locus1(kk2)
6080  if(itest >= 2) write(luq_tst,'(a,i4,3f12.5,2e12.5)') &
6081  'Q_LOCPOS: iter q kk1/2 zz1/2:',iter,q,kk1,kk2,zz1,zz2
6082  end do
6083 !
6084  if(iter>=maxiter) then
6085  call q_error('e','Start kb','Too many iterations needed')
6086  goto 9999
6087  end if
6088 !
6089 ! search root by Ridders method
6090 !
6091  kacc = 10.*max(kk1,kk2)*eps
6092  kb = z_root2(x_locus1,kk1,kk2,kacc,luq_tst,ierr)
6093  if(ierr>0.and.itest>=2) write(luq_tst,'(a,i4)') &
6094  'q_locpos/z_root2/ierr/4=',ierr
6095 !
6096 ! find positions for ka and kb for the case q > 0
6097 !
6098  end if
6099 !
6100  za = x_locus1(ka)
6101  zb = x_locus1(kb)
6102 !
6103  if(itest >= 1) write(luq_tst,'(a,6e12.5)') &
6104  'q_locpos: q,pmag,ka,kb,za,zb:',q,pmag,ka,kb,za,zb
6105  end if
6106 !
6107 ! compute position of mid point
6108 !
6109  kmid = 0.5*(ka+kb)
6110  km = kmid
6111 !
6112  if(q < 0) then
6113  kmidx = kmid*cos(pang+2.*pih)
6114  kmidy = kmid*sin(pang+2.*pih)
6115  else
6116  kmidx = kmid*cos(pang)
6117  kmidy = kmid*sin(pang)
6118  end if
6119 !
6120  if(itest >= 1) write(luq_tst,'(a,3f12.6)') &
6121  'q_locpos: kmid,kmidx,kmidy:',kmid,kmidx,kmidy
6122 !
6123 ! compute width of locus near mid point of locus
6124 !
6125 ! set starting values for determination of crossing point
6126 !
6127  beta1 = 0.
6128  kk1x = kmidx
6129  kk1y = kmidy
6130  beta2 = 0.5
6131  kk2x = kmidx - beta2*py
6132  kk2y = kmidy + beta2*px
6133  zz1 = x_flocus(kk1x,kk1y)
6134  zz2 = x_flocus(kk2x,kk2y)
6135 !
6136  if(itest >= 1) write(luq_tst,'(a,4f10.5,2e12.5)') &
6137  'q_locpos: k1 k2 z1/2:', &
6138  kk1x,kk1y,kk2x,kk2y,zz1,zz2
6139 !
6140  iter = 0
6141 .and. do while (zz1*zz2 > 0 iter < maxiter)
6142  iter = iter + 1
6143  kk2x = kmidx - beta2*py
6144  kk2y = kmidy + beta2*px
6145  zz1 = x_flocus(kk1x,kk1y)
6146  zz2 = x_flocus(kk2x,kk2y)
6147  if(itest >= 1) write(luq_tst,'(a,i4,4f12.5,2e12.5)') &
6148  'q_locpos: iter beta1/2 kk2x/y zz1/2:',iter,beta1,beta2, &
6149  kk2x,kk2y,zz1,zz2
6150  beta2 = beta2*2
6151  end do
6152 !
6153 ! call Ridders method to locate position of zero-crossing
6154 !
6155  if(itest >= 1) then
6156  write(luq_tst,'(a,2f10.4,2e13.5)') &
6157  'q_locpos: beta1/2 xlocus2(beta1/2):',beta1,beta2, &
6158  x_locus2(beta1),x_locus2(beta2)
6159  end if
6160 !
6161  bacc = 10.*max(beta1,beta2)*eps
6162  betaw = z_root2(x_locus2,beta1,beta2,bacc,lutest,ierr)
6163 !
6164  if(ierr>0) then
6165  if(itest>=2) write(luq_tst,'(a,i4)') &
6166  'q_locpos/z_root2/ierr_w/5=',ierr
6167  call q_error('e','root2','beta')
6168  goto 9999
6169  end if
6170 !
6171  kwx = kmidx - betaw*py
6172  kwy = kmidy + betaw*px
6173  zw = x_flocus(kwx,kwy)
6174  kw = betaw*pmag
6175 !
6176  if(itest >= 1) write(luq_tst,'(a,4f12.6,e12.5)') &
6177  'q_locpos: betaw kwx kwy kw zw:',betaw,kwx,kwy,kw,zw
6178 !
6179 ! estimate circumference of locus, assuming it to be an ellips
6180 ! estimate axis, this seems to be a rather good estimate
6181 !
6182  aa = 0.5*abs(ka-kb)
6183  bb = kw
6184 !
6185  if (aa > bb) then
6186  mm = 1-(bb/aa)**2
6187  else
6188  mm = 1-(aa/bb)**2
6189  end if
6190 !
6191  mm1 = 1.-mm
6192  a1 = 0.4630151; a2 = 0.1077812;
6193  b1 = 0.2452727; b2 = 0.0412496;
6194 !
6195  if (mm1==0) then
6196  loclen = 4.*max(aa,bb)
6197  else
6198  loclen = 4.*max(aa,bb)*((1. + a1*mm1 + a2*mm1**2) + &
6199  (b1*mm1 + b2*mm1**2)*log(1/mm1))
6200  end if
6201 !
6202  if(itest >= 1) then
6203  write(luq_tst,'(a,4f10.5)')'q_locpos: aa,bb,mm,mm1:',aa,bb,mm,mm1
6204  write(luq_tst,'(a,4f10.5)')'q_locpos: length of ellipse:',loclen
6205  end if
6206 !
6207  9999 continue
6208 !
6209  call q_stack('-q_locpos')
6210 !
6211  return
mod_time::abs
Definition: mod_time.f90:64
all_vars::s
real(sp), dimension(:,:), allocatable, target s
Definition: mod_main.f90:1288
m_constants
Definition: swmod3.f90:22
serv_xnl4v5::z_root2
real function z_root2(func, x1, x2, xacc, iprint, ierr)
Definition: swmod3.f90:1177
lims::kb
integer kb
Definition: mod_main.f90:64
ocpcomm4::itest
integer itest
Definition: swmod1.f90:536
all_vars::zz1
real(sp), dimension(:,:), allocatable, target zz1
Definition: mod_main.f90:1095
all_vars::z1
real(sp), dimension(:,:), allocatable, target z1
Definition: mod_main.f90:1094
m_constants::sqrtg
real sqrtg
Definition: swmod3.f90:27
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_makegrid()

subroutine m_xnldata::q_makegrid ( )

Definition at line 6216 of file swmod3.f90.

6216 !------------------------------------------------------------------------------
6217 !
6218 ! +-------+ ALKYON Hydraulic Consultancy & Research
6219 ! | | Gerbrant van Vledder
6220 ! | +---+
6221 ! | | +---+ Last update: 22 December 2003
6222 ! +---+ | | Release: 5.0
6223 ! +---+
6224 !
6225 !
6226 ! SWAN (Simulating WAves Nearshore); a third generation wave model
6227 ! Copyright (C) 2004-2005 Delft University of Technology
6228 !
6229 ! This program is free software; you can redistribute it and/or
6230 ! modify it under the terms of the GNU General Public License as
6231 ! published by the Free Software Foundation; either version 2 of
6232 ! the License, or (at your option) any later version.
6233 !
6234 ! This program is distributed in the hope that it will be useful,
6235 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
6236 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
6237 ! GNU General Public License for more details.
6238 !
6239 ! A copy of the GNU General Public License is available at
6240 ! http://www.gnu.org/copyleft/gpl.html#SEC3
6241 ! or by writing to the Free Software Foundation, Inc.,
6242 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
6243 !
6244 !
6245 ! do not use m_xnldata
6246  use m_constants
6247  use serv_xnl4v5
6248 !
6249 ! 0. Update history
6250 !
6251 ! 25/02/1999 Initial version
6252 ! 11/10/1999 Error handling improved; Bugs fixed when w1=w3
6253 ! 12/10/1999 Storage modified and non-geometric option included
6254 ! 16/10/1999 Equation for computing address of 2d array simplified
6255 ! 21/10/1999 Range of precomputed grid added to data file
6256 ! 22/10/1999 Renaming of some indices
6257 ! 25/10/1999 Header with grid info extended
6258 ! 12/11/1999 Output format modified of data to GRD file, adapted
6259 ! for use on UNIX systems at WES
6260 ! 08/12/1999 Interface with A_CMPLOC extended
6261 ! 28/12/1999 Routine A_CMPLOC renamed to Q_CMPLOC
6262 ! 03/01/2000 IQ_START replaced by IQ_LOCUS
6263 ! 05/01/2000 Interface with Q_CMPLOC modified
6264 ! 08/02/2000 Output to LUQLOC made conditional
6265 ! 09/08/2002 Name changed from Q_GRIDV1 to Q_MAKEGRID
6266 ! Upgrade to release 4.0
6267 ! 15/08/2002 Bug fixed in indexing bins below lowest wave number
6268 ! 20/08/2002 Sigma written to QUAD file, instead of wave numbers
6269 ! 22/08/2002 Data along locus compacted, elimate zero's
6270 ! 10/09/2002 Upgrade to release 5
6271 ! Value of LASTQUADFILE set
6272 ! 10/06/2003 Output to GRD file always without compacting
6273 ! 22/12/2003 Bug fixed in index for compacting secondary test data along locus
6274 ! Tail factor removed from compound parameter ZZ
6275 ! 24/12/2003 QUAD_T2 and QUAD_T4 always in database
6276 !
6277 ! 1. Purpose:
6278 !
6279 ! Set-up grid for computation of loci
6280 !
6281 ! Generate data file with basic loci for computation of
6282 ! nonlinear quadruplet interactions
6283 !
6284 ! 2. Method
6285 !
6286 !
6287 ! 3. Parameter list:
6288 !
6289 ! Name I/O Type Description
6290 !
6291 ! 4. Error messages
6292 !
6293 ! 5. Called by:
6294 !
6295 ! Q_CTRGRID
6296 !
6297 ! 6. Subroutines used
6298 !
6299 ! Q_STACK
6300 ! Q_CPMLOCUS
6301 ! Q_MODIFY
6302 ! Q_WEIGHT
6303 ! Q_CHKRES
6304 ! Q_NEAREST
6305 !
6306 ! 7. Remarks
6307 !
6308 ! 8. Structure
6309 !
6310 ! 9. Switches
6311 !
6312 ! 10. Source code
6313 !------------------------------------------------------------------------------
6314 ! Local variables
6315 !
6316  integer iloc,jloc ! counters
6317  integer iaq,ikq ! counters
6318  integer iaq3,ikq1,ikq3,nkq1 ! counters
6319  integer jaq1,jaq3 ! counters
6320  integer amem,kmem ! index of angle and wave number in grid
6321  real aa1,aa3,kk1,kk3 ! temporary wave number variables
6322 !
6323  integer nzloc ! counter for non-zero contributions along locus
6324  integer nztot1,nztot2 ! total number of zero and non-zero points on locus
6325  integer ik2,ia2 ! index of wave number k2
6326  integer ik4,ia4 ! index of wave number k4
6327 !
6328  real wk,wa ! weights
6329  real w1k2,w2k2,w3k2,w4k2 ! interpolation weights
6330  real w1k4,w2k4,w3k4,w4k4 ! interpolation weights
6331 !
6332  real ka,kb ! lower and higher wave number magnitude
6333  real km ! wave number at mid point
6334  real kw ! half width of locus
6335 !
6336  real tfac ! combined tail factor
6337 !
6338  logical lwrite ! indicator if binary interaction grid has been written successfully
6339  real smax ! maximum s-value
6340 !
6341  real, allocatable :: xloc(:),yloc(:)
6342  real qq
6343 !-------------------------------------------------------------------------------
6344  call q_stack('+q_makegrid')
6345 !
6346 ! initializations
6347 !
6348  lwrite = .false.
6349  nztot1 = 0
6350  nztot2 = 0
6351 !%
6352  quad_nloc = -1 ! number of points on all loci
6353 !%
6354  if(allocated(xloc)) deallocate(xloc) ; allocate (xloc(mlocus))
6355  if(allocated(yloc)) deallocate(yloc) ; allocate (yloc(mlocus))
6356 !
6357 ! write header to grid file
6358 !
6359 !
6360 ! set range of do loops for computing interaction grid
6361 !
6362  if(iq_geom==0 .or. iq_disp/=1) then
6363  nkq1 = nkq ! loop over all k1 wave numbers, since no geometric scaling can be used
6364  else
6365  nkq1 = 1 ! use only first wave number for k1, since geometric scaling can be used
6366  end if
6367 !
6368  jaq1 = 1 ! index of direction of k1 in grid matrix
6369 !-------------------------------------------------------------------------------------
6370 ! compute components of reference wave number,
6371 ! for setting up interaction grid
6372 !-------------------------------------------------------------------------------------
6373  do ikq1=1,nkq1
6374 !
6375  if(iq_screen==2) write(iscreen,*) 'k1-ring:',ikq1
6376 !
6377  aa1 = q_ad(iaref)
6378  kk1 = q_k(ikq1)
6379  krefx = kk1*cos(q_ad(iaref)*dera)
6380  krefy = kk1*sin(q_ad(iaref)*dera)
6381 !
6382  k1x = krefx
6383  k1y = krefy
6384 !
6385  if(iq_test >=1) write(luq_tst,'(a,i4,2x,2f8.4)') &
6386  'Q_MAKEGRID: ik1,krefx,krefy:',ikq1,krefx,krefy
6387 
6388  do ikq3 = ikq1,nkq !
6389  if(iq_screen==2) write(iscreen,*) 'k1-k3 indices:',ikq1,ikq3
6390 !
6391  kk3 = q_k(ikq3)
6392 !
6393  if(iq_test >= 1) write(luq_tst,'(a,3f12.6)') &
6394  'Q_MAKEGRID: kk1 kk3 kk3/kk1:',kk1,kk3,kk3/kk1
6395 !
6396  do iaq3 = iag1,iag2
6397 !
6398  if(iaq3 == iag1 .and. ikq3 == ikq1) cycle
6399 !
6400  aa3 = q_ad(iaq3)
6401  k3x = kk3*cos(aa3*dera)
6402  k3y = kk3*sin(aa3*dera)
6403 !------------------------------------------------------------------------------
6404 ! compute locus for a specified combination of k1 and k3
6405 !
6406  if(iq_test > 1) then
6407  write(luq_tst,'(a,2f10.4,2i4)') &
6408  'Q_MAKEGRID: k3 a3 ikq3 iaq3: ',kk3,aa3,ikq3,iaq3
6409  write(luq_tst,'(a,4f11.5)') &
6410  'Q_MAKEGRID: k1x/y k3x/y :',k1x,k1y,k3x,k3y
6411  end if
6412 !-----------------------------------------------------------------------------
6413  ia_k1 = iaq1; ik_k1 = ikq1
6414  ia_k3 = iaq3; ik_k3 = ikq3
6415  call q_cmplocus(ka,kb,km,kw,crf1)
6416 !
6417  if(iq_err/=0) goto 9999
6418 !------------------------------------------------------------------------------
6419 ! redistibute or filter data points along locus
6420 !
6421  call q_modify
6422  if(iq_err > 0) goto 9999
6423 !------------------------------------------------------------------------------
6424 ! compute weights for interpolation in computational grid
6425 !
6426  call q_weight
6427  if(iq_err > 0) goto 9999
6428 !------------------------------------------------------------------------------
6429 ! special storing mechanism for interactions per combination of k1 and k3
6430 !
6431  kmem = (ikq3-ikq1+1) - (ikq1-2*nkq-2)*(ikq1-1)/2;
6432  jaq3 = iaq3-iaref+1 ! ensure that data stored in matrix start at index (1,1)
6433  amem = jaq3 ! index of direction
6434 !
6435 !
6436 !-------------------------------------------------------------------------------
6437 ! Convert real indices to integer indexing and real weights
6438 !
6439 ! 3-----------4 ja2p w1 = (1-wk)*(1-wa)
6440 ! | . | w2 = wk*(1-wa)
6441 ! |. . + . . .| wa2 A w3 = (1-wk)*wa
6442 ! | . | | w4 = wk*wa
6443 ! | . | wa
6444 ! | . | |
6445 ! 1-----------2 ja2 V
6446 ! jk2 wk2 jk2p
6447 !
6448 ! <-wk->
6449 !
6450 !-------------------------------------------------------------------------------
6451  nzloc = 0
6452 !
6453  do iloc = 1,nlocus
6454 !
6455  ik2 = floor(wk_k2(iloc))
6456  ia2 = floor(wa_k2(iloc))
6457  wk = wk_k2(iloc)-real(ik2)
6458  wa = wa_k2(iloc)-real(ia2)
6459  w1k2 = (1.-wk)*(1.-wa)
6460  w2k2 = wk*(1.-wa)
6461  w3k2 = (1.-wk)*wa
6462  w4k2 = wk*wa
6463 !
6464  ik4 = floor(wk_k4(iloc))
6465  ia4 = floor(wa_k4(iloc))
6466  wk = wk_k4(iloc)-real(ik4)
6467  wa = wa_k4(iloc)-real(ia4)
6468  w1k4 = (1.-wk)*(1.-wa)
6469  w2k4 = wk*(1.-wa)
6470  w3k4 = (1.-wk)*wa
6471  w4k4 = wk*wa
6472 
6473  if(iq_interp==2) then
6474  call q_nearest(ik2,ia2,w1k2,w2k2,w3k2,w4k2)
6475  call q_nearest(ik4,ia4,w1k4,w2k4,w3k4,w4k4)
6476  end if
6477 !
6478 ! Take care of points that lie below lowest wave number
6479 ! when no geometric scaling is applied, then modify weights
6480 ! such that directional position is retained
6481 !
6482  if(iq_geom==0) then
6483  if(ik2 ==0) then
6484  ik2 = 1
6485  w1k2 = w1k2 + w2k2
6486  w2k2 = 0.
6487  w3k2 = w3k2 + w4k2
6488  w4k2 = 0.
6489  end if
6490  if(ik4 ==0) then
6491  ik4 = 1
6492  w1k4 = w1k4 + w2k4
6493  w2k4 = 0.
6494  w3k4 = w3k4 + w4k4
6495  w4k4 = 0.
6496  end if
6497  end if
6498 !
6499 ! compute combined tail factor and product of coupling coefficient, step size,
6500 ! symmetry factor, and tail factor divided by jacobian
6501 !
6502  tfac = wt_k2(iloc)*wt_k4(iloc)
6503  quad_zz(kmem,amem,iloc) = cple_mod(iloc)*ds_mod(iloc)* &
6504  sym_mod(iloc)/jac_mod(iloc)
6505 !
6506 !----------------------------------------------------------------------------------------
6507 ! compact data by elimating zero-contribution on locus
6508 !----------------------------------------------------------------------------------------
6509 !
6510  if(iq_compact==1 .and. &
6511  abs(quad_zz(kmem,amem,iloc)) > 1.e-15) then
6512  nzloc = nzloc + 1
6513  jloc = nzloc
6514  nztot1 = nztot1 + 1
6515  else
6516  jloc = iloc
6517  end if
6518  nztot2 = nztot2 + 1
6519 !
6520 ! shift data
6521 !
6522  quad_zz(kmem,amem,jloc) = quad_zz(kmem,amem,iloc)
6523 !
6524  quad_ik2(kmem,amem,jloc) = ik2 ! lower wave number index of k2
6525  quad_ia2(kmem,amem,jloc) = ia2 ! lower direction index of k2
6526  quad_ik4(kmem,amem,jloc) = ik4 ! lower wave number index of k4
6527  quad_ia4(kmem,amem,jloc) = ia4 ! lower direction index of k4
6528 !
6529  quad_w1k2(kmem,amem,jloc) = w1k2 ! weight 1 of k2
6530  quad_w2k2(kmem,amem,jloc) = w2k2 ! weight 2 of k2
6531  quad_w3k2(kmem,amem,jloc) = w3k2 ! weight 3 of k2
6532  quad_w4k2(kmem,amem,jloc) = w4k2 ! weight 4 of k2
6533 !
6534  quad_w1k4(kmem,amem,jloc) = w1k4 ! weight 1 of k4
6535  quad_w2k4(kmem,amem,jloc) = w2k4 ! weight 2 of k4
6536  quad_w3k4(kmem,amem,jloc) = w3k4 ! weight 3 of k4
6537  quad_w4k4(kmem,amem,jloc) = w4k4 ! weight 4 of k4
6538 !
6539  quad_t2(kmem,amem,jloc) = wt_k2(iloc) ! tail factor for k2
6540  quad_t4(kmem,amem,jloc) = wt_k4(iloc) ! tail factor for k4
6541 !
6542  quad_cple(kmem,amem,jloc) = cple_mod(iloc)
6543  quad_jac(kmem,amem,jloc) = jac_mod(iloc)
6544  quad_sym(kmem,amem,jloc) = sym_mod(iloc)
6545  quad_ws(kmem,amem,jloc) = ds_mod(iloc)
6546 !
6547  end do
6548 !
6549  if(iq_compact==1) then
6550  quad_nloc(kmem,amem) = nzloc ! store compacted number of points on locus
6551  else
6552  quad_nloc(kmem,amem) = nlocus ! store number of points on locus
6553  nzloc = nlocus
6554  end if
6555 !
6556 ! write(luq_prt,'(a,4i5)') 'Q_MAKEGRID kmem amem nlocus:',kmem,amem,nlocus,nzloc
6557 !
6558  end do
6559  end do
6560  end do
6561 !------------------------------------------------------------------------------
6562 ! Write locus information to binary file
6563 !------------------------------------------------------------------------------
6564 !
6565  write(luq_bqf) q_header
6566 !
6567 !------------------------------------------------------------------------------
6568 ! spectral interaction grid
6569 !------------------------------------------------------------------------------
6570 !
6571  write(luq_bqf) naq,nkq
6572  write(luq_bqf) q_sig
6573  write(luq_bqf) q_ad
6574  write(luq_bqf) iq_geom,iq_disp,iq_geom
6575  write(luq_bqf) q_depth
6576 !
6577 !------------------------------------------------------------------------------
6578 ! interaction grid
6579 !------------------------------------------------------------------------------
6580 !
6581  write(luq_bqf) quad_nloc
6582  write(luq_bqf) quad_ik2
6583  write(luq_bqf) quad_ia2
6584  write(luq_bqf) quad_ik4
6585  write(luq_bqf) quad_ia4
6586  write(luq_bqf) quad_w1k2
6587  write(luq_bqf) quad_w2k2
6588  write(luq_bqf) quad_w3k2
6589  write(luq_bqf) quad_w4k2
6590  write(luq_bqf) quad_w1k4
6591  write(luq_bqf) quad_w2k4
6592  write(luq_bqf) quad_w3k4
6593  write(luq_bqf) quad_w4k4
6594  write(luq_bqf) quad_zz
6595  write(luq_bqf) quad_t2
6596  write(luq_bqf) quad_t4
6597 !
6598  write(luq_bqf) quad_jac
6599  write(luq_bqf) quad_cple
6600  write(luq_bqf) quad_sym
6601  write(luq_bqf) quad_ws
6602 !
6603  lwrite = .true.
6604  lastquadfile = bqname
6605 !
6606  if(iq_screen >= 1 .and. iq_test>=1) write(iscreen,'(2a)') &
6607  'Q_MAKEGRID: LASTQUADFILE: ',lastquadfile
6608 !
6609  9999 continue
6610 !
6611  if(allocated(xloc)) deallocate(xloc,yloc)
6612 !
6613 ! check if BQF file has been written succesfully
6614 ! if not, deleted both the AQFILE and BQFILE
6615 !
6616  if(.not. lwrite) then
6617  close(luq_bqf,status='delete')
6618  if(iq_log > 0) then
6619  write(luq_log,*)
6620  write(luq_log,'(5a)') &
6621  'q_makegrid: grid files ',trim(aqname),' and ',trim(bqname), &
6622  ' deleted'
6623  write(luq_log,'(a)') &
6624  'q_makegrid: since an error occurred during the generation'
6625  write(luq_log,'(a)') 'q_makegrid: of the interaction grid'
6626  end if
6627  end if
6628 !-------------------------------------------------------------------------------
6629 ! write statistics of compacting to print file
6630 !
6631  if(iq_prt >=1) then
6632  if(iq_compact==0) nztot1 = nztot2
6633  write(luq_prt,'(a,i10)') &
6634  'q_makegrid: total number of points on loci :',nztot2
6635  write(luq_prt,'(a,i10)') &
6636  'q_makegrid: total number of stored points on locus:',nztot1
6637  write(luq_prt,'(a,i10)') &
6638  'q_makegrid: total number of zero points on locus :', &
6639  nztot2-nztot1
6640  write(luq_prt,'(a,f8.2)') &
6641  'q_makegrid: reduction factor(%):',real(nztot2-nztot1)/ &
6642  real(nztot2)*100.
6643  end if
6644 !
6645  call q_stack('-q_makegrid')
6646 !
6647  return
all_vars::km
real(sp), dimension(:,:), allocatable, target km
Definition: mod_main.f90:1293
mod_time::abs
Definition: mod_time.f90:64
m_constants
Definition: swmod3.f90:22
lims::kb
integer kb
Definition: mod_main.f90:64
m_constants::dera
real dera
Definition: swmod3.f90:39
control::zero
real(dp), parameter zero
Definition: mod_main.f90:882
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_modify()

subroutine m_xnldata::q_modify ( )

Definition at line 6651 of file swmod3.f90.

6651 !------------------------------------------------------------------------------
6652 !
6653 ! +-------+ ALKYON Hydraulic Consultancy & Research
6654 ! | | Gerbrant van Vledder
6655 ! | +---+
6656 ! | | +---+ Last update: 11 June 2003
6657 ! +---+ | | Release: 5.0
6658 ! +---+
6659 !
6660 !
6661 ! SWAN (Simulating WAves Nearshore); a third generation wave model
6662 ! Copyright (C) 2004-2005 Delft University of Technology
6663 !
6664 ! This program is free software; you can redistribute it and/or
6665 ! modify it under the terms of the GNU General Public License as
6666 ! published by the Free Software Foundation; either version 2 of
6667 ! the License, or (at your option) any later version.
6668 !
6669 ! This program is distributed in the hope that it will be useful,
6670 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
6671 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
6672 ! GNU General Public License for more details.
6673 !
6674 ! A copy of the GNU General Public License is available at
6675 ! http://www.gnu.org/copyleft/gpl.html#SEC3
6676 ! or by writing to the Free Software Foundation, Inc.,
6677 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
6678 !
6679 !
6680 ! do not use m_xnldata
6681  use m_constants
6682  use serv_xnl4v5
6683  implicit none
6684 !--------------------------------------------------------------------------------
6685 ! 0. Update history
6686 !
6687 ! 9/04/1999 Initial version
6688 ! 13/04/1999 New intermediate variables *_mod introduced
6689 ! 11/10/1999 Check on error messages in interpolation added
6690 ! 18/10/1999 Bug fixed in assigning new ds values to array DS_MOD
6691 ! 27/10/1999 Checked added on allocated of SOLD
6692 ! 8/12/1999 Test output added
6693 ! 29/12/1999 Bug fixed in assigning DS_MOD for first and last point on locus
6694 ! 1/10/2001 Components of k4-locus added
6695 ! No interpolation and modification if q==0
6696 ! 9/08/2002 Upgrade to version 4.0
6697 ! 15/08/2002 Step sizing improved
6698 ! 4/06/2003 Bug fixed in computing slen (length of locus)
6699 ! Locus closed to enable interpolation to finer resolution
6700 ! 6/06/2003 Activate output to XDIA configuration file
6701 ! 10/06/2003 Conversion to new indexing and lumping debugged
6702 ! 11/06/2003 Call to subroutine Q_SYMMETRY added
6703 !
6704 ! 1. Purpose:
6705 !
6706 ! Modify points along the locus, such that they are evenly distributed
6707 ! Only when intented, i.e. when IQ_LOCUS==2
6708 !
6709 ! 2. Method
6710 !
6711 ! Compute new spacing along locus
6712 ! Redistribute points and coefficient at new spacing using linear interpolation
6713 ! Output DIA configuration when also lumping active
6714 !
6715 ! If no redistribution is needed, then copy relevant data
6716 !
6717 ! 3. Parameter list:
6718 !
6719 ! Name I/O Type Description
6720 !
6721 ! 4. Error messages
6722 !
6723 ! 5. Called by:
6724 !
6725 ! Q_CMPLOCUS
6726 !
6727 ! 6. Subroutines used
6728 !
6729 ! Q_STACK
6730 ! Q_SYMMETRY
6731 ! Z_INTP1
6732 !
6733 ! 7. Remarks
6734 !
6735 ! 8. structure
6736 !
6737 ! 9. Switches
6738 !
6739 ! 10. Source code
6740 !------------------------------------------------------------------------------
6741 ! Local parameters
6742 !
6743  integer ierr,jerr ! error indicators
6744  integer nold,nnew ! old and new number of points on locus
6745  integer iold,inew ! counter for loop along points
6746  integer iloc ! counter for loop along locus
6747  integer jloc ! counter for loop over lumped locus
6748  integer itest ! local test level, by default equal to IQ_TEST
6749 !
6750  real k2a,k2m ! angle (deg) and wave number magnitude of wave number k2
6751  real k4a,k4m ! angle (deg) and wave number magnitude of wave number k4
6752  real w2,w4 ! radian frequencies of wave numbers
6753 !
6754 !
6755  real dk13,dk14 ! difference wave number
6756  real dsnew,slen ! new step size and length of locus
6757  real zero ! 0
6758  real q_eps ! accuracy to distinguish special case, with q=0
6759  real diold ! 'real' old number of indices between succeeding lumped bins
6760  real dinew ! 'real' new number of indices between succeeding lumped bins
6761 !
6762 !! real x_disper ! evaluate dispersion relation
6763  real, allocatable :: sold(:) ! old coordinate along locus
6764  real, allocatable :: snew(:) ! new coordinate along locus
6765 !--------------------------------------------------------------------------
6766  call q_stack('+q_modify')
6767 !
6768 ! initialisations
6769 !
6770  zero = 0.
6771  q_eps = 1.e-5
6772  itest = iq_test
6773 !
6774 ! itest = 1 ! set local test level for test purposes
6775 !
6776  if(itest>=1) then
6777  write(luq_tst,'(a,i4)') 'Q_MODIFY: iq_mod :',iq_mod
6778  write(luq_tst,'(a,i4)') 'Q_MODIFY: iq_xdia :',iq_xdia
6779  write(luq_tst,'(a,i4)') 'Q_MODIFY: iq_lump :',iq_lump
6780  write(luq_tst,'(a,i4)') 'Q_MODIFY: iq_gauleg:',iq_gauleg
6781  end if
6782 !------------------------------------------------------------------------------
6783 ! do not modify data when IQ_MOD==0
6784 !------------------------------------------------------------------------------
6785 !
6786  if(iq_mod==0) then
6787  nlocus = nlocus1
6788  x2_mod = x2_loc
6789  y2_mod = y2_loc
6790  x4_mod = x4_loc
6791  y4_mod = y4_loc
6792  s_mod = s_loc
6793  ds_mod = ds_loc
6794  jac_mod = jac_loc
6795  cple_mod = cple_loc
6796  call q_symmetry(k1x,k1y,k3x,k3y,x4_mod,y4_mod,sym_mod,nlocus)
6797  else
6798 !------------------------------------------------------------------------------
6799 ! Modify spacing along locus
6800 !------------------------------------------------------------------------------
6801  nold = nlocus1
6802 !
6803 ! close locus by adding one point, equal to first point
6804 ! only for normal locus
6805 !
6806  if(abs(q)>q_eps) nold = nold+1
6807 !
6808 !------------------------------------------------------------------------------
6809 ! Determine new number of points along locus
6810 !------------------------------------------------------------------------------
6811 !
6812  if(iq_gauleg > 0) then
6813  nnew = iq_gauleg
6814  elseif(iq_lump > 0) then
6815  nnew = iq_lump
6816  else
6817  nnew = nlocus0
6818  end if
6819 !
6820  if(itest>=1) write(luq_tst,'(a,2i4)') &
6821  'Q_MODIFY nold nnew:',nlocus1,nnew
6822 !
6823  allocate (sold(nold),snew(nnew))
6824 !------------------------------------------------------------------------------
6825 ! Compute circumference of locus, distinguish 2 case, open or closed
6826 !------------------------------------------------------------------------------
6827 !
6828  if(abs(q)<q_eps) then
6829  slen = s_loc(nold)
6830  sold = s_loc
6831  else
6832  slen = 0
6833  do iold=1,nold-1 ! loop length minus one, since locus is closed
6834  sold(iold) = s_loc(iold)
6835  slen = slen + ds_loc(iold)
6836  end do
6837 !
6838 !------------------------------------------------------------------------------
6839 ! close locus by copying first value in last value
6840 !------------------------------------------------------------------------------
6841 !
6842  sold(nold) = slen
6843  x2_loc(nold) = x2_loc(1)
6844  y2_loc(nold) = y2_loc(1)
6845  x4_loc(nold) = x4_loc(1)
6846  y4_loc(nold) = y4_loc(1)
6847  jac_loc(nold) = jac_loc(1)
6848  cple_loc(nold) = cple_loc(1)
6849  end if
6850 !
6851 !------------------------------------------------------------------------------
6852 ! compute new spacing along loci and coordinates along locus
6853 ! Gauss-Legendre integration
6854 !------------------------------------------------------------------------------
6855 !
6856  if(iq_gauleg > 0) then
6857  if(iq_gauleg > nnew) stop 'Q_MODIFY: iq_gauleg > nlocus0'
6858  nnew = iq_gauleg
6859  call y_gauleg(zero,slen,snew,ds_mod,nnew)
6860 !
6861  if( itest >=1) then
6862  write(luq_tst,'(a,2f10.4,i4)') &
6863  'Q_MODIFY: GAULEG x1,x2,n:',zero,slen,nnew
6864  write(luq_tst,'(a)') 'Q_MODIFY: Gauss-Legendre spacing'
6865  write(luq_tst,'(10f12.4)') (snew(inew),inew=1,nnew)
6866  write(luq_tst,'(a)') 'Q_MODIFY: Gauss-Legendre weights'
6867  write(luq_tst,'(10f12.4)') (ds_mod(inew),inew=1,nnew)
6868  end if
6869  else
6870  if(abs(q)>q_eps) then
6871  dsnew = slen/real(nnew)
6872  do inew=1,nnew
6873  snew(inew) = (inew-1.)*dsnew
6874  end do
6875  else
6876  dsnew = slen/real(nnew-1.)
6877  do inew=1,nnew
6878  snew(inew) = (inew-1)*dsnew
6879  end do
6880  end if
6881  ds_mod = dsnew
6882  end if
6883 !
6884  if(itest >= 1) then
6885  write(luq_tst,'(a,2f12.5)') 'Q_MODIFY: Slen q:',slen,q
6886  write(luq_tst,'(a,i4)') 'Q_MODIFY: nold /sold:',nold
6887  write(luq_tst,'(10f12.6)') sold
6888  write(luq_tst,'(a,i4)') 'Q_MODIFY: nnew /snew:',nnew
6889  write(luq_tst,'(10f12.6)') snew
6890  write(luq_tst,'(a)') 'Q_MODIFY: x2_loc'
6891  write(luq_tst,'(10f13.5)') (x2_loc(iloc), iloc=1,nold)
6892  write(luq_tst,'(a)') 'Q_MODIFY: y2_loc'
6893  write(luq_tst,'(10f13.5)') (y2_loc(iloc), iloc=1,nold)
6894  end if
6895 !
6896  jerr = 0
6897 !------------------------------------------------------------------------------
6898 ! Compute characteristics of locus for special case q=0
6899 !------------------------------------------------------------------------------
6900 !
6901  if(abs(q)<1.e-5) then
6902  call z_intp1(sold,x2_loc,snew,x2_mod,nold,nnew,ierr)
6903  if(ierr > 0) write(luq_err,*) 'Z_INTP1 x_loc, ierr=',ierr
6904  jerr = jerr + ierr
6905 !
6906  call z_intp1(sold,y2_loc,snew,y2_mod,nold,nnew,ierr)
6907  if(ierr > 0) write(luq_err,*) 'Z_INTP1 x_loc, ierr=',ierr
6908  jerr = jerr + ierr
6909  !
6910  call z_intp1(sold,x4_loc,snew,x4_mod,nold,nnew,ierr)
6911  if(ierr > 0) write(luq_err,*) 'Z_INTP1 x_loc, ierr=',ierr
6912  jerr = jerr + ierr
6913 !
6914  call z_intp1(sold,y4_loc,snew,y4_mod,nold,nnew,ierr)
6915  if(ierr > 0) write(luq_err,*) 'Z_INTP1 x_loc, ierr=',ierr
6916  jerr = jerr + ierr
6917 !
6918  call z_intp1(sold,s_loc,snew,s_mod,nold,nnew,ierr)
6919  if(ierr > 0) write(luq_err,*) 'Z_INTP1 x_loc, ierr=',ierr
6920  jerr = jerr + ierr
6921 !
6922  call q_symmetry(k1x,k1y,k3x,k3y,x4_mod,y4_mod,sym_mod,nnew)
6923 !
6924 ! --- lumping along locus --------------------------------------------
6925 !
6926  if(iq_lump>0) then
6927  diold = slen/real(nold)
6928  dinew = slen/real(nnew)
6929  ds_mod = 0.
6930  call q_symmetry(k1x,k1y,k3x,k3y,x4_loc,y4_loc,sym_loc,nold)
6931 !
6932  do iloc=1,nlocus1
6933  jloc = floor((iloc-1.)*diold/dinew)+1
6934  ds_mod(jloc) = ds_mod(jloc) + cple_loc(iloc)* &
6935  ds_loc(iloc)/jac_loc(iloc)*sym_loc(iloc)
6936  if(itest>=1) &
6937  write(luq_tst,'(a,2i4,f8.3,3e12.4,f4.0,e12.4)') &
6938  'Q_MODIFY Q=0 iloc,jloc s jac cple ds sym ds_mod:',&
6939  iloc,jloc,s_loc(iloc),jac_loc(iloc),cple_loc(iloc), &
6940  ds_loc(iloc),sym_loc(iloc),ds_mod(jloc)
6941  jac_mod(jloc) = 1.
6942  cple_mod(jloc) = 1.
6943  end do
6944 !
6945  sym_mod = 1 ! symmetry already taken account in lumping proces
6946 !
6947 ! --- No lumping -------------------------------------------------------------
6948 !
6949  else
6950  call z_intp1(sold,jac_loc,snew,jac_mod,nold,nnew,ierr)
6951  if(ierr > 0) write(luq_err,*) 'Z_INTP1 jac_loc, ierr=',ierr
6952  jerr = jerr + ierr
6953 !
6954  call z_intp1(sold,cple_loc,snew,cple_mod,nold,nnew,ierr)
6955  if(ierr > 0) write(luq_err,*) 'Z_INTP1 cp_loc, ierr=',ierr
6956  jerr = jerr + ierr
6957  end if
6958 !------------------------------------------------------------------------------------------------
6959 ! compute characteristics for closed locus
6960 !------------------------------------------------------------------------------------------------
6961  else
6962  call z_intp1(sold,x2_loc,snew,x2_mod,nold,nnew,ierr)
6963  if(ierr > 0) write(luq_err,*) 'Z_INTP1 x_loc, ierr=',ierr
6964  jerr = jerr + ierr
6965 !
6966  call z_intp1(sold,y2_loc,snew,y2_mod,nold,nnew,ierr)
6967  if(ierr > 0) write(luq_err,*) 'Z_INTP1 y_loc, ierr=',ierr
6968  jerr = jerr + ierr
6969 !
6970  call z_intp1(sold,x4_loc,snew,x4_mod,nold,nnew,ierr)
6971  if(ierr > 0) write(luq_err,*) 'Z_INTP1 x_loc, ierr=',ierr
6972  jerr = jerr + ierr
6973 !
6974  call z_intp1(sold,y4_loc,snew,y4_mod,nold,nnew,ierr)
6975  if(ierr > 0) write(luq_err,*) 'Z_INTP1 y_loc, ierr=',ierr
6976  jerr = jerr + ierr
6977 !
6978  call z_intp1(sold,s_loc,snew,s_mod,nold,nnew,ierr)
6979  if(ierr > 0) write(luq_err,*) 'Z_INTP1 s_loc, ierr=',ierr
6980  jerr = jerr + ierr
6981 !
6982  if(itest>=1) then
6983  write(luq_tst,'(a)') 'Q_MODIFY: s_loc'
6984  write(luq_tst,'(10f13.5)') (s_loc(iloc), iloc=1,nold)
6985  write(luq_tst,'(a)') 'Q_MODIFY: s_mod'
6986  write(luq_tst,'(10f13.5)') (s_mod(iloc), iloc=1,nold)
6987  end if
6988 !
6989  call q_symmetry(k1x,k1y,k3x,k3y,x4_mod,y4_mod,sym_mod,nnew)
6990 !
6991 ! ----- Lumping along locus -----------------------------------
6992 !
6993  if(iq_lump>0) then
6994  diold = slen/real(nold-1)
6995  dinew = slen/real(nnew)
6996  ds_mod = 0.
6997  call q_symmetry(k1x,k1y,k3x,k3y,x4_loc,y4_loc,sym_loc,nold)
6998 !
6999  do iloc=1,nold-1
7000  jloc = floor((iloc-1.)*diold/dinew + 1.49999)
7001  jloc = mod(jloc-1+nnew,nnew)+1
7002  ds_mod(jloc) = ds_mod(jloc) + cple_loc(iloc)* &
7003  ds_loc(iloc)/jac_loc(iloc)*sym_loc(iloc)
7004  if(itest>=1) &
7005  write(luq_tst,'(a,2i4,f8.3,3e12.4,f4.0,e12.4)') &
7006  'Q_MODIFY: q>0: iloc,jloc, s jac cple ds sym ds_mod:', &
7007  iloc,jloc,s_loc(iloc),jac_loc(iloc),cple_loc(iloc), &
7008  ds_loc(iloc),sym_loc(iloc),ds_mod(jloc)
7009  jac_mod(jloc) = 1.
7010  cple_mod(jloc) = 1.
7011  end do
7012 !
7013  sym_mod = 1 ! symmetry already taken account in lumping proces
7014 !
7015 !------------ No lumping along locus --------------------------------
7016 !
7017  else
7018  call z_intp1(sold,jac_loc,snew,jac_mod,nold,nnew,ierr)
7019  if(ierr > 0) write(luq_err,*) 'Z_INTP1 jac_loc, ierr=',ierr
7020  jerr = jerr + ierr
7021 !
7022  call z_intp1(sold,cple_loc,snew,cple_mod,nold,nnew,ierr)
7023  if(ierr > 0) write(luq_err,*) 'Z_INTP1 cp_loc, ierr=',ierr
7024  jerr = jerr + ierr
7025  end if
7026 !
7027  if(jerr > 0) then
7028  iq_err = iq_err + 1
7029  call q_error('e','INTER','Problem in interpolation process')
7030  goto 9999
7031  end if
7032  end if
7033 !
7034  nlocus = nnew
7035 !
7036  end if
7037 !
7038 !------------------------------------------------------------------------------
7039 !
7040  if(itest >= 1) then
7041  write(luq_tst,'(a)') 'Q_MODIFY: x2_mod'
7042  write(luq_tst,'(10f12.5)') (x2_mod(iloc),iloc=1,nlocus)
7043  write(luq_tst,'(a)') 'Q_MODIFY: y2_mod'
7044  write(luq_tst,'(10f12.5)') (y2_mod(iloc),iloc=1,nlocus)
7045  write(luq_tst,'(a)') 'Q_MODIFY: x4_mod'
7046  write(luq_tst,'(10f12.5)') (x4_mod(iloc),iloc=1,nlocus)
7047  write(luq_tst,'(a)') 'Q_MODIFY: y4_mod'
7048  write(luq_tst,'(10f12.5)') (y4_mod(iloc),iloc=1,nlocus)
7049  write(luq_tst,'(a)') 'Q_MODIFY: s_mod'
7050  write(luq_tst,'(10f12.5)') (s_mod(iloc),iloc=1,nlocus)
7051  write(luq_tst,'(a)') 'Q_MODIFY: ds_loc'
7052  write(luq_tst,'(10f12.5)') (ds_loc(iloc),iloc=1,nold)
7053  write(luq_tst,'(a)') 'Q_MODIFY: ds_mod'
7054  write(luq_tst,'(10f12.5)') (ds_mod(iloc),iloc=1,nlocus)
7055  end if
7056 !
7057 !------------------------------------------------------------------------------
7058 !
7059 !! compute symmetry factor for reducing computational load
7060 !!
7061 !!call q_symmetry(k1x,k1y,k3x,k3y,x4_mod,y4_mod,sym,nnew)
7062 !!
7063  do iloc=1,nlocus
7064  k2x = x2_mod(iloc)
7065  k2y = y2_mod(iloc)
7066  k4x = x4_mod(iloc)
7067  k4y = y4_mod(iloc)
7068 !
7069  k2m = sqrt(k2x**2 + k2y**2)
7070  k4m = sqrt(k4x**2 + k4y**2)
7071  k2a = atan2(k2y,k2x)*rade
7072  k4a = atan2(k4y,k4x)*rade
7073 !
7074  k2m_mod(iloc) = k2m
7075  k4m_mod(iloc) = k4m
7076  k2a_mod(iloc) = k2a
7077  k4a_mod(iloc) = k4a
7078 !
7079 !
7080 !
7081  end do
7082 !
7083  if(itest >= 1) then
7084  write(luq_tst,'(a)') 'Q_MODIFY: k2m_mod'
7085  write(luq_tst,'(10f12.5)') (k2m_mod(iloc),iloc=1,nlocus)
7086  write(luq_tst,'(a)') 'Q_MODIFY: k2a_mod'
7087  write(luq_tst,'(10f12.5)') (k2a_mod(iloc),iloc=1,nlocus)
7088  write(luq_tst,'(a)') 'Q_MODIFY: k4m_mod'
7089  write(luq_tst,'(10f12.5)') (k4m_mod(iloc),iloc=1,nlocus)
7090  write(luq_tst,'(a)') 'Q_MODIFY: k4a_mod'
7091  write(luq_tst,'(10f12.5)') (k4a_mod(iloc),iloc=1,nlocus)
7092  write(luq_tst,'(a)') 'Q_MODIFY: sym_mod'
7093  write(luq_tst,'(20f3.0)') (sym_mod(iloc),iloc=1,nlocus)
7094  end if
7095 !
7096  9999 continue
7097 !
7098  if(allocated(sold)) deallocate(sold,snew)
7099 !
7100  call q_stack('-q_modify')
7101 !
7102  return
mod_time::abs
Definition: mod_time.f90:64
m_constants
Definition: swmod3.f90:22
mod_time::mod
Definition: mod_time.f90:69
serv_xnl4v5::z_intp1
subroutine z_intp1(x1, y1, x2, y2, n1, n2, ierr)
Definition: swmod3.f90:786
ocpcomm4::itest
integer itest
Definition: swmod1.f90:536
control::zero
real(dp), parameter zero
Definition: mod_main.f90:882
serv_xnl4v5::y_gauleg
subroutine y_gauleg(x1, x2, x, w, n)
Definition: swmod3.f90:670
m_constants::rade
real rade
Definition: swmod3.f90:40
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_nearest()

subroutine m_xnldata::q_nearest ( integer, intent(inout)  ik,
integer, intent(inout)  ia,
real, intent(inout)  w1,
real, intent(inout)  w2,
real, intent(inout)  w3,
real, intent(inout)  w4 
)

Definition at line 7106 of file swmod3.f90.

7106 !------------------------------------------------------------------------------
7107 !
7108 ! +-------+ ALKYON Hydraulic Consultancy & Research
7109 ! | | Gerbrant van Vledder
7110 ! | +---+
7111 ! | | +---+ Last update: 29 April 2004
7112 ! +---+ | | Release: 5.0
7113 ! +---+
7114 !
7115 !
7116 ! SWAN (Simulating WAves Nearshore); a third generation wave model
7117 ! Copyright (C) 2004-2005 Delft University of Technology
7118 !
7119 ! This program is free software; you can redistribute it and/or
7120 ! modify it under the terms of the GNU General Public License as
7121 ! published by the Free Software Foundation; either version 2 of
7122 ! the License, or (at your option) any later version.
7123 !
7124 ! This program is distributed in the hope that it will be useful,
7125 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
7126 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
7127 ! GNU General Public License for more details.
7128 !
7129 ! A copy of the GNU General Public License is available at
7130 ! http://www.gnu.org/copyleft/gpl.html#SEC3
7131 ! or by writing to the Free Software Foundation, Inc.,
7132 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
7133 !
7134 !
7135 ! do not use m_xnldata
7136  implicit none
7137 !
7138 ! 0. Update history
7139 !
7140 ! 19/08/2002 Initial version
7141 ! 18/04/2003 Range of k-index limited
7142 ! 29/04/2004 Names of integer variables changes
7143 !
7144 ! 1. Purpose:
7145 !
7146 ! Compute corner point of spectral bin which is nearest to
7147 ! given bin
7148 !
7149 !
7150 ! 2. Method
7151 !
7152 ! The indexing is as in figure
7153 !
7154 !
7155 ! (ik,ia+1) (ik+1,ia+1)
7156 ! 3-----------4
7157 ! | . |
7158 ! |. . + . . .|
7159 ! | . |
7160 ! | . |
7161 ! | . |
7162 ! 1-----------2
7163 ! (ik,ia) (ik+1,ia)
7164 !
7165 ! Check all four corner points which has the maximum weight
7166 !
7167 ! 3. Parameter list:
7168 !
7169 !Type I/O name description
7170 !-------------------------------------------------------
7171  integer, intent(inout) :: ik ! Index of wave number
7172  integer, intent(inout) :: ia ! index of angle
7173  real, intent(inout) :: w1 ! weight of first corner point
7174  real, intent(inout) :: w2 ! weight of second corner point
7175  real, intent(inout) :: w3 ! weight of third corner point
7176  real, intent(inout) :: w4 ! weight of fourth corner point
7177 !
7178 ! 4. Error messages
7179 !
7180 ! 5. Called by
7181 !
7182 ! Q_MAKEGRID
7183 !
7184 ! 6. Subroutines used
7185 !
7186 ! 7. Remarks
7187 !
7188 ! 8. Structure
7189 !
7190 ! 9. Switches
7191 !
7192 ! 10. Source code
7193 !-------------------------------------------------------------------------------------
7194 ! Local parameters
7195 !
7196  integer ik_max ! k-index with maximum weight
7197  integer ia_max ! theta index with maximum weight
7198  integer iw_max ! index with highest weight
7199  real w_max ! maximum weight
7200 !------------------------------------------------------------------------------
7201  if(iq_test>=2) write(luq_tst,'(a,2i4,4f10.5)') &
7202  'Q_NEAREST-A:',ik,ia,w1,w2,w3,w4
7203 !
7204  w_max = 0.
7205  ik_max = ik
7206  ia_max = ia
7207  iw_max = 1
7208 !
7209  if(w1 >= w_max) then
7210  iw_max = 1
7211  w_max = w1
7212  ik_max = ik
7213  ia_max = ia
7214  end if
7215 !
7216  if(w2 >= w_max) then
7217  iw_max = 2
7218  w_max = w2
7219  ik_max = ik+1
7220  ia_max = ia
7221  end if
7222 !
7223  if(w3 >= w_max) then
7224  iw_max = 3
7225  w_max = w3
7226  ik_max = ik
7227  ia_max = ia+1
7228  end if
7229 !
7230  if(w4 >= w_max) then
7231  iw_max = 4
7232  w_max = w4
7233  ik_max = ik+1
7234  ia_max = ia+1
7235  end if
7236 !
7237  w1 = 0.0
7238  w2 = 0.0
7239  w3 = 0.0
7240  w4 = 0.0
7241 !
7242  ik = ik_max
7243  ia = ia_max
7244 !
7245 ! 18/04/2003 Limit range of nearest k-indices
7246 !
7247  ik = min(ik,nkq)
7248  ik = max(1,ik)
7249 !
7250  if(iw_max==1) w1 = 1.0
7251  if(iw_max==2) w2 = 1.0
7252  if(iw_max==3) w3 = 1.0
7253  if(iw_max==4) w4 = 1.0
7254 !
7255  if(iq_test>=2) then
7256  write(luq_tst,'(a,2i4,4f10.5)') 'Q_NEAREST-B:',ik,ia,w1,w2,w3,w4
7257  write(luq_tst,*)
7258  end if
7259 !
7260  return
Here is the caller graph for this function:

◆ q_polar2()

subroutine m_xnldata::q_polar2 ( real, intent(in)  kmin,
real, intent(in)  kmax,
real, intent(in)  kx_beg,
real, intent(in)  ky_beg,
real, intent(in)  kx_end,
real, intent(in)  ky_end,
real, intent(in)  loclen,
integer, intent(out)  ierr 
)

Definition at line 7265 of file swmod3.f90.

7265 !------------------------------------------------------------------------------
7266 !
7267 ! +-------+ ALKYON Hydraulic Consultancy & Research
7268 ! | | Gerbrant van Vledder
7269 ! | +---+
7270 ! | | +---+ Last update: 8 Aug. 2003
7271 ! +---+ | | Release: 5.0
7272 ! +---+
7273 !
7274 !
7275 ! SWAN (Simulating WAves Nearshore); a third generation wave model
7276 ! Copyright (C) 2004-2005 Delft University of Technology
7277 !
7278 ! This program is free software; you can redistribute it and/or
7279 ! modify it under the terms of the GNU General Public License as
7280 ! published by the Free Software Foundation; either version 2 of
7281 ! the License, or (at your option) any later version.
7282 !
7283 ! This program is distributed in the hope that it will be useful,
7284 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
7285 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
7286 ! GNU General Public License for more details.
7287 !
7288 ! A copy of the GNU General Public License is available at
7289 ! http://www.gnu.org/copyleft/gpl.html#SEC3
7290 ! or by writing to the Free Software Foundation, Inc.,
7291 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
7292 !
7293 !
7294 ! do not use m_xnldata
7295  use m_constants
7296  use serv_xnl4v5, only: z_wnumb
7297 !
7298  implicit none
7299 !
7300 ! 0. Update history
7301 !
7302 ! Date Description
7303 !
7304 ! 03/12/1999 Initial version
7305 ! 09/08/2002 Geometric spacing of k added
7306 ! Upgrade to release 4.0
7307 ! 13/08/2002 reorganisation of loops generating points on locus
7308 ! 08/08/2003 Check included for maximum number of IPOL by using MPOL
7309 ! MPOL=MLOCUS/2+1-1 (-1 added regarding IPOL=IPOL+1 in Q_MODIFY)
7310 ! Check included on ARG=0 for IQ_LOCUS=2 and parameter dke added
7311 !
7312 ! 1. Purpose:
7313 !
7314 ! Compute position of locus for given k1-k3 vector
7315 !
7316 ! 2. Method
7317 !
7318 ! Explicit polar method, see Van Vledder 2000, Monterey paper
7319 ! Optionally using a fixed k-step, geometric k-step or adaptive stepping
7320 !
7321 ! 3. Parameters used:
7322 !
7323 !Type I/O Name Description
7324 !------------------------------------------------------------------------------
7325  real, intent(in) :: kmin ! minimum wave number on locus
7326  real, intent(in) :: kmax ! maximum wave number on locus
7327  real, intent(in) :: kx_beg ! x-coordinate of begin point
7328  real, intent(in) :: ky_beg ! y-coordinate of begin point
7329  real, intent(in) :: kx_end ! x-coordinate of end point
7330  real, intent(in) :: ky_end ! y-coordinate of end point
7331  real, intent(in) :: loclen ! estimated length of locus
7332  integer, intent (out) :: ierr ! error condition
7333 !
7334 ! Parameters with module
7335 !
7336 ! nlocus0 Preferred number of points on locus
7337 ! q w1-w3, difference of radian frequencies
7338 ! pmag |k1-k3| (vector form)
7339 ! pdir direction of difference vector k1-k3
7340 !
7341 ! 4. Error messages
7342 !
7343 ! 5. Called by:
7344 !
7345 ! Q_CPMLOCUS
7346 !
7347 ! 6. Subroutines used:
7348 !
7349 ! X_COSK
7350 !
7351 ! 7. Remarks
7352 !
7353 ! The type of locus computation is controlled by the parameter IQ_LOCUS
7354 ! Set in Q_SETCFG
7355 !
7356 ! 8. Structure
7357 !
7358 ! 9. Switches
7359 !
7360 ! /S enable subroutine tracing
7361 ! /T enable test output
7362 !
7363 ! 10. Source code
7364 !------------------------------------------------------------------------------
7365 ! Local variabels
7366 !
7367  integer ipol ! counter
7368  integer jpol ! counter
7369  integer iend ! indicates end of locus computation
7370  integer ipass ! counter for passes
7371  integer npol ! number of points on locus
7372  integer npass ! number of passes in iteration process
7373  integer mpol ! maximum number of points on locus, related to MLOCUS
7374 !
7375  real kold ! temporary wave number
7376  real knew ! temporary wave number
7377  real cosold ! 'old' cosine of angle
7378  real cosnew ! 'new' cosine of angle
7379  real dkpol ! step in wave number
7380  real dkold ! 'old' step in wave number
7381  real ang1 ! 'old' angle
7382  real ang2 ! 'new' angle
7383  real kk1 ! 'old' wave number
7384  real kk2 ! 'new' wave number
7385  real kratio ! ratio between succesive k-values when IQ_LOCUS=3
7386  real arg ! argument
7387  real dk ! step in wave number
7388  real dke ! estimate of new dk
7389  real dsnew ! new step size along locus
7390  real dsz ! estimated step size along locus
7391 !
7392  integer itest ! local test level
7393  integer lutest ! unit number for test output in service routine
7394 !
7395 ! function declarations
7396 !!!real z_wnumb ! compute wave number, via module SERV_XNL4V4
7397 !! real x_disper ! dispersion relation
7398 !
7399 !------------------------------------------------------------------------------
7400 ! initialisations
7401 !------------------------------------------------------------------------------
7402  call q_stack('+q_polar2')
7403 !
7404  ierr = 0 ! set error code to zero
7405  npol = (nlocus0+1)/2+1 ! first estimate of number k-values along symmetry axis
7406  mpol = mlocus/2 ! set maximum number of points along locus axis
7407 !
7408 !-------------------------------------------------------------------------------
7409 !
7410  select case(iq_locus)
7411 !------------------------------------------------------------------------------
7412 ! CASE = 1: Linear spacing of wave numbers along symmetry axis
7413 !------------------------------------------------------------------------------
7414  case(1)
7415 !
7416  dk = (kmax-kmin)/real(npol-1)
7417  do ipol=1,npol
7418  k_pol(ipol) = kmin + (ipol-1)*dk
7419  c_pol(ipol) = x_cosk(k_pol(ipol))
7420  end do
7421 !------------------------------------------------------------------------------
7422 ! Case = 2: Variable k-stepping along symmetry axis,
7423 ! such that step along locus is more or less constant
7424 !------------------------------------------------------------------------------
7425  case(2)
7426 !
7427 ! set first point on locus
7428 !
7429  ipol = 1
7430  k_pol(ipol) = kmin
7431  c_pol(ipol) = -1.
7432  kold = kmin
7433  cosold = -1.
7434 !
7435 ! compute initial step size of polar wave number
7436 !
7437  dk0 = (kmax - kmin)/real(npol) ! estimate of step size of equidistant radii
7438  dsz = loclen/real(nlocus0) ! estimate of step size along locus
7439  npass = 3 ! set number of passes in iteration
7440  dk0 = dk0/2 ! reduce initial step
7441  dk = dk0
7442  iend = 0
7443 !
7444  if(iq_test>=2) write(luq_tst,'(a,3f12.6)') &
7445  'q_polar2: loclen dsz dk:',loclen,dsz,dk
7446 !
7447 .and..and. do while (k_pol(ipol) < kmax iend==0 ipol < mpol)
7448  do ipass=1,npass
7449  knew = min(kmax,k_pol(ipol)+dk)
7450  dkold = knew - k_pol(ipol)
7451  cosnew = x_cosk(knew)
7452  ang1 = pang + acos(cosold)
7453  ang2 = pang + acos(cosnew)
7454  kk1 = kold
7455  kk2 = knew
7456  arg = kk1**2 + kk2**2 -2.*kk1*kk2*cos(ang1-ang2)
7457  dsnew = sqrt(abs(arg))
7458  if(dsnew>0) dke = dk*dsz/dsnew
7459  dk = dke
7460  end do
7461 !----------------------------------------------------------------------------------------------
7462 ! assign new estimate and check value of IPOL
7463 !----------------------------------------------------------------------------------------------
7464  ipol = ipol + 1
7465  k_pol(ipol) = k_pol(ipol-1) + dkold
7466  c_pol(ipol) = cosnew
7467  kold = knew
7468  cosold = cosnew
7469  if (abs(dkold) < 0.0005*(kmax-kmin)) iend=1
7470  end do
7471 !
7472 ! fill last bin with coordinates of end point
7473 !
7474 .and. if(k_pol(ipol) < kmax ipol < mpol) then
7475  ipol = ipol + 1
7476  c_pol(ipol) = -1.
7477  k_pol(ipol) = kmax
7478  end if
7479 !
7480 ! update the number of k-points on symmetry axis
7481 !
7482  npol = ipol
7483 !
7484 !-------------------------------------------------------------------------------
7485 ! Case 3: Geometric spacing of wave numbers along symmetry axis
7486 !-------------------------------------------------------------------------------
7487  case(3)
7488  kratio = (kmax/kmin)**(1./(npol-1.))
7489  if(iq_test>=2) write(luq_tst,'(a,i4,3f11.6)') &
7490  'q_polar2: npol kmin kmax kratio:',npol,kmin,kmax,kratio
7491  do ipol=1,npol
7492  k_pol(ipol) = kmin*kratio**(ipol-1.)
7493  c_pol(ipol) = x_cosk(k_pol(ipol))
7494  end do
7495 !
7496  end select
7497 !
7498 !------------------------------------------------------------------------------
7499 !
7500 ! compute actual number of points on locus
7501 ! this will always be an even number
7502 ! mirror image the second half of the locus
7503 !
7504  nlocus1 = 2*npol-2
7505 !
7506  a_pol(1) = pang + acos(c_pol(1))
7507  c_pol(1) = cos(a_pol(1))
7508 !
7509  do ipol=2,npol
7510  jpol = 2*npol-ipol
7511  a_pol(ipol) = pang + acos(c_pol(ipol))
7512  a_pol(jpol) = pang - acos(c_pol(ipol))
7513  c_pol(jpol) = cos(a_pol(jpol))
7514  k_pol(jpol) = k_pol(ipol)
7515  end do
7516 !
7517 ! compute x- and y-position along locus
7518 !
7519  do ipol=1,nlocus1
7520  x2_loc(ipol) = k_pol(ipol)*cos(a_pol(ipol))
7521  y2_loc(ipol) = k_pol(ipol)*sin(a_pol(ipol))
7522  end do
7523 !
7524  if(iq_test >= 1) then
7525  write(luq_tst,'(a,3i4)') &
7526  'q_polar2: nlocus0 npol nlocus1:',nlocus0,npol,nlocus1
7527  write(luq_tst,'(a,2f12.6,i4)') &
7528  'q_polar2: kmin kmax iq_locus :',kmin,kmax,iq_locus
7529  if(iq_locus==1) write(luq_tst,'(a,f10.4)') &
7530  'q_polar2: dk :',dk
7531  if(iq_locus==3) write(luq_tst,'(a,f10.4)') &
7532  'q_polar2: kratio :',kratio
7533  do ipol=1,nlocus1
7534  write(luq_tst,'(a,i4,4f13.7)') &
7535  'q_polar2: i k(i) a(i) x(i) y(i):',ipol,k_pol(ipol),&
7536  a_pol(ipol),x2_loc(ipol),y2_loc(ipol)
7537  end do
7538  end if
7539 !
7540  9999 continue
7541 !
7542  call q_stack('-q_polar2')
7543 !
7544  return
control::iend
integer(itime) iend
Definition: mod_main.f90:853
m_constants
Definition: swmod3.f90:22
serv_xnl4v5::z_wnumb
real function z_wnumb(w, d, grav_w)
Definition: swmod3.f90:1467
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_searchgrid()

subroutine m_xnldata::q_searchgrid ( real, intent(in)  depth,
integer, intent(out)  igrid 
)

Definition at line 7841 of file swmod3.f90.

7841 !------------------------------------------------------------------------------
7842 !
7843 ! +-------+ ALKYON Hydraulic Consultancy & Research
7844 ! | | Gerbrant van Vledder
7845 ! | +---+
7846 ! | | +---+ Last update: 28 April 2004
7847 ! +---+ | | Release: 5.03
7848 ! +---+
7849 !
7850 !
7851 ! SWAN (Simulating WAves Nearshore); a third generation wave model
7852 ! Copyright (C) 2004-2005 Delft University of Technology
7853 !
7854 ! This program is free software; you can redistribute it and/or
7855 ! modify it under the terms of the GNU General Public License as
7856 ! published by the Free Software Foundation; either version 2 of
7857 ! the License, or (at your option) any later version.
7858 !
7859 ! This program is distributed in the hope that it will be useful,
7860 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
7861 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
7862 ! GNU General Public License for more details.
7863 !
7864 ! A copy of the GNU General Public License is available at
7865 ! http://www.gnu.org/copyleft/gpl.html#SEC3
7866 ! or by writing to the Free Software Foundation, Inc.,
7867 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
7868 !
7869 !
7870 ! do not use m_xnldata
7871  implicit none
7872 !------------------------------------------------------------------------------
7873 ! 0. Update history
7874 !
7875 ! Version Date Modification
7876 !
7877 ! 20/08/2002 Initial version
7878 ! 29/08/2002 Write statements made conditionsl
7879 ! 5/09/2003 Search algorithm improved
7880 ! 09/09/2003 facotr ID_FACMAX introduced and extra test output created
7881 ! Input water depth saved for output
7882 ! 28/04/2004 Bug fixed in location of save input depth to s_depth
7883 !
7884 ! 1. Purpose:
7885 !
7886 ! Search nearest valid grid, read grid file and scale factor
7887 !
7888 ! 2. Method
7889 !
7890 ! Using the actual water depth
7891 ! all possible interaction grids are checked
7892 ! in upward and downward direction
7893 !
7894 ! 3. Parameters used
7895 !
7896  real, intent(in) :: depth ! depth for which grid file must be found
7897  integer, intent(out) :: igrid ! status of grid checking
7898 ! ==0: a proper grid exists
7899 ! ==1: grid file does not exist
7900 ! ==2: grid file exists, but it is incorrect
7901 ! ==3: read error in accessing grid information
7902 !
7903 ! 4. Error messages
7904 !
7905 ! 5. Called by:
7906 !
7907 ! Q_XNL4V4
7908 !
7909 ! 6. Subroutines used
7910 !
7911 ! Q_CTRGRID
7912 ! Q_STACK
7913 !
7914 ! 7. Remarks
7915 !
7916 !
7917 ! 8. Structure
7918 !
7919 !
7920 ! 9. Switches
7921 !
7922 ! 10. Source code
7923 !---------------------------------------------------------------------------
7924 ! Local variables
7925 !
7926  integer id ! counter
7927  integer idepth ! integer depth
7928  integer id_upper ! upper limit of search
7929  integer id_lower ! lower limit of depth search
7930 !
7931  real d_lower ! lower valid depth
7932  real d_upper ! upper valid depth
7933  real r_lower ! ratio with lower valid depth
7934  real r_upper ! ratio with upper valid depth
7935  real s_depth ! target depth in m, saved in this variable
7936  real dfac1,dfac2 ! depth scale factors
7937  real eps ! accuracy
7938 !------------------------------------------------------------------------------
7939 !
7940  call q_stack('+q_searchgrid')
7941 !
7942  eps = 0.0001
7943 !
7944 ! save depth for which nearest grid file is to be found
7945 !
7946  s_depth = depth
7947 !
7948 !------------------------------------------------------------------------------
7949 ! check if a depth exists for current grid
7950 !------------------------------------------------------------------------------
7951 !
7952  if(iq_prt>=1) write(luq_prt,'(a,f10.2)') &
7953  'Q_SEARCHGRID: Input target depth:',depth
7954 !
7955  q_depth = depth + eps
7956 
7957  call q_ctrgrid(1,igrid)
7958 !
7959  if(iq_prt>=1) write(luq_prt,'(a,i4,f12.2)') &
7960  'Q_SEARCHGRID: First call of Q_CTRGGRID exit code & q_depth:', &
7961  igrid,q_depth
7962 !
7963  if(igrid==0) then
7964  if(iq_prt>=1) then
7965  write(luq_prt,'(a,f10.2)') 'Q_SEARCHGRID: target depth:', &
7966  q_depth
7967  write(iscreen,'(a)') &
7968  'Q_SEARCHGRID: grid accepted, read whole database'
7969  end if
7970  if(iq_screen>=1) write(iscreen,'(a)') &
7971  'Q_SEARCHGRID: grid accepted, read whole database'
7972 !
7973  call q_ctrgrid(2,igrid)
7974  goto 9999
7975  end if
7976 !
7977  idepth = int(s_depth*10+eps)
7978  id_lower = int(q_mindepth*10+eps)
7979  id_upper = int(q_maxdepth*10+eps)
7980 !
7981  id_upper = min(id_facmax*idepth,id_upper)
7982 !
7983 ! set 'not found' condition
7984 !
7985  d_lower = -1.
7986  d_upper = -1.
7987 !
7988  if(iq_prt>=2) write(luq_prt,'(a,3i6)') &
7989  'Q_SEARCHGRID: idepth,id_lower/upper:', &
7990  idepth,id_lower,id_upper
7991 !------------------------------------------------------------------------------
7992 ! search downwards until a valid grid is found
7993 !------------------------------------------------------------------------------
7994 !
7995  do id = idepth-1,id_lower,-1
7996  q_depth = real(id)/10.+eps
7997  if(iq_prt>=2) write(luq_prt,'(a,i6,f8.1)') &
7998  'Q_SEARCHGRID: downwards id q_depth:',id,q_depth
7999 
8000  call q_ctrgrid(1,igrid)
8001 
8002  if(iq_prt>=2) write(luq_prt,'(a,i4)') &
8003  'Q_SEARCHGRID: igrid:',igrid
8004 
8005  if(igrid==0) then
8006  if(iq_prt>=2) write(luq_prt,'(a,f8.2)') &
8007  'Q_SEARCHGRID: valid grid found for depth:',q_depth
8008  d_lower = q_depth
8009  exit
8010  end if
8011  end do
8012 !
8013 !------------------------------------------------------------------------------
8014 ! seach upwards until a valid grid is found
8015 !------------------------------------------------------------------------------
8016 !
8017  do id = idepth+1,id_upper
8018  q_depth = real(id)/10.+eps
8019 
8020  if(iq_prt>=2) write(luq_prt,'(a,i6,f8.1)') &
8021  'q_searchgrid: upwards id q_depth:',id,q_depth
8022 
8023  call q_ctrgrid(1,igrid)
8024 
8025  if(iq_prt>=2) write(luq_prt,'(a,i4)') &
8026  'q_searchgrid: igrid:',igrid
8027 
8028  if(igrid==0) then
8029  if(iq_prt>=2) write(luq_prt,'(a,f8.2)') &
8030  'q_searchgrid: valid grid found for depth:',q_depth
8031  d_upper = q_depth
8032  exit
8033  end if
8034  end do
8035  if(iq_prt>=1) write(luq_prt,*)
8036 !------------------------------------------------------------------------------
8037 !
8038 ! determine nearest grid
8039 !------------------------------------------------------------------------------
8040 !
8041  if(d_lower > 0) then
8042  r_lower = s_depth/d_lower
8043  else
8044  r_lower = -1.
8045  end if
8046 !
8047  if(d_upper > 0) then
8048  r_upper = d_upper/s_depth
8049  else
8050  r_upper = -1.
8051  end if
8052 !
8053  if(iq_prt>=1) then
8054  write(luq_prt,'(a,3f8.2)') &
8055  'q_searchgrid: d_lower d_target d_upper :', &
8056  d_lower,s_depth,d_upper
8057  write(luq_prt,'(a,2f8.2)') &
8058  'q_searchgrid: r_lower r_upper :', &
8059  r_lower,r_upper
8060  end if
8061 !------------------------------------------------------------------------------
8062 ! select nearest valid grid
8063 !------------------------------------------------------------------------------
8064 .and. if(r_lower>0 r_upper>0) then
8065  if(r_lower < r_upper) then
8066  q_depth = d_lower
8067  else
8068  q_depth = d_upper
8069  end if
8070 !
8071 .and. elseif(r_lower > 0 r_upper <0 ) then
8072  q_depth = d_lower
8073 .and. elseif(r_lower < 0 r_upper > 0) then
8074  q_depth = d_upper
8075  else
8076  call q_error('e','searchgrid', &
8077  'no valid nearest grid could be found')
8078  goto 9999
8079  end if
8080 !
8081  if(iq_prt>=1) write(luq_prt,'(a,2f10.2)') &
8082  'q_searchgrid: target and nearest water depth :',s_depth,q_depth
8083  if(iq_screen>0) write(iscreen,'(a,f10.2)') &
8084  'q_searchgrid: nearest valid bqf depth:',q_depth
8085 !-----------------------------------------------------------------------------------------------
8086 ! compute depth scaling factors
8087 !------------------------------------------------------------------------------
8088 !
8089  call q_dscale(a,q_sig,q_a,nkq,naq,s_depth,q_grav,dfac1)
8090  call q_dscale(a,q_sig,q_a,nkq,naq,q_depth,q_grav,dfac2)
8091 !
8092  q_scale = dfac1/dfac2
8093 !
8094  if(iq_prt>=1) then
8095  write(luq_prt,'(a,2f8.4)') &
8096  'q_searchgrid: target and nearest scale factors:',dfac1,dfac2
8097  write(luq_prt,'(a,f8.4)') &
8098  'q_searchgrid: compound scale factor :',q_scale
8099  end if
8100 !
8101 ! Read BQF for nearest valid water depth
8102 !
8103  call q_ctrgrid(2,igrid)
8104  if(iq_prt>=2) then
8105  write(luq_prt,'(a,f12.2)') &
8106  'q_searchgrid: q_ctrgrid called with depth:',q_depth
8107  write(luq_prt,'(a,i4)') &
8108  'q_searchgrid: igrid of nearest grid operation:',igrid
8109  end if
8110 !
8111  9999 continue
8112 !
8113 ! restore water depth
8114 !
8115  q_depth = s_depth
8116  write(*,*) 'q_searchgrid q_depth on exit:',q_depth
8117 !
8118  call q_stack('-q_searchgrid')
8119 !
8120  return
m_genarr::depth
real, dimension(:), allocatable, save depth
Definition: swmod2.f90:768
for
subroutine for(IUNIT, DDNAME, SF, IOSTAT)
Definition: ocpmix.f90:835
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_setconfig()

subroutine m_xnldata::q_setconfig ( integer, intent(in)  iquad)

Definition at line 7548 of file swmod3.f90.

7548 !------------------------------------------------------------------------------
7549 !
7550 ! +-------+ ALKYON Hydraulic Consultancy & Research
7551 ! | | Gerbrant van Vledder
7552 ! | +---+
7553 ! | | +---+ Last update: 7 May 2004
7554 ! +---+ | | Release: 5.04
7555 ! +---+
7556 !
7557 !
7558 ! SWAN (Simulating WAves Nearshore); a third generation wave model
7559 ! Copyright (C) 2004-2005 Delft University of Technology
7560 !
7561 ! This program is free software; you can redistribute it and/or
7562 ! modify it under the terms of the GNU General Public License as
7563 ! published by the Free Software Foundation; either version 2 of
7564 ! the License, or (at your option) any later version.
7565 !
7566 ! This program is distributed in the hope that it will be useful,
7567 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
7568 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
7569 ! GNU General Public License for more details.
7570 !
7571 ! A copy of the GNU General Public License is available at
7572 ! http://www.gnu.org/copyleft/gpl.html#SEC3
7573 ! or by writing to the Free Software Foundation, Inc.,
7574 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
7575 !
7576 !
7577 ! do not use m_xnldata
7578  use m_fileio
7579  use serv_xnl4v5
7580 !--------------------------------------------------------------------------------
7581 !
7582  implicit none
7583 
7584 !
7585 ! 0. Update history
7586 !
7587 ! 20/07/1999 Initial version
7588 ! 11/10/1999 Option iq_geom added, consistency checks added
7589 ! 15/10/1999 Option iq_trf added, keyword TRANSF
7590 ! 02/11/1999 Close(LUQCFG) added, implicit none added
7591 ! 08/12/1999 Option IQ_MOD added
7592 ! 24/12/1999 Extra output when *.cfg does not exist, and IQ_PRT=1
7593 ! 08/02/2000 Error message included for IQUAD
7594 ! 12/05/2002 Triplet settings added
7595 ! 08/08/2002 Upgrade to release 4
7596 ! 19/08/2002 Inclusion of various test option and interpolation
7597 ! 22/08/2002 Switch to compact data included
7598 ! 09/09/2002 Parameter q_dstep added
7599 ! 11/09/2002 Parameter qf_frac added
7600 ! 26/05/2003 Parameter iq_lump added
7601 ! 04/06/2003 Parameter IQ_INT renamed IQ_INTEG
7602 ! Switch IQ_GAULEG added
7603 ! 11/06/2003 name changed from Q_SETCFG to Q_SETCONFIG
7604 ! Parameter IQ_SPACE removed
7605 ! 13/06/2003 Set test output, from XNL_INIT
7606 ! 16/06/2003 Switch IQ_SYM added
7607 ! 09/09/2003 Variable ID_FACMAX added
7608 ! 30/12/2003 Parameters IQ_TAIL and FF_TAIL added
7609 ! 07/05/2004 Switch IQ_DSCALE configurbale via CFG file
7610 ! Parameters FQMAX & FQMIN not configurable via CFG
7611 !
7612 ! 1. Purpose:
7613 !
7614 ! Set settings for computing the nonlinear interactions
7615 ! set optimal basic settings
7616 ! Set some settings based on the value of IQUAD
7617 !
7618 ! 2. Method
7619 !
7620 ! Based on the value of IQUAD a number of settings are preset
7621 ! In the case the file [qbase].CFG exists, this file
7622 ! is analyzed and possibly some settings are reset
7623 !
7624 ! 3. Parameter list:
7625 !
7626 !Type, I/O Name Description
7627 !--------------------------------------------------------------------------
7628  integer, intent(in) :: iquad ! Indicator for a specific choice of
7629 ! settings for computing the nonlinear
7630 ! interactions
7631 ! 4. Error messages
7632 !
7633 ! 5. Called by:
7634 !
7635 ! XNL_INIT
7636 !
7637 ! 6. Subroutines used
7638 !
7639 ! 7. Remarks
7640 !
7641 ! IF no valid value for iquad is given, a default choice is
7642 ! specified
7643 !
7644 ! The various options of the setting are specified in the general quads module
7645 !
7646 ! 8. Structure
7647 !
7648 ! 9. Switches
7649 !
7650 ! /S Enable subroutine tracing
7651 !
7652 ! 10. Source code
7653 !--------------------------------------------------------------------------------
7654 ! Local variables
7655 !
7656  integer iend ! indicator for end of file
7657  integer iuerr ! error status of file io
7658  character(len=10) cpar ! character parameter
7659  real rpar ! real parameter
7660 !--------------------------------------------------------------------------------
7661 !
7662  call q_stack('+q_setconfig')
7663 !--------------------------------------------------------------------------------
7664 ! default settings, which always work
7665 !--------------------------------------------------------------------------------
7666  nlocus0 = 30 ! Preferred number of points along locus
7667  id_facmax = 2 ! Factor for depth search in Q_SEARCHGRID
7668  iq_filt = 1 ! switch filtering on
7669  iq_gauleg = 0 ! No Gauss-Legendre interpolation
7670  iq_locus = 2 ! polar method, constant step with adaptive stepping
7671  iq_make = 1 ! make grid at each new run
7672  iq_mod = 1 ! Modify spacing to equidistant spacing of points along locus
7673  iq_compact = 1 ! Do not (yet) compact data along locus
7674  iq_interp = 1 ! bi-linear interpolation
7675  iq_lump = 0 ! no lumping of coefficient along locus
7676  iq_search = 0 ! No search is carried out for nearest quad grid
7677  iq_sym = 1 ! Activate symmetry reduction
7678  iq_tail = 1 ! Activate parametric tail for transfer rate and diagonal term
7679 !--------------------------------------------------------------------------------
7680 ! set settings for special purposes
7681 !--------------------------------------------------------------------------------
7682  iq_xdia = 0 ! Disable output to DIA configuration file
7683 !-------------------------------------------------------------------------------
7684 ! set filtering values for retricting integration space
7685 !-------------------------------------------------------------------------------
7686  qf_krat = 2.5 ! maximum ratio between wave numbers k1 and k3
7687  qf_dmax = 75.0 ! difference in degrees between k1 and k3
7688  qf_frac = 0.1 ! fraction of maximum energy density
7689 !
7690  q_sector = 120. ! set size of half-plane direction sector (120)
7691 !-------------------------------------------------------------------------------
7692 ! setting for parametric tail
7693 !--------------------------------------------------------------------------------
7694  ff_tail = 0.75 ! parametric tail starts at 0.75 of maximum frequency
7695 !------------------------------------------------------------------------------
7696 !
7697 ! Set specific parameter depending on IQUAD
7698 !
7699 !------------------------------------------------------------------------------
7700 ! deep water test version
7701 !
7702  if(iquad==1) then
7703  iq_geom = 0 ! apply geometric scaling (Geometric scaling is disabled)
7704  iq_dscale = 0 ! no depth scaling
7705  iq_disp = 1 ! deep water
7706  iq_cple = 1 ! Webb's coupling coefficient
7707 !
7708 ! 'deep' water computation and HH/WAM depth scaling
7709 !
7710  elseif(iquad==2) then
7711  iq_geom = 0 ! apply geometric scaling
7712  iq_dscale = 1 ! put depth scaling on
7713  iq_disp = 1 ! deep water
7714  iq_cple = 1 ! Webb's coupling coefficient
7715 !
7716 ! full finite depth computation of interactions
7717 !
7718  elseif(iquad==3) then
7719  iq_dscale = 0 ! no depth scaling
7720  iq_disp = 2 ! finite depth dispersion relation
7721  iq_geom = 0 ! no geometric scaling
7722  iq_cple = 2 ! finite depth coupling coefficient of H&H
7723  else
7724  if(iq_screen>0) write(iscreen,'(a,i4)') &
7725  'q_setconfig: iquad=',iquad
7726  call q_error('e','iquad', &
7727  'no valid value of iquad has been given, default settings')
7728  write(luq_err,'(a,i4)') 'q_setconfig: Value of iquad:',iquad
7729  goto 9999
7730  end if
7731 !-------------------------------------------------------------------------------------------------
7732 ! Optional test output
7733 !--------------------------------------------------------------------------------------------
7734  iq_integ = 0 ! No test output of actual integration
7735  iq_trf = 0 ! No test output of transformed loci
7736  iq_t13 = 0 ! No test output of basic integration T13
7737 !
7738 ! set indices for test output of transformation and integration
7739 !
7740  mk1a = 34
7741  mk1b = 35
7742  mk3a = 34
7743  mk3b = 35
7744 !
7745 !----------------------------------------------------------------------------------
7746 ! check if the configuration exists,
7747 ! and if so, override the settings
7748 !----------------------------------------------------------------------------------
7749 !
7750  tempfile = trim(qbase)//'.cfg'
7751  call z_fileio(tempfile,'of',iufind,luq_cfg,iuerr)
7752  if(luq_cfg > 0) then
7753  if(iq_log >= 1) then
7754  write(luq_log,*)
7755  write(luq_log,'(a)') 'q_setconfig: configuration file '// &
7756  trim(qbase)//'.cfg has been found'
7757  write(luq_log,'(a,i4)') 'q_setconfig: '//trim(qbase)// &
7758  '.cfg connected to :',luq_cfg
7759  end if
7760 !
7761  iend = 0
7762 !
7763  do while (iend==0)
7764  read(luq_cfg,*,iostat=iend) cpar,rpar
7765 !
7766  call z_upper(cpar) ! Convert string to upper case
7767 !
7768  if(iend==0) then ! process the command
7769 !
7770 ! if(trim(cpar)=='depth') q_depth = rpar
7771  if(trim(cpar)=='dstep') q_dstep = rpar
7772  if(trim(cpar)=='f_dmax') qf_dmax = rpar
7773  if(trim(cpar)=='f_krat') qf_krat = rpar
7774  if(trim(cpar)=='ff_tail') ff_tail = rpar
7775  if(trim(cpar)=='f_frac') qf_frac = rpar
7776 ! if(trim(cpar)=='fmin') fqmin = rpar
7777 ! if(trim(cpar)=='fmax') fqmax = rpar
7778  if(trim(cpar)=='nlocus') nlocus0 = int(rpar)
7779  if(trim(cpar)=='sector') q_sector = rpar
7780 !
7781  if(trim(cpar)=='geom') then
7782  iq_geom = int(rpar)
7783  if(iq_geom==1) then
7784  iq_geom=0
7785  if(iq_screen>0) write(iscreen,'(a)') &
7786  'q_setconfig: geometric scaling disabled'
7787  if(iq_prt>=1) write(luq_prt,'(a)') &
7788  'q_setconfig: geometric scaling disabled'
7789  end if
7790  end if
7791  if(trim(cpar)=='compact') iq_compact = int(rpar)
7792  if(trim(cpar)=='coupling') iq_cple = int(rpar)
7793  if(trim(cpar)=='disper') iq_disp = int(rpar)
7794  if(trim(cpar)=='dscale') iq_dscale = int(rpar)
7795  if(trim(cpar)=='filt') iq_filt = int(rpar)
7796  if(trim(cpar)=='gauleg') iq_gauleg = int(rpar)
7797  if(trim(cpar)=='grid') iq_grid = int(rpar)
7798  if(trim(cpar)=='integ') iq_integ = int(rpar)
7799  if(trim(cpar)=='interp') iq_interp = int(rpar)
7800  if(trim(cpar)=='locus') iq_locus = int(rpar)
7801  if(trim(cpar)=='logging') iq_log = int(rpar)
7802  if(trim(cpar)=='lumping') iq_lump = int(rpar)
7803  if(trim(cpar)=='make') iq_make = int(rpar)
7804  if(trim(cpar)=='modify') iq_mod = int(rpar)
7805  if(trim(cpar)=='print') iq_prt = int(rpar)
7806  if(trim(cpar)=='screen') iq_screen = int(rpar)
7807  if(trim(cpar)=='search') iq_search = int(rpar)
7808  if(trim(cpar)=='sym') iq_sym = int(rpar)
7809  if(trim(cpar)=='t13') iq_t13 = int(rpar)
7810  if(trim(cpar)=='tail') iq_tail = int(rpar)
7811  if(trim(cpar)=='test') iq_test = int(rpar)
7812  if(trim(cpar)=='trace') iq_trace = int(rpar)
7813  if(trim(cpar)=='transf') iq_trf = int(rpar)
7814  if(trim(cpar)=='xdia') iq_xdia = int(rpar)
7815  end if
7816  end do
7817 !
7818  close(luq_cfg)
7819 !
7820  if(iq_log >= 1) write(luq_log,'(a,i4)') &
7821  'q_setconfig: '//trim(qbase)//'.cfg disconnected from :', &
7822  luq_cfg
7823 !
7824  else
7825 ! iq_prt = 1
7826  if(iq_log >= 1) then
7827  write(luq_log,*)
7828  write(luq_log,'(a)') 'q_setconfig: configuration file '// &
7829  trim(qbase)//'.cfg has not been found'
7830  end if
7831  end if
7832 !
7833  9999 continue
7834 !
7835  call q_stack('-q_setconfig')
7836 !
7837  return
swcomm3::iquad
integer iquad
Definition: swmod1.f90:2127
ocpcomm4::screen
integer screen
Definition: swmod1.f90:517
m_genarr::depth
real, dimension(:), allocatable, save depth
Definition: swmod2.f90:768
m_fileio
Definition: swmod3.f90:74
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_setversion()

subroutine m_xnldata::q_setversion ( )

Definition at line 8124 of file swmod3.f90.

8124 !-----------------------------------------------------------------
8125 ! do not use m_xnldata
8126 !-----------------------------------------------------------------
8127 ! This subroutine has automatically been written by MODULE5
8128 ! Author: Gerbrant van Vledder
8129 !
8130  q_version = &
8131  'GurboQuad Version: 5.03 Build: 120 Date: 2004/05/07 [ST]'
8132 !
8133 ! Source code options:ST
8134 !
8135  return
Here is the caller graph for this function:

◆ q_stack()

subroutine m_xnldata::q_stack ( character(len=*), intent(in)  mod_name)

Definition at line 8139 of file swmod3.f90.

8139 !------------------------------------------------------------------------------
8140 !
8141 ! +-------+ ALKYON Hydraulic Consultancy & Research
8142 ! | | Gerbrant van Vledder
8143 ! | +---+
8144 ! | | +---+ Last update: 11 June 2003
8145 ! +---+ | | Release: 5
8146 ! +---+
8147 !
8148 !
8149 ! SWAN (Simulating WAves Nearshore); a third generation wave model
8150 ! Copyright (C) 2004-2005 Delft University of Technology
8151 !
8152 ! This program is free software; you can redistribute it and/or
8153 ! modify it under the terms of the GNU General Public License as
8154 ! published by the Free Software Foundation; either version 2 of
8155 ! the License, or (at your option) any later version.
8156 !
8157 ! This program is distributed in the hope that it will be useful,
8158 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
8159 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
8160 ! GNU General Public License for more details.
8161 !
8162 ! A copy of the GNU General Public License is available at
8163 ! http://www.gnu.org/copyleft/gpl.html#SEC3
8164 ! or by writing to the Free Software Foundation, Inc.,
8165 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
8166 !
8167 !
8168 ! do not use m_xnldata
8169  use m_fileio
8170  implicit none
8171 !
8172 !
8173 ! 0. Update history
8174 !
8175 ! 20/07/1999 Initial version
8176 ! 13/10/1999 Error handling improved
8177 ! 08/08/2002 Upgrade to release 4
8178 ! 11/06/2003 Extra check on output to print or test file
8179 !
8180 ! 1. Purpose:
8181 !
8182 ! Add or remove mod_name name from module stack
8183 !
8184 ! 2. Method
8185 !
8186 ! mod_name must be preceeded by a '+' , '-'
8187 ! The module name is pushed to the stack when preceeded by '+'
8188 ! and removed if mname starts with '-'.
8189 ! In case an error is active,the module name is not removed
8190 ! from the stack if mname starts with a '-'.The module is
8191 ! always removed from the stack if mname starts with '!'.
8192 !
8193 !
8194 ! 3. Parameter list:
8195 !
8196 !Type I/O name description
8197 !-------------------------------------------------------
8198  character(len=*), intent(in) :: mod_name ! module name
8199 !
8200 ! 4. Error messages
8201 !
8202 ! 5. Called by
8203 !
8204 ! All q_** routines
8205 !
8206 ! 6. Subroutines used
8207 !
8208 ! q_error
8209 !
8210 ! 7. Remarks
8211 !
8212 ! 8. Structure
8213 !
8214 ! 9. Switches
8215 !
8216 ! 10. Source code
8217 !-------------------------------------------------------------------------------------
8218  character(len=1) mod_task ! task to do
8219  integer mod_len ! length of mod_name
8220 !
8221 !!\A
8222  if(iq_trace > 0) then
8223  if(iq_prt>0) write(luq_prt,'(2a)') 'TRACE -> ',trim(mod_name)
8224  if(iq_test>0) write(luq_tst,'(2a)') 'TRACE -> ',trim(mod_name)
8225  if(iq_screen >= 2) write(iscreen,'(2a)') 'TRACE -> ',trim(mod_name)
8226  end if
8227 !
8228 ! split MOD_NAME in two parts
8229 !
8230 ! MOD_TASK '+','-'
8231 !
8232  mod_len = len_trim(mod_name)
8233  mod_task = mod_name(1:1)
8234  sub_name = mod_name(2:mod_len)
8235 !
8236  if(mod_task(1:1) == '+') then
8237  iq_stack = iq_stack + 1
8238 !
8239  if(iq_stack > mq_stack) then
8240  call q_error('e','STACKMAX',' ')
8241  goto 9999
8242  else
8243  cstack(iq_stack) = mod_name(2:mod_len)
8244  end if
8245 !------------------------------------------------------------------------
8246 ! remove name from stack
8247 !------------------------------------------------------------------------
8248  elseif(mod_task(1:1) == '-') then
8249 !
8250  if(mod_name(2:mod_len) == cstack(iq_stack)) then
8251  iq_stack = iq_stack - 1
8252  else
8253  write(luq_err,'(a)') 'Module name:',mod_name
8254  call q_error('e','STACKNAME',' ')
8255  goto 9999
8256  end if
8257  else
8258  call q_error('e','STACKCALL',' ')
8259  goto 9999
8260  end if
8261 !
8262 !!\Z
8263 !
8264  9999 continue
8265 !
8266  return
m_fileio
Definition: swmod3.f90:74
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_summary()

subroutine m_xnldata::q_summary ( )

Definition at line 8270 of file swmod3.f90.

8270 !------------------------------------------------------------------------------
8271 !
8272 ! +-------+ ALKYON Hydraulic Consultancy & Research
8273 ! | | Gerbrant van Vledder
8274 ! | +---+
8275 ! | | +---+ Last update: 30 December 2003
8276 ! +---+ | | Release: 5.04
8277 ! +---+
8278 !
8279 !
8280 ! SWAN (Simulating WAves Nearshore); a third generation wave model
8281 ! Copyright (C) 2004-2005 Delft University of Technology
8282 !
8283 ! This program is free software; you can redistribute it and/or
8284 ! modify it under the terms of the GNU General Public License as
8285 ! published by the Free Software Foundation; either version 2 of
8286 ! the License, or (at your option) any later version.
8287 !
8288 ! This program is distributed in the hope that it will be useful,
8289 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
8290 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
8291 ! GNU General Public License for more details.
8292 !
8293 ! A copy of the GNU General Public License is available at
8294 ! http://www.gnu.org/copyleft/gpl.html#SEC3
8295 ! or by writing to the Free Software Foundation, Inc.,
8296 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
8297 !
8298 !
8299 ! do not use m_xnldata
8300  use m_fileio
8301  use serv_xnl4v5
8302 !--------------------------------------------------------------------------------
8303 !
8304  implicit none
8305 
8306 !
8307 ! 0. Update history
8308 !
8309 ! 11/06/2003 Initial version
8310 ! Parameter iq_space removed
8311 ! 16/06/2003 Switch IQ_SYM added
8312 ! 30/12/2003 Parameters IQ_TAIL and FF_TAIl added
8313 !
8314 ! 1. Purpose:
8315 !
8316 ! Write summary of GurboQuad settings to print file
8317 !
8318 ! 2. Method
8319 !
8320 ! Based on the value of IQUAD a number of settings are preset
8321 ! In the case the file [qbase].CFG exists, this file
8322 ! is analyzed and possibly some settings are reset
8323 !
8324 ! 3. Parameter list:
8325 !
8326 !Type, I/O Name Description
8327 !--------------------------------------------------------------------------
8328 !
8329 ! 4. Error messages
8330 !
8331 ! 5. Called by:
8332 !
8333 ! XNL_INIT
8334 !
8335 ! 6. Subroutines used
8336 !
8337 ! 7. Remarks
8338 !
8339 ! 8. Structure
8340 !
8341 ! 9. Switches
8342 !
8343 ! /S Enable subroutine tracing
8344 !
8345 ! 10. Source code
8346 !--------------------------------------------------------------------------------
8347 ! Local variables
8348 !
8349 !--------------------------------------------------------------------------------
8350 !
8351  call q_stack('+q_summary')
8352 !--------------------------------------------------------------------------------
8353 !-----------------------------------------------------------------------------------------------------
8354 ! write summary of settings for computation of quadruplets
8355 ! to print file
8356 !
8357  if (iq_prt > 0) then
8358  write(luq_prt,*)
8359  write(luq_prt,'(a)') 'Summary of settings for QUAD computation'
8360  write(luq_prt,'(a)') &
8361  '------------------------------------------------'
8362  write(luq_prt,'(a,i4)') 'Number of wave numbers :', &
8363  nkq
8364  write(luq_prt,'(a,i4)') 'Number of directions :', &
8365  naq
8366  write(luq_prt,'(a,f10.5)') 'Minimum frequency (Hz) :', &
8367  fqmin
8368  write(luq_prt,'(a,f10.5)') 'Maximum frequency (Hz) :', &
8369  fqmax
8370  write(luq_prt,'(a,f10.2)') 'Water depth (m) :', &
8371  q_depth
8372  write(luq_prt,'(a,i4)') 'Preferred number of locus points:', &
8373  nlocus0
8374 !
8375  write(luq_prt,*)
8376  write(luq_prt,'(a,f10.3)') 'Gravitational acceleration:',q_grav
8377 ! write(luq_prt,'(a,f10.3)') 'Density of water :',q_rhow
8378 ! write(luq_prt,'(a,f10.2)') 'Power spectral tail E(f) :',qf_tail
8379 ! write(luq_prt,'(a,f10.2)') 'Power spectral tail N(k) :',qk_tail
8380 !
8381  write(luq_prt,*)
8382  if(iq_type==1) write(luq_prt,'(a)') &
8383  'IQUAD = 1: Deep water'
8384  if(iq_type==2) write(luq_prt,'(a)') &
8385  'IQUAD = 2: Deep water & WAM depth scaling'
8386  if(iq_type==3) write(luq_prt,'(a)') &
8387  'IQUAD = 3: Direct finite depth calculation'
8388  write(luq_prt,*)
8389 !
8390  write(luq_prt,'(a,f5.2)') 'Step size in m of BQF coding:', &
8391  q_dstep
8392  write(luq_prt,*)
8393 !
8394  if(iq_grid==1) write(luq_prt,'(a)') 'Symmetric sector grid'
8395  if(iq_grid==2) write(luq_prt,'(a)') 'Non-symmetric sector grid'
8396  if(iq_grid==3) write(luq_prt,'(a)') &
8397  'Non-symmetric full circle grid'
8398 !
8399  write(luq_prt,*)
8400  if(iq_compact==0) write(luq_prt,'(a)') &
8401  'No compacting of data along locus'
8402  if(iq_compact==1) write(luq_prt,'(a)') &
8403  'Compact data along locus by eliminating zero contributions'
8404 !
8405  write(luq_prt,*)
8406  if(iq_dscale==0) write(luq_prt,'(a)') 'No WAM depth scaling'
8407  if(iq_dscale==1) write(luq_prt,'(a)') &
8408  'WAM depth scaling of transfer'
8409 !
8410  write(luq_prt,*)
8411  if(iq_screen==0) write(luq_prt,'(a)') 'No output to screen'
8412  if(iq_screen>=1) write(luq_prt,'(a)') &
8413  'Intermediate output to screen'
8414  if(iq_screen>=2) write(luq_prt,'(a)') &
8415  'Intermediate output to screen + subroutine tracing'
8416  write(luq_prt,*)
8417 !
8418  write(luq_prt,*)
8419  if(iq_search==0) write(luq_prt,'(a)') &
8420  'No search is carried out for nearest QUAD grid'
8421  if(iq_search==1) write(luq_prt,'(a)') &
8422  'A search is carried out for nearest QUAD grid'
8423 !
8424  write(luq_prt,*)
8425  if(iq_gauleg==0) write(luq_prt,'(a)') 'Rectangular integration'
8426  if(iq_gauleg>0) write(luq_prt,'(a,i4)') &
8427  'Gauss-Legendre integration with N=',iq_gauleg
8428 !
8429  write(luq_prt,*)
8430  if(iq_cple==1) write(luq_prt,'(a)') &
8431  'Deep water coupling coefficient of Webb'
8432  if(iq_cple==2) write(luq_prt,'(a)') &
8433  'Finite depth coupling coefficient of H&H'
8434  if(iq_cple==3) write(luq_prt,'(a)') &
8435  'Finite depth coupling coefficient of Gorman'
8436  if(iq_cple==4) write(luq_prt,'(a)') &
8437  'Deep water coefficient of Zakharov'
8438  if(iq_cple==5) write(luq_prt,'(a)') &
8439  'Finite depth coefficient of Zakharov'
8440 !
8441  write(luq_prt,*)
8442  if(iq_disp==1) write(luq_prt,'(a)') &
8443  'Deep water dispersion relation'
8444  if(iq_disp==2) write(luq_prt,'(a)') &
8445  'Finite depth linear dispersion relation'
8446  if(iq_disp==3) write(luq_prt,'(a)') &
8447  'Non linear finite depth dispersion'
8448 !
8449  write(luq_prt,*)
8450  if(iq_filt==0) write(luq_prt,'(a)') &
8451  'Filtering of quadruplets off'
8452  if(iq_filt==1) then
8453  write(luq_prt,'(a)') 'Filtering of quadruplets on'
8454  write(luq_prt,*)
8455  write(luq_prt,'(a,f8.2)') &
8456  'Maximum ratio of k1 and k3 :',qf_krat
8457  write(luq_prt,'(a,f8.2)') &
8458  'Maximum directional difference :',qf_dmax
8459  write(luq_prt,'(a,e12.3)') &
8460  'Fraction of maximum energy density:',qf_frac
8461  end if
8462 !
8463 ! write(luq_prt,*)
8464 ! if(iq_geom==0) write(luq_prt,'(a)') 'Only directional scaling of loci'
8465 ! if(iq_geom==1) write(luq_prt,'(a)') 'Geometric scaling of loci using R-T method'
8466 !
8467  write(luq_prt,*)
8468  if(iq_locus==1) write(luq_prt,'(a)') &
8469  'Compute locus with polar method with fixed k-step'
8470  if(iq_locus==2) write(luq_prt,'(a)') &
8471  'Compute locus with polar method using adaptive k-step'
8472  if(iq_locus==3) write(luq_prt,'(a)') &
8473  'Compute locus with polar method using geometric k-step'
8474 !
8475  write(luq_prt,*)
8476  if(iq_sym==0) write(luq_prt,'(a)') &
8477  'Handling of symmetries disabled'
8478  if(iq_sym==1) write(luq_prt,'(a)') &
8479  'Handling of symmetries enabled'
8480 !
8481  write(luq_prt,*)
8482  if(iq_make==1) write(luq_prt,'(a)') &
8483  'Make quadruplet grid when necessary'
8484  if(iq_make==2) write(luq_prt,'(a)') &
8485  'Always make quadruplet grid'
8486  if(iq_make==3) write(luq_prt,'(a)') &
8487  'Stop after generation of quadruplet grid'
8488 !
8489  write(luq_prt,*)
8490  if(iq_interp==1) write(luq_prt,'(a)') &
8491  'Apply bi-linear interpotion to retrieve action density'
8492  if(iq_interp==2) write(luq_prt,'(a)') &
8493  'Take nearest bin to retrieve action density'
8494 !
8495  write(luq_prt,*)
8496  if(iq_lump==0) write(luq_prt,'(a)') &
8497  'Lumping of coefficients along locus disabled'
8498  if(iq_lump>0) write(luq_prt,'(a)') &
8499  'Lumping of coefficients along locus enabled'
8500 !
8501  write(luq_prt,*)
8502  if(iq_mod==0) write(luq_prt,'(a)') &
8503  '?X? Spacing of point along locus as initially computed'
8504  if(iq_mod==1) write(luq_prt,'(a)') &
8505  'Equidistant spacing of points along locus'
8506 !
8507  write(luq_prt,*)
8508  if(iq_tail==0) write(luq_prt,'(a)') &
8509  'No parametric tail is added'
8510  if(iq_tail==1) write(luq_prt,'(a,f8.2,a)') &
8511  'Parametric tail is added from ', &
8512  ff_tail,' times maximum frequency'
8513 !
8514  write(luq_prt,*)
8515  if(iq_trace==0) write(luq_prt,'(a)') &
8516  'Subroutine tracing disabled'
8517  if(iq_trace>0) write(luq_prt,'(a)') &
8518  'Subroutine tracing enabled'
8519 !
8520 !
8521  write(luq_prt,*)
8522  write(luq_prt,'(a,i4)') 'IQ_INTEG:',iq_integ
8523  if(iq_integ==0) write(luq_prt,'(a)') &
8524  'No test output of integration'
8525  if(iq_integ==1) write(luq_prt,'(a)') &
8526  'Summary output of integration per locus'
8527  if(iq_integ==2) write(luq_prt,'(a)') &
8528  'Extended output of integration along locus'
8529  if(iq_integ==3) write(luq_prt,'(a)') 'Line function along locus'
8530 !
8531  write(luq_prt,*)
8532  if(iq_t13==0) write(luq_prt,'(a)') &
8533  'No test output of T13 integration'
8534  if(iq_t13==1) write(luq_prt,'(a)') &
8535  'Summary output of T13 integration'
8536 !
8537  write(luq_prt,*)
8538 !
8539 ! if(iq_disp==1 .and. iq_start==2) then
8540 ! write(luqprt,'(a)') 'Start point for locus according to Resio&Tracy'
8541 ! else
8542 ! write(luqprt,'(a)') 'Start point for locus equal to k3'
8543 ! end if
8544  write(luq_prt,*)
8545  write(luq_prt,'(a,i4)') 'Level of printed output :', &
8546  iq_prt
8547  write(luq_prt,'(a,i4)') 'Level of logging output :', &
8548  iq_log
8549  write(luq_prt,'(a,i4)') 'Level of test output :', &
8550  iq_test
8551  write(luq_prt,'(a,i4)') 'Level of trace output :', &
8552  iq_trace
8553  write(luq_prt,'(a,i4)') 'Level of transformation output :', &
8554  iq_trf
8555  write(luq_prt,'(a)') &
8556  '----------------------------------------------'
8557  end if
8558 !
8559  9999 continue
8560 !
8561  call q_stack('-q_summary')
8562 !
8563  return
m_fileio
Definition: swmod3.f90:74
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_symmetry()

subroutine m_xnldata::q_symmetry ( real, intent(in)  k1x,
real, intent(in)  k1y,
real, intent(in)  k3x,
real, intent(in)  k3y,
real, dimension(nloc), intent(in)  k4x,
real, dimension(nloc), intent(in)  k4y,
real, dimension(nloc), intent(out)  symfac,
integer, intent(in)  nloc 
)

Definition at line 8567 of file swmod3.f90.

8567 !------------------------------------------------------------------------------
8568 !
8569 ! +-------+ ALKYON Hydraulic Consultancy & Research
8570 ! | | Gerbrant van Vledder
8571 ! | +---+
8572 ! | | +---+ Last update: 16 June 2003
8573 ! +---+ | | Release: 5.0
8574 ! +---+
8575 !
8576 !
8577 ! SWAN (Simulating WAves Nearshore); a third generation wave model
8578 ! Copyright (C) 2004-2005 Delft University of Technology
8579 !
8580 ! This program is free software; you can redistribute it and/or
8581 ! modify it under the terms of the GNU General Public License as
8582 ! published by the Free Software Foundation; either version 2 of
8583 ! the License, or (at your option) any later version.
8584 !
8585 ! This program is distributed in the hope that it will be useful,
8586 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
8587 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
8588 ! GNU General Public License for more details.
8589 !
8590 ! A copy of the GNU General Public License is available at
8591 ! http://www.gnu.org/copyleft/gpl.html#SEC3
8592 ! or by writing to the Free Software Foundation, Inc.,
8593 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
8594 !
8595 !
8596  implicit none
8597 !--------------------------------------------------------------------------------
8598 ! 0. Update history
8599 !
8600 ! 10/06/2003 Initial version
8601 ! 16/06/2003 Switch iq_sym added
8602 !
8603 ! 1. Purpose:
8604 !
8605 ! Compute symmetry factor to reduce integration
8606 !
8607 ! 2. Method
8608 !
8609 ! Compute distance between k1 and k3, and between k4 and k1
8610 !
8611 ! 3. Parameter list:
8612 !
8613 ! Type i/o Name Description
8614 !----------------------------------------------------------------------------------
8615  integer, intent(in) :: nloc ! number of points in array with wave number
8616  real, intent(in) :: k1x ! x-component of wave number k1
8617  real, intent(in) :: k1y ! y-component of wave number k1
8618  real, intent(in) :: k3x ! x-component of wave number k3
8619  real, intent(in) :: k3y ! y-component of wave number k3
8620  real, intent(in) :: k4x(nloc) ! x-components of wave number k4
8621  real, intent(in) :: k4y(nloc) ! y-components of wave number k4
8622  real, intent(out) :: symfac(nloc) ! symmetry factor
8623 !----------------------------------------------------------------------------------
8624 ! 4. Error messages
8625 !
8626 ! 5. Called by:
8627 !
8628 ! Q_MODIFY
8629 !
8630 ! 6. Subroutines used
8631 !
8632 ! Q_STACK
8633 !
8634 ! 7. Remarks
8635 !
8636 ! 8. structure
8637 !
8638 ! 9. Switches
8639 !
8640 ! 10. Source code
8641 !------------------------------------------------------------------------------
8642  integer iloc ! counter
8643  real dk13 ! distance between k1 and k3
8644  real dk14 ! distance between k1 and k4
8645 !------------------------------------------------------------------------------
8646 !
8647  call q_stack('+q_symmetry')
8648 !
8649 !
8650 ! evaluate criterion |k3-k1| < |k4-k1|
8651 ! if true then symfac=1
8652 !
8653  symfac = 1.
8654  if(iq_sym==1) then
8655  dk13 = (k1x-k3x)**2 + (k1y-k3y)**2
8656  do iloc=1,nloc
8657  dk14 = (k1x-k4x(iloc))**2 + (k1y-k4y(iloc))**2
8658  if (dk13 >= dk14) symfac(iloc) = 0.
8659  end do
8660  end if
8661 !
8662  call q_stack('-q_symmetry')
8663 !
8664  return
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_t13v4()

subroutine m_xnldata::q_t13v4 ( integer, intent(in)  ik1,
integer, intent(in)  ia1,
integer, intent(in)  ik3,
integer, intent(in)  ia3,
real, intent(out)  t13,
real, intent(out)  diagk1,
real, intent(out)  diagk3 
)

Definition at line 8668 of file swmod3.f90.

8668 !------------------------------------------------------------------------------
8669 !
8670 ! +-------+ ALKYON Hydraulic Consultancy & Research
8671 ! | | Gerbrant van Vledder
8672 ! | +---+
8673 ! | | +---+ Last update: 27 April 2004
8674 ! +---+ | | Release: 5.04
8675 ! +---+
8676 !
8677 !
8678 ! SWAN (Simulating WAves Nearshore); a third generation wave model
8679 ! Copyright (C) 2004-2005 Delft University of Technology
8680 !
8681 ! This program is free software; you can redistribute it and/or
8682 ! modify it under the terms of the GNU General Public License as
8683 ! published by the Free Software Foundation; either version 2 of
8684 ! the License, or (at your option) any later version.
8685 !
8686 ! This program is distributed in the hope that it will be useful,
8687 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
8688 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
8689 ! GNU General Public License for more details.
8690 !
8691 ! A copy of the GNU General Public License is available at
8692 ! http://www.gnu.org/copyleft/gpl.html#SEC3
8693 ! or by writing to the Free Software Foundation, Inc.,
8694 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
8695 !
8696 !
8697 ! do not use m_xnldata
8698  use m_constants
8699  implicit none
8700 !
8701 ! 0. Update history
8702 !
8703 ! 25/02/1999 Initial version
8704 ! 14/04/1999 Extra check in GET_LOC if locus exists in internal database
8705 ! 12/10/1999 Error handling improved
8706 ! 15/01/2001 Interface extended with diagonal term
8707 ! 06/05/2002 Criterion f34_mod added to computational procedure
8708 ! 14/08/2002 Integration simplified
8709 ! 22/08/2002 Integration modified depending on actual number of non-zero points
8710 ! 26/09/2002 Boundary check for sector grid activated
8711 ! 15/04/2003 Bug fixed in handling of periodicity
8712 ! Nearest bin integration enabled, including diagonal term
8713 ! 25/04/2003 Output to triplet arrays for nearest bin
8714 ! 03/05/2003 Output of triplets for bi-linear interpolation enabled
8715 ! 04/06/2003 Parameter IQ_INT renamed IQ_INTEG
8716 ! 13/06/2003 Test of integration for case of nearest bin interpolation
8717 ! 25/06/2003 Bug fixed in computation of partial derivatives for contribution to
8718 ! diagonal term
8719 ! 27/08/2003 Short-cut when number of non-zero points on locus is ZERO
8720 ! 05/09/2003 Switches for test output in nearest bin approach modified
8721 ! 24/12/2003 Tail factors from BQF
8722 ! 27/04/2004 Double switches build in for /T & /R & /N
8723 !
8724 ! 1. Purpose:
8725 !
8726 ! Compute the function T13, defined as a line integral around a locus
8727 !
8728 ! 2. Method
8729 !
8730 ! See Tracy and Resio (1982) and Van Vledder (1999)
8731 !
8732 ! 3. Parameter list:
8733 !
8734 ! Type I/O Name Description
8735 !------------------------------------------------------------------------------
8736  integer, intent(in) :: ik1 ! Index of k-component of wave number k1
8737  integer, intent(in) :: ia1 ! Index of a-component of wave number k1
8738  integer, intent(in) :: ik3 ! Index of k-component of wave number k3
8739  integer, intent(in) :: ia3 ! Index of a-component of wave number k3
8740  real, intent(out) :: t13 ! Value of line integral over a specific locus
8741  real, intent(out) :: diagk1 ! Contribution to diagonal term of k1
8742  real, intent(out) :: diagk3 ! Contribution to diagonal term of k3
8743 !
8744 ! 4. Error messages
8745 !
8746 ! 5. Called by:
8747 !
8748 ! Q_XNL4V4
8749 !
8750 ! 6. Subroutines used
8751 !
8752 ! Q_GETLOCUS
8753 ! Q_PUT_BTRIPLETS
8754 ! Q_PUT_NTRIPLETS
8755 !
8756 ! 7. Remarks
8757 !
8758 ! The action density product term is given by:
8759 ! P = n1.n2.(n3+n4)-(n1+n2).n3.n4
8760 !
8761 ! This term is rewritten as:
8762 !
8763 ! P = n1.n2.n3 + n1.n2.n4 - n1.n3.n4 - n2.n3.n4
8764 ! = n1.n3.(n2-n4) + n2.n4.(n1-n3)
8765 
8766 !
8767 ! 8. Structure
8768 !
8769 ! 9. Switches
8770 !
8771 ! /S enable subroutine tracing
8772 ! /T enable test output
8773 ! /N enable interpolation using nearest point
8774 ! /R enable triplet output
8775 !
8776 ! 10. Source code:
8777 !------------------------------------------------------------------------------
8778 ! Local variables
8779 !
8780  integer iloc ! counter along locus
8781  integer ifnd ! indicator if correct locus is found
8782  integer ja2,ja2p ! direction indices for interpolation of k2
8783  integer jk2,jk2p ! wave number indices for interpolation of k2
8784  integer ja4,ja4p ! direction indices for interpolation of k4
8785  integer jk4,jk4p ! wave number indices for interpolation of k4
8786  integer ikq,iaq ! counters
8787 !
8788  real sumt13 ! sum along locus
8789  real qn1,qn2,qn3,qn4 ! action densities at wave numbers k1, k2, k3 and k4
8790  real nprod ! wave number product
8791  real t2,t4 ! tail factors for k2 and k4
8792  real qd1,qd3 ! contribution to diagonal term
8793  real rterm ! product term along locus
8794 !
8795  real qn13p ! product of N1 and N3
8796  real qn13d ! difference of N1 and N3
8797 !
8798  integer jq_int ! switch to activate test output
8799  real wk,wa ! weight for interpolation
8800  real vk2,va2 ! wave number and direction for k2
8801  real vk4,va4 ! wave number and direction for k4
8802 !
8803 !------------------------------------------------------------------------------
8804  call q_stack('+q_t13v4')
8805 !
8806  t13 = 0.
8807  diagk1 = 0.
8808  diagk3 = 0.
8809 !
8810  if(iq_test >=2) write(luq_tst,'(a,4i3)') &
8811  'Q_T13V4: ik1,ia1 ik3 ia3:',ik1,ia1,ik3,ia3
8812 !
8813  if(ik1==ik3 .and. ia1==ia3) goto 9999 ! skip routine if k1=k3
8814 !
8815 ! obtain information requested locus based on a information
8816 ! about a precomputed locus, as stored in the database file
8817 !
8818  call q_getlocus(ik1,ia1,ik3,ia3,ifnd)
8819  if(iq_err/=0) goto 9999
8820 !
8821  if(ifnd==0 .or. nlocusx==0) then
8822  t13 = 0.
8823  goto 9999
8824  end if
8825 !
8826 !---------------------------------------------------------------------------------------
8827  qn1 = nspec(ik1,ia1)
8828  qn3 = nspec(ik3,ia3)
8829 !
8830  qn13p = qn1*qn3 ! compute product
8831  qn13d = qn3-qn1 ! compute difference
8832 !
8833  sumt13 = 0
8834 !
8835 ! 3-----------4 ja2p w1 = (1-wk)*(1-wa)
8836 ! | . | w2 = wk*(1-wa)
8837 ! |. . + . . .| wa2 A w3 = (1-wk)*wa
8838 ! | . | | w4 = wk*wa
8839 ! | . | wa
8840 ! | . | |
8841 ! 1-----------2 ja2 V
8842 ! jk2 wk2 jk2p
8843 !
8844 ! <-wk->
8845 !
8846  jq_int = 0 ! temporary parameter
8847 
8848  if((ik1>=mk1a .and. ik1<=mk1b) .and. (ik3>=mk3a .and. ik3<=mk3b) &
8849  .and.iq_integ==2) jq_int=1
8850 
8851  if(jq_int ==1) then
8852  write(luq_int,'(a1,2i3.3,a1,2i3.3,a1)') '(',ik1,ia1,'-',ik3, &
8853  ia3,')'
8854  write(luq_int,'(4f10.4)') q_k(ik1),q_ad(ia1),q_k(ik3),q_ad(ia3)
8855  write(luq_int,'(4f10.4)') q_k(ik1)*cos(q_a(ia1)), &
8856  q_k(ik1)*sin(q_a(ia1)), &
8857  q_k(ik3)*cos(q_a(ia3)), &
8858  q_k(ik3)*sin(q_a(ia3))
8859  write(luq_int,'(2i4)') nlocusx,19
8860  end if
8861 !
8862  if(iq_interp==2) then
8863  do iloc=1,nlocusx
8864  jk2 = t_ik2(iloc)
8865  ja2 = mod(t_ia2(iloc)-1+naq,naq)+1
8866  jk4 = t_ik4(iloc)
8867  ja4 = mod(t_ia4(iloc)-1+naq,naq)+1
8868  qn2 = nspec(jk2,ja2)
8869  qn4 = nspec(jk4,ja4)
8870  nprod = qn13p*(qn4-qn2) + qn2*qn4*qn13d
8871  rterm = t_zz(iloc)
8872  t13 = t13 + nprod*rterm
8873 !
8874 ! add diagonal terms
8875 !
8876  qd1 = qn3*(qn4-qn2) + qn2*qn4*qn3
8877  qd3 = qn1*(qn4-qn2) - qn2*qn4*qn1
8878  diagk1 = diagk1 + qd1*rterm
8879  diagk3 = diagk3 + qd3*rterm
8880 !-----------------------------------------------------------------------------------
8881  end do
8882  goto 9999
8883  end if
8884 !---------------------------------------------------------------------------------------
8885 ! Main loop over the locus
8886 !
8887  do iloc=1,nlocusx
8888 !
8889  jk2 = t_ik2(iloc)
8890  jk2p = min(jk2+1,nkq)
8891  ja2 = mod(t_ia2(iloc)-1+naq,naq)+1
8892  ja2p = mod(t_ia2(iloc)+naq,naq)+1
8893 !
8894  t2 = t_tail2(iloc)
8895 !
8896 ! if(jk2==nkq .and. jk2p==nkq) then
8897 ! wk = t_w2k2(iloc) + t_w4k2(iloc)
8898 ! vk2 = q_k(t_ik2(iloc)) + wk*q_sk(t_ik2(iloc))
8899 ! t2 = (vk2/q_k(nkq))**(-4)
8900 ! end if
8901 !
8902 !! if(iq_geom==1) then
8903 !! jk2 = max(1,jk2)
8904 !! jk4 = max(1,jk4)
8905 !! t2 = max(1.,q_kfac**real(t_ik2(iloc)-nkq))
8906 !! t2 = t2**qk_tail
8907 !! t4 = max(1.,q_kfac**real(t_ik4(iloc)-nkq))
8908 !! t4 = t4**qk_tail
8909 !! end if
8910 !---------------------------------------------------------------------------------------
8911 ! check boundaries of sector grid
8912 !
8913  if(iq_grid < 3) then
8914  ja2 = max(ja2,1)
8915  ja2 = min(ja2,naq)
8916  ja2p = max(ja2p,1)
8917  ja2p = min(ja2p,naq)
8918  end if
8919 !
8920  qn2 = (t_w1k2(iloc)*nspec(jk2,ja2) + &
8921  t_w2k2(iloc)*nspec(jk2p,ja2) + &
8922  t_w3k2(iloc)*nspec(jk2,ja2p) + &
8923  t_w4k2(iloc)*nspec(jk2p,ja2p))*t2
8924 !
8925  jk4 = t_ik4(iloc)
8926  jk4p = min(jk4+1,nkq)
8927  ja4 = mod(t_ia4(iloc)-1+naq,naq)+1
8928  ja4p = mod(t_ia4(iloc)+naq,naq)+1
8929 !
8930  t4 = t_tail4(iloc)
8931 !
8932 ! compute tail factor
8933 !
8934 ! if(jk4==nkq .and. jk4p==nkq) then
8935 ! wk = t_w2k4(iloc) + t_w4k4(iloc)
8936 ! vk4 = q_k(t_ik4(iloc)) + wk*q_sk(t_ik4(iloc))
8937 ! t4 = (vk4/q_k(nkq))**(-4)
8938 ! end if
8939 !
8940 ! special treatment for sector grids
8941 ! limit range of indices
8942 ! QQQ: in fact energy density should be set to ZERO
8943 !
8944  if(iq_grid < 3) then
8945  ja4 = max(ja4,1)
8946  ja4 = min(ja4,naq)
8947  ja4p = max(ja4p,1)
8948  ja4p = min(ja4p,naq)
8949  end if
8950 !
8951  qn4 = (t_w1k4(iloc)*nspec(jk4,ja4) + &
8952  t_w2k4(iloc)*nspec(jk4p,ja4) + &
8953  t_w3k4(iloc)*nspec(jk4,ja4p) + &
8954  t_w4k4(iloc)*nspec(jk4p,ja4p))*t4
8955 !
8956 !-------------------------------------------------------------------------------
8957 !
8958  nprod = qn13p*(qn4-qn2) + qn2*qn4*qn13d
8959  rterm = t_zz(iloc)
8960  t13 = t13 + rterm*nprod
8961 !
8962 ! output to triplets
8963 !
8964 !
8965  dt13(iloc) = nprod *rterm
8966 !
8967 ! add diagonal terms
8968 !
8969 !! qd1 = qn3*(qn4-qn2) + qn2*qn4*qn3
8970 !! qd3 = qn1*(qn4-qn2) - qn2*qn4*qn1
8971 !
8972  qd1 = qn3*(qn4-qn2) - qn2*qn4
8973  qd3 = qn1*(qn4-qn2) + qn2*qn4
8974  diagk1 = diagk1 + qd1*rterm
8975  diagk3 = diagk3 + qd3*rterm
8976 !-----------------------------------------------------------------------------------
8977 ! Test output of actual integration
8978 !
8979  if(jq_int == 1) then
8980 !
8981 ! reconstruct wave numbers along locus
8982 !
8983  wk = t_w2k2(iloc) + t_w4k2(iloc)
8984  wa = t_w3k2(iloc) + t_w4k2(iloc)
8985  ja2 = mod(t_ia2(iloc)-1+naq,naq)+1
8986  vk2 = q_k(t_ik2(iloc)) + wk*q_sk(t_ik2(iloc))
8987  va2 = q_a(ja2) + wa*q_delta
8988 !
8989  wk = t_w2k4(iloc) + t_w4k4(iloc)
8990  wa = t_w3k4(iloc) + t_w4k4(iloc)
8991  ja4 = mod(t_ia4(iloc)-1+naq,naq)+1
8992  vk4 = q_k(t_ik4(iloc)) + wk*q_sk(t_ik4(iloc))
8993  va4 = q_a(ja4) + wa*q_delta
8994 !
8995  write(luq_int,'(1x,i4,5f8.3,11e12.4,2f11.6)') &
8996  iloc,vk2,va2*rade,vk4,va4*rade, &
8997  t_ws(iloc),qn1,qn2,qn3,qn4,nprod, &
8998  t_cple(iloc),t_jac(iloc),t_sym(iloc),t_zz(iloc), &
8999  dt13(iloc),t13, &
9000  t2,t4
9001  end if
9002  end do
9003 !
9004 !!/T if(iq_test>=4) then
9005 !!/T write(luq_tst,'(a)') 'Q_T13V4: NSPEC'
9006 !!/T do ikq=1,nkq
9007 !!/T write(luq_tst,'(100e12.4)') (nspec(ikq,iaq),iaq=1,naq)
9008 !!T end do
9009 !!T end if
9010  if(iq_integ==3 .and. ik1>=30 .and. ik1<=35 .and. ik3>=30 .and. &
9011  ik3<=35 ) &
9012  write(luq_int,'(a,4i3,i5,e13.5)') 'Q_T13V4:',ik1,ia1,ik3,ia3, &
9013  nlocusx,t13
9014 !
9015 !!/T if(iq_integ==3) write(luq_int,'(4i3,i5,1000e13.5)') ik1,ia1,ik3,ia3,nloc,
9016 !!/T & t_s(nloc),t13
9017 !!,(dt13(iloc),iloc=1,nloc)
9018 !
9019  9999 continue
9020 !
9021  call q_stack('-q_t13v4')
9022 !
9023  return
all_vars::t2
real(sp), dimension(:,:), allocatable, target t2
Definition: mod_main.f90:1314
m_constants
Definition: swmod3.f90:22
mod_time::mod
Definition: mod_time.f90:69
m_constants::rade
real rade
Definition: swmod3.f90:40
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_weight()

subroutine m_xnldata::q_weight ( )

Definition at line 9027 of file swmod3.f90.

9027 !------------------------------------------------------------------------------
9028 !
9029 ! +-------+ ALKYON Hydraulic Consultancy & Research
9030 ! | | Gerbrant van Vledder
9031 ! | +---+
9032 ! | | +---+ Last update: 20 Aug. 2002
9033 ! +---+ | | Release: 4.0
9034 ! +---+
9035 !
9036 !
9037 ! SWAN (Simulating WAves Nearshore); a third generation wave model
9038 ! Copyright (C) 2004-2005 Delft University of Technology
9039 !
9040 ! This program is free software; you can redistribute it and/or
9041 ! modify it under the terms of the GNU General Public License as
9042 ! published by the Free Software Foundation; either version 2 of
9043 ! the License, or (at your option) any later version.
9044 !
9045 ! This program is distributed in the hope that it will be useful,
9046 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
9047 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9048 ! GNU General Public License for more details.
9049 !
9050 ! A copy of the GNU General Public License is available at
9051 ! http://www.gnu.org/copyleft/gpl.html#SEC3
9052 ! or by writing to the Free Software Foundation, Inc.,
9053 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
9054 !
9055 !
9056 ! do not use m_xnldata
9057  implicit none
9058 !
9059 ! 0. Update history
9060 !
9061 ! 13/04/1999 Initial version
9062 ! 27/10/1999 Weight computed in the case that k2m < k(1)
9063 ! 01/11/1999 Use of Q_XK and Q_SK added to compute weights if k > kmax
9064 ! 26/11/1999 Bug fixed when checking conversion
9065 ! 8/12/1999 Use of SK_MAX introduced to handle very large loci
9066 ! 09/08/2002 Modification of weights
9067 ! 13/08/2002 storage of log-spacing replace by linear spacing
9068 ! 20/08/2002 Bug fixed when geometric scaling is assumed
9069 !
9070 ! 1. Purpose:
9071 !
9072 ! Compute interpolation weights of locus
9073 !
9074 ! 2. Method
9075 !
9076 ! Compute position of wave number in wave number grid
9077 ! Usable for linear interpolation
9078 !
9079 ! 3. Parameter list:
9080 !
9081 ! Name I/O Type Description
9082 !
9083 ! 4. Error messages
9084 !
9085 ! 5. Called by:
9086 !
9087 ! Q_MAKEGRID
9088 !
9089 ! 6. Subroutines used
9090 !
9091 ! 7. Remarks
9092 !
9093 ! The tail factors wt_k2 and wt_k4 are valid for the decay of the action density spectrum
9094 ! N(kx,ky). With p (qk_tail) the power p of the tail of the N(k) spectrum, and q the power
9095 ! of the tail of the N(kx,ky) spectrum, we have q=p-1
9096 !
9097 ! Since N(k) = k N(kx,ky) with k the Jacobian
9098 ! it follows that the tail functions are given by
9099 !
9100 ! k^p = k k^q => k^p = k^(q+1) => p=q+1 => q=p-1
9101 !
9102 ! 8. Structure
9103 !
9104 ! Initialisations
9105 ! do for all points on locus
9106 ! compute directional index for k2 and k4
9107 ! if geometric scaling then
9108 ! compute wave number index directly
9109 ! convert log-scaling to linear scaling
9110 ! else
9111 ! search position of wave number in k-array
9112 ! if k < kmin then
9113 ! k-index = 1 and factor is 0
9114 ! elsif k < kmax then
9115 ! compute k-index for k2 and k4
9116 ! else
9117 ! compute tail factor
9118 ! end if
9119 ! end if
9120 ! end do
9121 !
9122 !
9123 ! 9. Switches
9124 !
9125 ! /T enable test output
9126 !
9127 ! 10. Source code:
9128 !------------------------------------------------------------------------------
9129 ! Local variables
9130 !
9131  integer iloc ! counter along locus loop
9132  integer jpos ! index for interpolation and tracking of position in wave numebr array
9133  integer itest ! local test level
9134  real k2a,k2m ! angle (radians) and magnitude of wave number k2
9135  real k4a,k4m ! angle (radians) and magnitude of wave number k2
9136  real dk ! difference between two wave numbers
9137  real xtest ! test value for checking computation of weights, by inversion test
9138  real ff,gg ! variables in transformation of log-spacing to linear spacing
9139 !
9140 ! functions used
9141 !
9142 !! real x_kfunc ! function to invert computation of wieghts
9143 !------------------------------------------------------------------------------
9144  call q_stack('+q_weight')
9145 !
9146 ! initialisations
9147 !
9148  itest = iq_test ! set local test level
9149  itest = itest
9150 !------------------------------------------------------------------------------
9151  do iloc=1,nlocus
9152  k2m = k2m_mod(iloc)
9153  k2a = k2a_mod(iloc)
9154  k4m = k4m_mod(iloc)
9155  k4a = k4a_mod(iloc)
9156 !
9157  wt_k2(iloc) = 0.
9158  wt_k4(iloc) = 0.
9159 !
9160 ! compute directional weights
9161 !
9162  wa_k2(iloc) = (k2a-q_ang1)/q_deltad+1
9163  wa_k4(iloc) = (k4a-q_ang1)/q_deltad+1
9164 !------------------------------------------------------------------------------
9165 ! compute position of k2 in wave number grid
9166 ! and compute weight function
9167 !-----------------------------------------------------------------------------
9168  if(iq_disp==1.and. iq_geom==1) then ! deep water is assumed and loci have geometric scaling
9169 !
9170  wk_k2(iloc) = 1.+alog(k2m/kqmin)/alog(q_kfac)
9171  wt_k2(iloc) = 1.
9172  wk_k4(iloc) = 1.+alog(k4m/kqmin)/alog(q_kfac)
9173  wt_k4(iloc) = 1.
9174 !
9175 ! Replace log-spacing by linear spacing
9176 !
9177  ff = wk_k2(iloc)
9178  gg = floor(ff)
9179  wk_k2(iloc) = gg+(q_kfac**(ff-gg)-1.)/(q_kfac-1.)
9180 !
9181 !!/T if(iq_test>=3) write(luq_tst,'(a,4f10.5)') 'Q_WEIGHT: wlog gg wlin2:',
9182 !!/T & ff,gg,wk_k2(iloc),abs(wk_k2(iloc)-ff)/abs(ff)*100.
9183 !
9184  ff = wk_k4(iloc)
9185  gg = floor(ff)
9186  wk_k4(iloc) = gg+(q_kfac**(ff-gg)-1.)/(q_kfac-1.)
9187 !
9188 !!/T if(iq_test>=3) write(luq_tst,'(a,4f10.5)') 'Q_WEIGHT: wlog gg wlin4:',
9189 !!/T ff,gg,wk_k4(iloc),abs(wk_k4(iloc)-ff)/abs(ff)*100.
9190 !
9191 ! for finite depth a search is carried out to compute
9192 ! the position of the interacting wave number in the
9193 ! non-geometric k-grid
9194 !
9195  else
9196  jpos = 1
9197  do while (k2m > q_k(jpos))
9198  jpos = jpos + 1
9199  if(jpos > nkq) exit
9200  end do
9201 !
9202  if(k2m <= q_k(1)) then
9203  wk_k2(iloc) = k2m/q_k(1)
9204  wt_k2(iloc) = 0.
9205  elseif(k2m < q_k(nkq) .and. k2m > q_k(1)) then
9206  dk = q_k(jpos)-q_k(jpos-1)
9207  wk_k2(iloc) = real(jpos-1) + (k2m-q_k(jpos-1))/dk
9208  wt_k2(iloc) = 1.
9209  elseif(k2m >= q_k(nkq)) then
9210  wk_k2(iloc) = min(wk_max,real(nkq)+(k2m-q_k(nkq))/q_sk(nkq))
9211  wt_k2(iloc) = (k2m/q_k(nkq))**(qk_tail-1.)
9212 !
9213 ! minus 1 to account for Jacobian from kx,ky to polar k-grid
9214 !
9215  end if
9216 !
9217 ! compute position of k4 in wave number grid
9218 ! and compute weight function
9219 !
9220  jpos = 1
9221  do while (k4m > q_k(jpos))
9222  jpos = jpos + 1
9223  if(jpos > nkq) exit
9224  end do
9225 !
9226  if(k4m <= q_k(1)) then
9227  wk_k4(iloc) = k4m/q_k(1)
9228  wt_k4(iloc) = 0.
9229  elseif(k4m < q_k(nkq) .and. k4m > q_k(1)) then
9230  dk = q_k(jpos)-q_k(jpos-1)
9231  wk_k4(iloc) = real(jpos-1) + (k4m-q_k(jpos-1))/dk
9232  wt_k4(iloc) = 1.
9233  elseif(k4m >= q_k(nkq)) then
9234  wk_k4(iloc) = min(wk_max,real(nkq)+(k4m-q_k(nkq))/q_sk(nkq))
9235  wt_k4(iloc) = (k4m/q_k(nkq))**(qk_tail-1.)
9236  end if
9237 !
9238  end if
9239 !
9240  if(itest >= 1) write(luq_tst,'(a,i3,10f12.4)') &
9241  'Q_WEIGHT: i k2m k2a wk2 wa2 wt2(+4):', &
9242  iloc,k2m,k2a,wk_k2(iloc),wa_k2(iloc),wt_k2(iloc), &
9243  k4m,k4a,wk_k4(iloc),wa_k4(iloc),wt_k4(iloc)
9244 !
9245  end do
9246 !
9247  9999 continue
9248 !
9249  call q_stack('-q_weight')
9250 !
9251  return
ocpcomm4::itest
integer itest
Definition: swmod1.f90:536
Here is the call graph for this function:
Here is the caller graph for this function:

◆ q_xnl4v4()

subroutine m_xnldata::q_xnl4v4 ( real, dimension(nsig,nang), intent(in)  aspec,
real, dimension(nsig), intent(in)  sigma,
real, dimension(nang), intent(in)  angle,
integer, intent(in)  nsig,
integer, intent(in)  nang,
real, intent(in)  depth,
real, dimension(nsig,nang), intent(out)  xnl,
real, dimension(nsig,nang), intent(out)  diag,
integer, intent(out)  ierror 
)

Definition at line 9404 of file swmod3.f90.

9404 !------------------------------------------------------------------------------
9405 !
9406 ! +-------+ ALKYON Hydraulic Consultancy & Research
9407 ! | | Gerbrant van Vledder
9408 ! | +---+
9409 ! | | +---+ Last update: 29 April 2004
9410 ! +---+ | | Release: 5.0
9411 ! +---+
9412 !
9413 !
9414 ! SWAN (Simulating WAves Nearshore); a third generation wave model
9415 ! Copyright (C) 2004-2005 Delft University of Technology
9416 !
9417 ! This program is free software; you can redistribute it and/or
9418 ! modify it under the terms of the GNU General Public License as
9419 ! published by the Free Software Foundation; either version 2 of
9420 ! the License, or (at your option) any later version.
9421 !
9422 ! This program is distributed in the hope that it will be useful,
9423 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
9424 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9425 ! GNU General Public License for more details.
9426 !
9427 ! A copy of the GNU General Public License is available at
9428 ! http://www.gnu.org/copyleft/gpl.html#SEC3
9429 ! or by writing to the Free Software Foundation, Inc.,
9430 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
9431 !
9432 !
9433 ! do not use m_xnldata
9434  use m_constants
9435  use serv_xnl4v5
9436  implicit none
9437 !------------------------------------------------------------------------------
9438 ! 0. Update history
9439 !
9440 ! 08/01/2000 Initial version
9441 ! 12/01/2001 Updated interface
9442 ! 13/01/2001 Inclusion of diagonal term
9443 ! 14/02/2002 Upgrade to release 4.0, depth added to input
9444 ! 20/08/2002 quad depth adapted in the case of WAM-depth scaling
9445 ! then deep water is assumed for conversion of A(sig,theta) -> N(kx,ky)
9446 ! Search option for nearest grid included
9447 ! 23/08/2002 Allocation of work arrays set to fixed size
9448 ! 11/09/2002 Filtering of energy densities introduced and restructure
9449 ! 14/04/2003 Format of test write statement corrected
9450 ! 03/05/2003 Computation and output of triplets enabled
9451 ! 12/06/2003 Export spectral grid in case of Q_INTEG>1
9452 ! 16/06/2003 Switch IQ_SYM included
9453 ! Allocation of dynamic data array's moved to Q_ALLOCATE
9454 ! 24/06/2003 Range of loop for IK3 made dependent on value of IQ_SYM
9455 ! 25/06/2003 Bug fixed in assigment of contribution of diagonal term
9456 ! 27/04/2004 Bug fixed in hadling of symmetric sector grid
9457 ! Also mirror image of DIAG copied after computation
9458 ! 29/04/2004 In case of error set variable IERROR
9459 !
9460 ! 1. Purpose:
9461 !
9462 ! Compute nonlinear transfer for a given action density spectrum
9463 ! on a given wave number and direction grid
9464 !
9465 ! 2. Method
9466 !
9467 ! Compute nonlinear transfer in a surface gravity wave spectrum
9468 ! due to resonant four wave-wave interactions
9469 !
9470 ! Methods: Webb/Resio/Tracy/VanVledder
9471 !
9472 !
9473 ! 3. Parameter list:
9474 !
9475 ! Type I/O Name Description
9476 !------------------------------------------------------------------------------
9477  integer,intent(in) :: nsig ! number of radian frequencies
9478  integer,intent(in) :: nang ! number of directions
9479  real, intent(in) :: aspec(nsig,nang) ! Action density spectrum as a function of (sigma,theta)
9480  real, intent(in) :: sigma(nsig) ! radian frequencies
9481  real, intent(in) :: angle(nang) ! directions in radians (sector or full circle)
9482  real, intent(in) :: depth ! water depth in m
9483  real, intent(out) :: xnl(nsig,nang) ! nonlinear quadruplet interaction computed with
9484 ! a certain exact method (k,theta)
9485  real, intent(out) :: diag(nsig,nang) ! Diagonal term for WAM based implicit integration scheme
9486  integer, intent(out) :: ierror ! error indicator
9487 !
9488 ! 4. Error messages
9489 !
9490 ! 5. Called by:
9491 !
9492 ! XNL_MAIN
9493 !
9494 ! 6. Subroutines used
9495 !
9496 ! Q_STACK
9497 ! Q_INIT
9498 ! Q_CTRGRID
9499 ! Q_T13V4
9500 ! Q_SEARCHGRID
9501 !
9502 ! 7. Remarks
9503 !
9504 ! The external action density spectrum is given as N(sigma,dir)
9505 ! The internal action density spectrum is given as N(kx,ky)
9506 !
9507 ! These 2 spectra are conected via the Jacobian transformation
9508 !
9509 ! cg
9510 ! N(kx,ky) = -- N(sig,theta)
9511 ! k
9512 ! 8. Structure
9513 !
9514 ! 9. Switches
9515 !
9516 ! 10. Source code
9517 !------------------------------------------------------------------------------
9518 ! local variables
9519 !---------------------------------------------------------------------------------------
9520  integer iaq ! counter for directions
9521  integer jaq ! counter for directions
9522  integer ikq ! counter for wave numbers
9523  integer iang ! counter for directions
9524  integer ia ! counter for directions
9525  integer ik ! counter for wave numbers
9526  integer idir1 ! direction in degrees of k1 (for integration test)
9527  integer idir3 ! direction in degrees of k3 (for integration test)
9528  real period ! periodicity for direction, used in conversion of 2-spectra
9529  real diagk1 ! diagonal term for k1
9530  real diagk3 ! diagonal term for k3
9531 !
9532  real qn_max ! maximum action density
9533  real qn_min ! minimum action density
9534 !
9535  real cg(nsig) ! group velocity for conversion of spectrum and transfer
9536 !
9537  integer ia1,ia3,ja3 ! limits for directional loops
9538  integer jk3 ! start of k3 loop
9539  integer ik1,ik3 ! counters for wave number loop
9540  integer nloc ! number of points on locus
9541 !
9542  integer igrid ! status of grid file
9543  real t13 ! value of sub-integral
9544  real k_rat ! local ratio of wave numbers
9545  real a_dif ! directional difference
9546  real jacobian ! Jacobian
9547  real qn1,qn3 ! action densities in k1 and k3
9548 !
9549 ! testing of diagonal term on a low level
9550 !
9551  real diagk1_0 ! saved value of diagk1
9552  real diagk3_0 ! saved value of diagk3
9553  real dq1 ! small change in action density of n1
9554  real dq3 ! small change in action density of n3
9555  real t13_0 ! Original estimated of diagonal term
9556  real t13_1,t13_3 ! perturbed estimated of diagonal term
9557 !
9558  integer ifil_dir ! indicator for filtering of directional criterion
9559  integer ifil_krat ! indicator for filtering of wave number ratio criterion
9560  integer ifil_dens ! indicator for filtering of action density criterion
9561  integer ifil_tot ! indicator for filtering due to any criterion
9562  integer nfil_dir ! counter to indicate filtering of directional criterion
9563  integer nfil_krat ! counter to indicate filtering of wave number criterion
9564  integer nfil_dens ! counter to indicate filtering of action density criterion
9565 !
9566  integer ntot_conf ! total number of configurations
9567  integer ntot_filt ! total number of filtered configurations
9568 !
9569  integer icx1,icx3 ! test output for T13 test
9570  real xt13 ! modified contribution of T13
9571 !
9572 !------------------------------------------------------------------------------
9573  call q_stack('+q_xnl4v4')
9574 !
9575 ! initialisations
9576 !------------------------------------------------------------------------------
9577  ierror = 0 ! error status
9578  diag = 0 ! initialize output diagonal term
9579 !
9580 !
9581  if(iq_type==3) then
9582  q_depth = depth ! water depth to be used in computation
9583  else
9584  q_depth = q_maxdepth
9585  end if
9586 !--------------------------------------------------------------------------
9587 ! generate basic grid of loci and store loci in memory and to datafile
9588 !--------------------------------------------------------------------------
9589  if(iq_screen >= 1) write(iscreen,'(a)') &
9590  'Q_XNL4V4: Checking interaction grid '
9591  if(iq_screen >= 1) write(iscreen,'(a,2i4)') &
9592  'Q_XNL4V4: iq_search iq_type:',iq_search,iq_type
9593 !
9594  if(iq_search==0 .or. iq_type/=3) then
9595  call q_init
9596  call q_ctrgrid(2,igrid)
9597  if(iq_err /= 0) then
9598  ierror = 1
9599  goto 9999
9600  end if
9601 !
9602  if(igrid/=0) then
9603  call q_error('e','NOGRID','No proper grid exists')
9604  ierror = 2
9605  goto 9999
9606  end if
9607 !
9608  if(iq_make ==3) then
9609  call q_error('e','MAKEGRID','Only computation of grid')
9610  goto 9999
9611  end if
9612 !------------------------------------------------------------------------------
9613 ! set overall scale factor resulting from optional SEARCH for nearest grid
9614 !------------------------------------------------------------------------------
9615 !
9616  q_scale = 1.
9617 !------------------------------------------------------------------------
9618  else
9619 !
9620 ! search nearest valid grid and compute additional WAM scale factor
9621 ! only active when IQ_SEARCH==1 .AND. IQ_TYPE==3
9622 !
9623  if(iq_screen>0) write(iscreen,'(a,f12.2)') &
9624  'Q_XNL4V4: Q_SEARCHGRID called with q_depth: ',q_depth
9625  call q_searchgrid(depth,igrid)
9626 
9627  if(iq_screen>0) write(iscreen,'(a,f12.2)') &
9628  'q_xnl4v4: q_searchgrid exited with q_depth: ',q_depth
9629 
9630  if(igrid/=0) then
9631  call q_error('e','nogrid','no proper grid exists')
9632  ierror = 3
9633  goto 9999
9634  end if
9635 !
9636  if(iq_err /=0) goto 9999
9637  end if
9638 !
9639 !------------------------------------------------------------------------------
9640 ! convert input action density spectrum from A(sigma,theta) -> N(kx,ky)
9641 !
9642  do ikq=1,nkq
9643  call z_cmpcg(sigma(ikq),q_depth,q_grav,cg(ikq))
9644  do iaq=1,naq
9645  nspec(ikq,iaq) = aspec(ikq,iaq)/q_k(ikq)*cg(ikq)
9646  end do
9647  end do
9648 !
9649  if(iq_test>=1) then
9650  write(luq_tst,'(a)') 'nspec'
9651  do ikq=1,nkq
9652  write(luq_tst,'(100e12.4)') (nspec(ikq,iaq),iaq=1,naq)
9653  end do
9654  end if
9655 !------------------------------------------------------------------------------
9656 !
9657  if(iq_integ==2) then
9658  write(luq_int,'(2i4)') nkq,naq
9659  write(luq_int,'(10f10.3)') (q_k(ik1),ik1=1,nkq)
9660  write(luq_int,'(10f10.3)') (q_a(ia1)*rade,ia1=1,naq)
9661  end if
9662 !--------------------------------------------------------------------------------------
9663 ! integration over all possible configurations
9664 !--------------------------------------------------------------------------------------
9665  xnl = 0.
9666  qn_max = maxval(nspec)
9667 !
9668 !--------------------------------------------------------------------------------------
9669  do ik1 = 1,nkq
9670  if(iq_screen >= 1) write(iscreen,'(a,2i4,e12.3)') &
9671  'q_xnl4v4: k1 nk depth:',ik1,nkq,q_depth
9672  jk3 = ik1
9673  if(iq_sym==0) jk3 = 1
9674 !
9675  do ia1 = iaq1,iaq2 ! loop over selected part of grid, set in q_init
9676 !
9677  qn1 = nspec(ik1,ia1)
9678 !
9679  do ik3 = jk3,nkq ! compute only half-plane
9680  do ia3 = 1,naq ! loop over all possible wave directions
9681  qn3 = nspec(ik3,ia3)
9682 !
9683  if(iq_screen>=3) write(iscreen,'(a,4i4)') &
9684  'q_xnl4v4: ik1 ia1 ik3 ia3:',ik1,ia1,ik3,ia3
9685 !
9686 ! computes distances in wave number space
9687 !
9688  a_dif = 180. - abs(180. - abs(q_ad(ia1) - q_ad(ia3)))
9689  k_rat = max(q_k(ik1)/q_k(ik3), q_k(ik3)/q_k(ik1))
9690  qn_min = qf_frac*qn_max/(q_k(ik3)/q_k(1))**7.5
9691  qn_min = qf_frac*qn_max*q_kpow(ik3)
9692 !
9693  ifil_dir = 0
9694  ifil_krat = 0
9695  ifil_dens = 0
9696  ifil_tot = 0
9697 !
9698 ! perform filtering
9699 !
9700 ! directional difference
9701 !
9702  if(a_dif > qf_dmax) then
9703  ifil_dir = 1
9704  end if
9705 !
9706 ! wave number ratio
9707 !
9708  if(k_rat > qf_krat) then
9709  ifil_krat = 1
9710  end if
9711 !
9712 ! energy density filtering
9713 !
9714 .and. if(qn1 < qn_min qn3 < qn_min) then
9715  ifil_dens = 1
9716  end if
9717 !
9718 !
9719 .and..and..or. if(ifil_dir==0 ifil_krat==0 ifil_dens==0 &
9720  iq_filt==0) then
9721 .and..or.!? if(a_dif < qf_dmax k_rat < qf_krat iq_filt==0) then
9722 !
9723 ! perform integration along locus
9724 !
9725  call q_t13v4(ik1,ia1,ik3,ia3,t13,diagk1,diagk3)
9726 !
9727 ! check computation of diagonal term --------------------------------------
9728 ! check has been done on 25 June 2003
9729 !
9730 ! diagk1_0 = diagk1
9731 ! diagk3_0 = diagk3
9732 ! t13_0 = t13
9733 ! t13_1 = 0.
9734 ! t13_3 = 0.
9735 ! dq1 = nspec(ik1,ia1)*0.01
9736 ! dq3 = nspec(ik3,ia3)*0.01
9737 ! nspec(ik1,ia1) = nspec(ik1,ia1)+ dq1
9738 ! call q_t13v4(ik1,ia1,ik3,ia3,t13,diagk1,diagk3)
9739 ! if(dq1>1.e-10) t13_1 = (t13-t13_0)/dq1
9740 ! nspec(ik1,ia1) = nspec(ik1,ia1) - dq1
9741 !
9742 ! nspec(ik3,ia3) = nspec(ik3,ia3) + dq3
9743 ! call q_t13v4(ik1,ia1,ik3,ia3,t13,diagk1,diagk3)
9744 ! nspec(ik3,ia3) = nspec(ik3,ia3) - dq3
9745 ! if(dq3>1.e-10) t13_3 = (t13-t13_0)/dq3
9746 ! write(*,'(a,6e13.4)') 'check of diagonal term:',dq1,diagk1_0,t13_1,dq3,diagk3_0,t13_3
9747 !
9748 !---------- end of check of diagonal term
9749 !
9750  if(iq_err /= 0) then
9751  ierror = 4
9752  goto 9999
9753  end if
9754 !
9755 ! check contribution T13 as computed with triplet method
9756 !
9757 !!/R qt13 = 0.
9758 !!/R do iqtr = 1,ktriplets
9759 !!/R qt13 = qt13 + w_qtr(iqtr)*nspec(i_qtr(iqtr,1),i_qtr(iqtr,2))*
9760 !!/R & nspec(i_qtr(iqtr,3),i_qtr(iqtr,4))*nspec(i_qtr(iqtr,5),i_qtr(iqtr,6))
9761 !!/R end do
9762 !!/R write(iscreen,*) 'check t13 qt13:',t13,qt13
9763 !
9764  if(iq_t13==1) then
9765  idir1 = int(q_ad(ia1))
9766  idir3 = int(q_ad(ia3))
9767  if (idir1>180) idir1 = idir1-360
9768  if (idir3>180) idir3 = idir3-360
9769  icx1 = (idir1/15-1)*20+ik1
9770  icx3 = (idir3/15-1)*20+ik3
9771  xt13 = alog10(max(1.e-20,abs(t13)))
9772  if(xt13<-19.99) xt13=0
9773  write(luq_t13,'(4i6,e13.5,2i6,f10.4)') ik1,idir1,ik3, &
9774  idir3,t13,icx1,icx3,xt13
9775  end if
9776 !
9777 ! take care of additional scale factor aring from search of nearest grid
9778 !
9779  t13 = t13*q_scale
9780  diagk1 = diagk1*q_scale
9781  diagk3 = diagk3*q_scale
9782 !
9783 ! take care of symmetric storing of interactions
9784 ! and factor 2 due to symmetry (if activated)
9785 !
9786  if(iq_sym==1) then
9787  t13 = 2.*t13
9788  diagk1 = 2.*diagk1
9789  diagk3 = 2.*diagk3
9790  end if
9791 !
9792 ! compute mirror image of index
9793 !
9794  ja3 = ia3
9795 .and. if(iq_grid==1 ia3 < iaref) ja3 = naq-ia3+1
9796 !
9797  xnl(ik1,ia1) = xnl(ik1,ia1) + t13*q_k(ik3)* &
9798  q_delta*q_dk(ik3)
9799  xnl(ik3,ja3) = xnl(ik3,ja3) - t13*q_k(ik1)* &
9800  q_delta*q_dk(ik1)
9801 !
9802 ! add diagonal term
9803 !
9804  diag(ik1,ia1) = diag(ik1,ia1) + diagk1*q_k(ik3)* &
9805  q_delta*q_dk(ik3)
9806  diag(ik3,ja3) = diag(ik3,ja3) - diagk3*q_k(ik1)* &
9807  q_delta*q_dk(ik1)
9808 !
9809  end if
9810 !
9811 !!/F write(luq_fil,'(a,4i3,3e11.3,2f7.2,4i2)')
9812 !!/F & 'ik1 ia1 ik3 ia3 n1 n3 t13 adif krat fil1/2/3:',
9813 !!/F & ik1,ia1,ik3,ia3,qn1,qn3,t13,a_dif,k_rat,
9814 !!/F & ifil_dir,ifil_krat,ifil_dens,ifil_tot
9815  end do
9816  end do
9817  end do
9818  end do
9819 !
9820 !
9821 !
9822 !
9823 !
9824 ! write number of triplets that have been written
9825 !
9826 !
9827 !------------------------------------------------------------------------------
9828 ! in the case of a symmetric sector, copy results to other part
9829 !
9830 ! Examples: naq=5, iaref=3: 1,2,3,4,5 -> Q(1)=Q(5)
9831 ! Q(2)=Q(4)
9832 ! Q(3)=Q(3)
9833 ! iaq+jaq=naq+1
9834 ! naq=6, iaref=4: 1,2,3,4,5,6 -> Q(1)=Q(6)
9835 ! Q(2)=Q(5)
9836 ! Q(3)=Q(4)
9837 !
9838  if(iq_grid==1) then
9839  do ikq = 1,nkq
9840  do iaq=iaref,naq
9841  jaq = naq+1-iaq
9842  xnl(ikq,jaq) = xnl(ikq,iaq)
9843  diag(ikq,jaq) = diag(ikq,iaq)
9844  end do
9845  end do
9846  end if
9847 !
9848 !------------------------------------------------------------------------------
9849  if(iq_screen>=2) write(iscreen,'(a)') &
9850  'q_xnl4v4: main computation ended'
9851 !
9852 ! Convert transfer from (kx,ky) grid to (sigma,theta) grid
9853 !
9854  do ikq=1,nkq
9855  jacobian = q_k(ikq)/cg(ikq)
9856  do iaq=1,naq
9857  xnl(ikq,iaq) = xnl(ikq,iaq)*jacobian
9858  end do
9859  end do
9860 ! !
9861  9999 continue
9862 !
9863  call q_stack('-q_xnl4v4')
9864 !
9865  return
m_constants
Definition: swmod3.f90:22
m_genarr::depth
real, dimension(:), allocatable, save depth
Definition: swmod2.f90:768
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ tanz()

real function m_xnldata::tanz ( real  x)

Definition at line 10737 of file swmod3.f90.

10737  real x
10738 ! print *,'inside tanz '
10739  if (x.gt.20.) x=25.
10740  tanz=tanh(x)
10741 ! print *,'after def of tanz'
10742  return
Here is the caller graph for this function:

◆ x_cosk()

real function m_xnldata::x_cosk ( real, intent(in)  k)

Definition at line 9869 of file swmod3.f90.

9869 !------------------------------------------------------------------------------
9870 !
9871 ! +-------+ ALKYON Hydraulic Consultancy & Research
9872 ! | | Gerbrant van Vledder
9873 ! | +---+
9874 ! | | +---+ Last update: 13 Aug. 2002
9875 ! +---+ | | Release: 4.0
9876 ! +---+
9877 !
9878 !
9879 ! SWAN (Simulating WAves Nearshore); a third generation wave model
9880 ! Copyright (C) 2004-2005 Delft University of Technology
9881 !
9882 ! This program is free software; you can redistribute it and/or
9883 ! modify it under the terms of the GNU General Public License as
9884 ! published by the Free Software Foundation; either version 2 of
9885 ! the License, or (at your option) any later version.
9886 !
9887 ! This program is distributed in the hope that it will be useful,
9888 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
9889 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9890 ! GNU General Public License for more details.
9891 !
9892 ! A copy of the GNU General Public License is available at
9893 ! http://www.gnu.org/copyleft/gpl.html#SEC3
9894 ! or by writing to the Free Software Foundation, Inc.,
9895 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
9896 !
9897 !
9898 ! do not use m_xnldata
9899  use serv_xnl4v5, only: z_wnumb
9900 !
9901  implicit none
9902 !--------------------------------------------------------------------------------
9903 ! 0. Update history
9904 !
9905 ! Date Description
9906 !
9907 ! 13/08/2002 Initial version
9908 !
9909 ! 1. Purpose:
9910 !
9911 ! Compute cosine of points on locus for given wave number k
9912 !
9913 ! 2. Method
9914 !
9915 ! Explicit polar method, see Van Vledder 2000, Monterey paper
9916 ! Optionally using a fixed k-step, geometric k-step or adaptive stepping
9917 !
9918 ! 3. Parameters used:
9919 !
9920  real, intent(in) :: k ! wave number along symmetry axis of locus
9921 !
9922 ! 4. Error messages
9923 !
9924 ! 5. Called by:
9925 !
9926 ! Q_POLAR
9927 !
9928 ! 6. Subroutines used:
9929 !
9930 ! Z_WNUMB computation of wave number
9931 !
9932 ! 7. Remarks
9933 !
9934 ! The variables q, pmag and q_depth are accessed from module m_xnldata
9935 ! The variable q_grav is accessed from module m_constants
9936 !
9937 ! 8. Structure
9938 !
9939 ! 9. Switches
9940 !
9941 !
9942 ! 10. Source code
9943 !------------------------------------------------------------------------------
9944 ! Local variables
9945 !
9946  real qq ! constant in direct polar method qq=q/sqrt(g)
9947  real wk ! intemediate radian frequency
9948  real kz ! intermediate wave number
9949 !------------------------------------------------------------------------------
9950  select case(iq_disp)
9951 !
9952  case(1) ! deep water
9953 !
9954  qq = q/sqrt(q_grav)
9955  x_cosk = ((qq+sqrt(k))**4 - k**2 - pmag**2)/(2.*k*pmag)
9956 !
9957  case(2) ! finite depth
9958 !
9959  wk = q + x_disper(k,q_depth)
9960  kz = z_wnumb(wk,q_depth,q_grav)
9961  x_cosk = (kz**2-k**2 - pmag**2)/(2.*k*pmag)
9962 !
9963  end select
9964 !
9965  x_cosk = max(-1.,x_cosk)
9966  x_cosk = min( 1.,x_cosk)
9967 !
serv_xnl4v5::z_wnumb
real function z_wnumb(w, d, grav_w)
Definition: swmod3.f90:1467
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:
Here is the caller graph for this function:

◆ x_cple()

real function m_xnldata::x_cple ( real, intent(in)  k1x,
real, intent(in)  k1y,
real, intent(in)  k2x,
real, intent(in)  k2y,
real, intent(in)  k3x,
real, intent(in)  k3y,
real, intent(in)  k4x,
real, intent(in)  k4y,
integer, intent(in)  iq_cple,
real, intent(in)  depth,
real, intent(in)  grav_w 
)

Definition at line 9972 of file swmod3.f90.

9972 !------------------------------------------------------------------------------
9973 !
9974 ! +-------+ ALKYON Hydraulic Consultancy & Research
9975 ! | | Gerbrant van Vledder
9976 ! | +---+
9977 ! | | +---+ Last update: 10 Sept. 2002
9978 ! +---+ | | Release: 5.0
9979 ! +---+
9980 !
9981 !
9982 ! SWAN (Simulating WAves Nearshore); a third generation wave model
9983 ! Copyright (C) 2004-2005 Delft University of Technology
9984 !
9985 ! This program is free software; you can redistribute it and/or
9986 ! modify it under the terms of the GNU General Public License as
9987 ! published by the Free Software Foundation; either version 2 of
9988 ! the License, or (at your option) any later version.
9989 !
9990 ! This program is distributed in the hope that it will be useful,
9991 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
9992 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9993 ! GNU General Public License for more details.
9994 !
9995 ! A copy of the GNU General Public License is available at
9996 ! http://www.gnu.org/copyleft/gpl.html#SEC3
9997 ! or by writing to the Free Software Foundation, Inc.,
9998 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
9999 !
10000 !
10001  implicit none
10002 !
10003 ! 0. Update history
10004 !
10005 ! 25/02/1999 Initial version
10006 ! 25/10/1999 Names of some variables modified
10007 ! type and depth via interface
10008 ! 09/08/2002 Upgrade to release 4.0
10009 ! 10/09/2002 g included in interface
10010 !
10011 ! 1. Purpose:
10012 !
10013 ! Compute coupling coefficient between a quadruplet of
10014 ! interacting wave numbers
10015 !
10016 ! 2. Method
10017 !
10018 !
10019 ! 3. Parameter list:
10020 !
10021 ! Name I/O Type Description
10022 !
10023 !Type I/O Name Description
10024 !-----------------------------------------------------------------------------
10025  real, intent(in) :: k1x ! x-component of wave number k1
10026  real, intent(in) :: k1y ! y-component of wave number k1
10027  real, intent(in) :: k2x ! x-component of wave number k2
10028  real, intent(in) :: k2y ! y-component of wave number k2
10029  real, intent(in) :: k3x ! x-component of wave number k3
10030  real, intent(in) :: k3y ! y-component of wave number k3
10031  real, intent(in) :: k4x ! x-component of wave number k4
10032  real, intent(in) :: k4y ! y-component of wave number k4
10033  integer, intent(in) :: iq_cple ! Type of coupling coefficient
10034  real, intent(in) :: depth ! Water depth in meters
10035  real, intent(in) :: grav_w ! Gravitational acceleration
10036 !
10037 ! 4. Error messages
10038 !
10039 ! 5. Called by:
10040 !
10041 ! Q_CMPLOCUS
10042 !
10043 ! 6. Subroutines used
10044 !
10045 ! X_WEBB
10046 ! X_HH
10047 !
10048 ! 7. Remarks
10049 !
10050 ! 8. Structure
10051 !
10052 ! 9. Switches
10053 !
10054 ! 10. Source code:
10055 !-------------------------------------------------------------------------------
10056 ! Local variables
10057 ! ! real functions to compute coupling coefficient
10058 !!real xc_webb ! Webb, deep water
10059 !!real xc_hh ! Herterich and Hasselmann, finite depth
10060 !------------------------------------------------------------------------------
10061  if (iq_cple < 1 .or. iq_cple > 4) then
10062  x_cple = 0.
10063  goto 9999
10064  end if
10065 !
10066  select case(iq_cple)
10067 !
10068 ! 1) Deep water coupling coefficient of Webb
10069 !
10070  case(1)
10071  x_cple = xc_webb(k1x,k1y,k2x,k2y,k3x,k3y,k4x,k4y,grav_w)
10072 !
10073 ! 2) finite depth coupling coefficient of Herterich and Hasselmann
10074 ! as implemented in the Resio-Tracy program SB5
10075 !
10076  case(2)
10077  x_cple = xc_hh(k4x,k4y,k3x,k3y,k2x,k2y,k1x,k1y,depth)
10078 !
10079 ! x_cple = xc_hh2(k1x,k1y,k2x,k2y,k3x,k3y,depth,grav_w)
10080 !
10081  end select
10082 !
10083  9999 continue
10084 !
10085  return
swcomm3::grav_w
real grav_w
Definition: swmod1.f90:1721
m_genarr::depth
real, dimension(:), allocatable, save depth
Definition: swmod2.f90:768
Here is the call graph for this function:
Here is the caller graph for this function:

◆ x_disper()

real function m_xnldata::x_disper ( real, intent(in)  k,
real, intent(in)  d 
)

Definition at line 10320 of file swmod3.f90.

10320 !------------------------------------------------------------------------------
10321 !
10322 ! +-------+ ALKYON Hydraulic Consultancy & Research
10323 ! | | Gerbrant van Vledder
10324 ! | +---+
10325 ! | | +---+ Last update: 9 Aug. 2002
10326 ! +---+ | | Release: 4.0
10327 ! +---+
10328 !
10329 !
10330 ! SWAN (Simulating WAves Nearshore); a third generation wave model
10331 ! Copyright (C) 2004-2005 Delft University of Technology
10332 !
10333 ! This program is free software; you can redistribute it and/or
10334 ! modify it under the terms of the GNU General Public License as
10335 ! published by the Free Software Foundation; either version 2 of
10336 ! the License, or (at your option) any later version.
10337 !
10338 ! This program is distributed in the hope that it will be useful,
10339 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
10340 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10341 ! GNU General Public License for more details.
10342 !
10343 ! A copy of the GNU General Public License is available at
10344 ! http://www.gnu.org/copyleft/gpl.html#SEC3
10345 ! or by writing to the Free Software Foundation, Inc.,
10346 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
10347 !
10348 !
10349 ! do not use m_xnldata
10350  implicit none
10351 !
10352 ! 0. Update history
10353 !
10354 ! 16/02/1999 Initial version
10355 ! 25/02/1999 Short cut if kd > 10
10356 ! 09/08/2002 Upgrade to release 4.0
10357 !
10358 ! 1. Purpose:
10359 !
10360 ! Compute radian frequency for a given wave number and water depth
10361 !
10362 ! 2. Method
10363 !
10364 ! Depending on the value of the parameter iq_disp the radian
10365 ! wave number is computed as:
10366 ! 1) deep water
10367 ! 2) finite depth linear dispersion relation
10368 ! 3) finited depth non-linear dispersion relation (NOT YET implemented)
10369 !
10370 ! 3. Parameter list:
10371 !
10372 ! Type I/O Name Description
10373 !----------------------------------------------------------------------
10374  real, intent(in) :: k ! wave number
10375  real, intent(in) :: d ! water depth in m
10376 !
10377 ! 4. Error messages
10378 !
10379 ! if iq_type not valid, then q_disper = -1
10380 !
10381 ! 5. Called by:
10382 !
10383 ! Q_CHKRES
10384 !
10385 ! 6. Subroutines used
10386 !
10387 !
10388 ! 7. Remarks
10389 !
10390 ! Type of dispersion relation is determined by the parameter IQ_DISP:
10391 !
10392 ! IQ_DISP==1 deep water linear disperion relation is used
10393 ! 2 finite depth linear dispersion relation is used
10394 !
10395 ! 8. Structure
10396 !
10397 ! 9. Switches
10398 !
10399 ! 10. Source code
10400 !------------------------------------------------------------------------------
10401 ! Local variables
10402 !
10403  integer id ! copy of iq_type
10404  real kd ! k*d
10405 !
10406  kd = k * d
10407  id = iq_disp
10408 !
10409  if (kd > 20.) id = 1
10410 !
10411  select case(id)
10412  case (1) ! deep water w^2=g k
10413  x_disper = sqrt(q_grav*k)
10414  case (2) ! finite depth w^2 = g k tanh(k d)
10415  x_disper = sqrt(q_grav*k*tanh(k*d))
10416  case default
10417  x_disper = -1.
10418  end select
10419 !
10420  return
all_vars::d
real(sp), dimension(:), allocatable, target d
Definition: mod_main.f90:1132
Here is the caller graph for this function:

◆ x_flocus()

real function m_xnldata::x_flocus ( real, intent(in)  kxx,
real, intent(in)  kyy 
)

Definition at line 10089 of file swmod3.f90.

10089 !------------------------------------------------------------------------------
10090 !
10091 ! +-------+ ALKYON Hydraulic Consultancy & Research
10092 ! | | Gerbrant van Vledder
10093 ! | +---+
10094 ! | | +---+ Last update: 9 Aug. 2002
10095 ! +---+ | | Release: 4.0
10096 ! +---+
10097 !
10098 !
10099 ! SWAN (Simulating WAves Nearshore); a third generation wave model
10100 ! Copyright (C) 2004-2005 Delft University of Technology
10101 !
10102 ! This program is free software; you can redistribute it and/or
10103 ! modify it under the terms of the GNU General Public License as
10104 ! published by the Free Software Foundation; either version 2 of
10105 ! the License, or (at your option) any later version.
10106 !
10107 ! This program is distributed in the hope that it will be useful,
10108 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
10109 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10110 ! GNU General Public License for more details.
10111 !
10112 ! A copy of the GNU General Public License is available at
10113 ! http://www.gnu.org/copyleft/gpl.html#SEC3
10114 ! or by writing to the Free Software Foundation, Inc.,
10115 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
10116 !
10117 !
10118 ! do not use m_xnldata
10119  use m_constants
10120  implicit none
10121 !
10122 ! 0. Update history
10123 !
10124 ! 25/02/1999 Initial version
10125 ! 20/07/1999 Bug fixed when IDISP=2
10126 ! 09/10/1999 Values of w2 and w4 in double precision
10127 ! to improve accuracy of computation of z
10128 ! 09/08/2002 Upgrade to release 4.0
10129 !
10130 ! 1. Purpose:
10131 !
10132 ! Compute locus function used for the determination of the
10133 ! resonance condition
10134 !
10135 ! 2. Method
10136 !
10137 ! Explicit function evaluation
10138 !
10139 ! 3. Parameter list:
10140 !
10141 !Type I/O Name Description
10142 !-----------------------------------------------------------
10143  real, intent(in) :: kxx ! x-component of wave number
10144  real, intent(in) :: kyy ! y-component of wave number
10145 !
10146 ! 4. Error messages
10147 !
10148 !
10149 ! 5. Called by:
10150 !
10151 ! Q_LOCPOS
10152 !
10153 ! 6. Subroutines used
10154 !
10155 ! X_DISPER
10156 !
10157 ! 7. Remarks
10158 !
10159 ! if iq_disp not valid, then q_disper = -1
10160 !
10161 ! 8. Structure
10162 !
10163 ! 9. Switches
10164 !
10165 ! 10. Source code:
10166 !-------------------------------------------------------------------------------
10167 ! Local variables
10168 !
10169  real z ! diferrence
10170  real k2m,k4m ! wave number magnitudes
10171  real (kind=8) w2,w4 ! radian frequencies
10172 !! real x_disper
10173 !------------------------------------------------------------------------------
10174 ! call q_stack('+x_flocus')
10175 !
10176  select case(iq_disp)
10177  case (1)
10178  w2 = sqrtg * (kxx**2 + kyy**2)**(0.25)
10179  w4 = sqrtg * ((kxx+px)**2 + (kyy+py)**2)**(0.25)
10180  z = q + w2 - w4
10181 !
10182  case (2)
10183  k2m = sqrt(kxx**2+kyy**2)
10184  k4m = sqrt((kxx+px)**2 + (kyy+py)**2)
10185  w2 = x_disper(k2m,q_depth)
10186  w4 = x_disper(k4m,q_depth)
10187  z = q + w2 - w4
10188 !
10189  case default
10190  z = -1
10191  end select
10192 !
10193  x_flocus = z
10194 !
10195 !call q_stack('-x_flocus')
10196 !
10197  return
m_constants
Definition: swmod3.f90:22
all_vars::z
real(sp), dimension(:,:), allocatable, target z
Definition: mod_main.f90:1090
m_constants::sqrtg
real sqrtg
Definition: swmod3.f90:27
Here is the call graph for this function:
Here is the caller graph for this function:

◆ x_jacobian()

real function m_xnldata::x_jacobian ( real, intent(in)  x2,
real, intent(in)  y2,
real, intent(in)  x4,
real, intent(in)  y4 
)

Definition at line 10201 of file swmod3.f90.

10201 !------------------------------------------------------------------------------
10202 !
10203 ! +-------+ ALKYON Hydraulic Consultancy & Research
10204 ! | | Gerbrant van Vledder
10205 ! | +---+
10206 ! | | +---+ Last update: 9 Aug. 2002
10207 ! +---+ | | Release: 4.0
10208 ! +---+
10209 !
10210 !
10211 ! SWAN (Simulating WAves Nearshore); a third generation wave model
10212 ! Copyright (C) 2004-2005 Delft University of Technology
10213 !
10214 ! This program is free software; you can redistribute it and/or
10215 ! modify it under the terms of the GNU General Public License as
10216 ! published by the Free Software Foundation; either version 2 of
10217 ! the License, or (at your option) any later version.
10218 !
10219 ! This program is distributed in the hope that it will be useful,
10220 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
10221 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10222 ! GNU General Public License for more details.
10223 !
10224 ! A copy of the GNU General Public License is available at
10225 ! http://www.gnu.org/copyleft/gpl.html#SEC3
10226 ! or by writing to the Free Software Foundation, Inc.,
10227 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
10228 !
10229 !
10230 ! do not use m_xnldata
10231 !% use serv_xnl4v5, only: z_cmpcg
10232 !
10233  implicit none
10234 !
10235 ! 0. Update history
10236 !
10237 ! 25/02/1999 Initial version
10238 ! 12/10/1999 Overflow avoided by checking for argument k*d
10239 ! 29/10/1999 Bug fixed in computing finite depth gradient
10240 ! 27/12/1999 Factor SQRT(Grav) added
10241 ! 01/10/2001 Components of k4 wave number explicitly input
10242 ! New version of function X_GRAD
10243 ! 09/08/2002 Computation of Jacobian replace by |cg2-cg4|
10244 ! based on old routine X_GRAD2
10245 ! Upgrade to release 4.0
10246 !
10247 ! 1. Purpose:
10248 !
10249 ! Compute gradient/Jacobian term for a given point on the locus
10250 !
10251 ! 2. Method
10252 !
10253 ! Explicit expressions for gradient term
10254 ! Using expression of Rasmussen (1998)
10255 ! J = |cg2-cg4|
10256 !
10257 ! 3. Parameter list:
10258 !
10259 ! Type I/O Name Description
10260 !--------------------------------------------------------------------
10261  real, intent(in) :: x2 ! x-component of wave number k2
10262  real, intent(in) :: y2 ! y-component of wave number k2
10263  real, intent(in) :: x4 ! x-component of wave number k4
10264  real, intent(in) :: y4 ! y-component of wave number k4
10265 !
10266 ! 4. Error messages
10267 !
10268 ! 5. Called by:
10269 !
10270 ! Q_CMPLOCUS
10271 !
10272 ! 6. Subroutines used:
10273 !
10274 ! 7. Remarks
10275 !
10276 ! 8. Structure
10277 !
10278 ! 9. Switches
10279 !
10280 ! 10. Source code:
10281 !------------------------------------------------------------------------------
10282 ! local variables
10283 !
10284  real k2m,k4m ! wave number magnitudes
10285  real k2md,k4md ! k*d values
10286  real ang2,ang4 ! directions
10287  real cg2,cg4 ! group velocities
10288  real sig2,sig4 ! radian frequencies
10289 !------------------------------------------------------------------------------
10290  k2m = sqrt(x2**2 + y2**2)
10291  k4m = sqrt(x4**2 + y4**2)
10292 !
10293  ang2 = atan2(x2,y2)
10294  ang4 = atan2(x4,y4)
10295 !
10296  sig2 = sqrt(q_grav*k2m*tanh(k2m*q_depth))
10297  sig4 = sqrt(q_grav*k4m*tanh(k4m*q_depth))
10298 !
10299  k2md = k2m*q_depth
10300  k4md = k4m*q_depth
10301 !
10302  if(k2md > 20) then
10303  cg2 = 0.5*q_grav/sig2
10304  else
10305  cg2 = sig2/k2m*(0.5+k2md/sinh(2*k2md))
10306  end if
10307 !
10308  if(k4md > 20) then
10309  cg4 = 0.5*q_grav/sig4
10310  else
10311  cg4 = sig4/k4m*(0.5+k4md/sinh(2*k4md))
10312  end if
10313 !
10314  x_jacobian = sqrt(cg2**2+cg4**2-2*cg2*cg4*cos(ang2-ang4))
10315 !
10316  return
Here is the caller graph for this function:

◆ x_locus1()

real function m_xnldata::x_locus1 ( real, intent(in)  k2)

Definition at line 5587 of file swmod3.f90.

5587 !------------------------------------------------------------------------------
5588 !
5589 ! +-------+ ALKYON Hydraulic Consultancy & Research
5590 ! | | Gerbrant van Vledder
5591 ! | +---+
5592 ! | | +---+ Last update: 9 AUg. 2002
5593 ! +---+ | | Release: 4.0
5594 ! +---+
5595 !
5596 !
5597 ! SWAN (Simulating WAves Nearshore); a third generation wave model
5598 ! Copyright (C) 2004-2005 Delft University of Technology
5599 !
5600 ! This program is free software; you can redistribute it and/or
5601 ! modify it under the terms of the GNU General Public License as
5602 ! published by the Free Software Foundation; either version 2 of
5603 ! the License, or (at your option) any later version.
5604 !
5605 ! This program is distributed in the hope that it will be useful,
5606 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
5607 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
5608 ! GNU General Public License for more details.
5609 !
5610 ! A copy of the GNU General Public License is available at
5611 ! http://www.gnu.org/copyleft/gpl.html#SEC3
5612 ! or by writing to the Free Software Foundation, Inc.,
5613 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
5614 !
5615 !
5616 ! do not use m_xnldata
5617  use m_constants
5618  implicit none
5619 !
5620 ! 0. Update history
5621 !
5622 ! Date Description
5623 !
5624 ! 23/11/1999 Initial version
5625 ! 9/08/2002 Upgrade to release 4.0
5626 !
5627 ! 1. Purpose:
5628 !
5629 ! Compute locus function along symmetry axis
5630 !
5631 ! 2. Method
5632 !
5633 ! See ALKYON, 1999
5634 !
5635 ! 3. Parameter list:
5636 !
5637 !Type I/O name Description
5638 !-------------------------------------------------------
5639  real, intent(in) :: k2 ! Magnitude of wave number k2
5640 !
5641 ! 4. Error messages
5642 !
5643 ! 5. Called by:
5644 !
5645 ! Q_LOCPOS
5646 !
5647 ! 6. Subroutines used
5648 !
5649 ! x_disper
5650 !
5651 ! 7. Remarks
5652 !
5653 ! The routine assumes that w1 < w3 or q<0
5654 ! implying that the directions of k2 and P are opposite
5655 !
5656 ! 8. Structure
5657 !
5658 ! 9. Switches
5659 !
5660 ! 10. Source code
5661 !------------------------------------------------------------------------------
5662 ! Local variables
5663 !
5664  real k4 ! wave number magnitudes of k4
5665  real w2,w4 ! radian frequencies of wave numbers k2 and k4
5666  real z ! function value
5667 !
5668 !! real x_disper
5669 !
5670  select case(iq_disp)
5671  case (1)
5672  w2 = sqrtg * sqrt(k2)
5673  w4 = sqrtg * sqrt(abs(-pmag+k2))
5674  z = q + w2 - w4
5675 !
5676  case (2)
5677  k4 = abs(-pmag+k2)
5678  w2 = x_disper(k2,q_depth)
5679  w4 = x_disper(k4,q_depth)
5680  z = q + w2 - w4
5681 !
5682  case default
5683  z = -1
5684  end select
5685 !
5686  x_locus1 = z
5687 !
5688  return
mod_time::abs
Definition: mod_time.f90:64
m_constants
Definition: swmod3.f90:22
all_vars::z
real(sp), dimension(:,:), allocatable, target z
Definition: mod_main.f90:1090
m_constants::sqrtg
real sqrtg
Definition: swmod3.f90:27
Here is the call graph for this function:
Here is the caller graph for this function:

◆ x_locus2()

real function m_xnldata::x_locus2 ( real, intent(in)  lambda)

Definition at line 5693 of file swmod3.f90.

5693 !------------------------------------------------------------------------------
5694 !
5695 ! +-------+ ALKYON Hydraulic Consultancy & Research
5696 ! | | Gerbrant van Vledder
5697 ! | +---+
5698 ! | | +---+ Last update: 9 Aug. 2002
5699 ! +---+ | | Release: 4.0
5700 ! +---+
5701 !
5702 !
5703 ! SWAN (Simulating WAves Nearshore); a third generation wave model
5704 ! Copyright (C) 2004-2005 Delft University of Technology
5705 !
5706 ! This program is free software; you can redistribute it and/or
5707 ! modify it under the terms of the GNU General Public License as
5708 ! published by the Free Software Foundation; either version 2 of
5709 ! the License, or (at your option) any later version.
5710 !
5711 ! This program is distributed in the hope that it will be useful,
5712 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
5713 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
5714 ! GNU General Public License for more details.
5715 !
5716 ! A copy of the GNU General Public License is available at
5717 ! http://www.gnu.org/copyleft/gpl.html#SEC3
5718 ! or by writing to the Free Software Foundation, Inc.,
5719 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
5720 !
5721 !
5722 ! do not use m_xnldata
5723  use m_constants
5724  implicit none
5725 !
5726 ! 0. Update history
5727 !
5728 ! Date Description
5729 !
5730 ! 23/11/1999 Initial version
5731 ! 09/08/2002 Upgrade to release 4.0
5732 !
5733 ! 1. Purpose:
5734 !
5735 ! Compute locus function perpendicluar to symmetry axis
5736 !
5737 ! 2. Method
5738 !
5739 ! See ALKYON, 1999
5740 !
5741 ! 3. Parameter list:
5742 !
5743 ! Name I/O Type Description
5744 !
5745  real, intent(in) :: lambda
5746 !
5747 ! 4. Error messages
5748 !
5749 ! 5. Called by:
5750 !
5751 ! Q_LOCPOS
5752 !
5753 ! 6. Subroutines used
5754 !
5755 ! x_disper
5756 !
5757 ! 7. Remarks
5758 !
5759 ! The routine assumes that w1 < w3 or q<0
5760 ! implying that the directions of k2 and P are opposite
5761 !
5762 ! 8. Structure
5763 !
5764 ! 9. Switches
5765 !
5766 ! 10. Source code:
5767 !------------------------------------------------------------------------------
5768 ! local variables
5769 !
5770  real kk2x,kk2y,kk2m ! wave number components and magnitude for k2
5771  real kk4x,kk4y,kk4m ! wave number components and magnitude for k4
5772  real w2,w4 ! radian frequencies of wave numbers k2 and k4
5773  real z ! function value
5774 !! real x_disper
5775  kk2x = kmidx - lambda*py
5776  kk2y = kmidy + lambda*px
5777  kk2m = sqrt(kk2x**2 + kk2y**2)
5778 !
5779  kk4x = kk2x + px
5780  kk4y = kk2y + py
5781  kk4m = sqrt(kk4x**2 + kk4y**2)
5782 !
5783  select case(iq_disp)
5784  case (1)
5785  w2 = sqrtg * sqrt(kk2m)
5786  w4 = sqrtg * sqrt(kk4m)
5787  z = q + w2 - w4
5788 !
5789  case (2)
5790 !
5791  w2 = x_disper(kk2m,q_depth)
5792  w4 = x_disper(kk4m,q_depth)
5793  z = q + w2 - w4
5794 !
5795  case default
5796  z = -1
5797  end select
5798 !
5799  x_locus2 = z
5800 !
5801  return
m_constants
Definition: swmod3.f90:22
m_snl4::lambda
real, dimension(:), allocatable, save, public lambda
Definition: swmod2.f90:373
all_vars::z
real(sp), dimension(:,:), allocatable, target z
Definition: mod_main.f90:1090
m_constants::sqrtg
real sqrtg
Definition: swmod3.f90:27
Here is the call graph for this function:
Here is the caller graph for this function:

◆ xc_hh()

real function m_xnldata::xc_hh ( real  w1x0,
real  w1y0,
real  w2x0,
real  w2y0,
real  w3x0,
real  w3y0,
real  z4x,
real  z4y,
real  h 
)

Definition at line 10428 of file swmod3.f90.

10428 !------------------------------------------------------------------------------
10429 !
10430 ! factor EPS included
10431 !
10432  implicit none
10433 !
10434  real z4x,z4y ! dummy arguments
10435 !
10436  real w1x0,w1y0,w2x0,w2y0,w3x0,w3y0,h,dsq
10437  real om1,om2,om3,om4,scpl1,scpl2,scpl3,stot
10438  real t1,t2,t3,t4,t5,tot1,tot2,tot3,tot4,tot5
10439  real som1,som2,som3
10440  real s1,s2,s3,z1,z2,z3,z4,z5
10441  real p1,p2,p3,p4,di,tnz1,tnz2,tnz3,tnz23
10442  real csz1,csz2,csz3,csz23
10443  real e,g,gsq,omsq23,pi4
10444  real dot123,dot23
10445 !! real cosz,tanz
10446 !
10447  real eps
10448 !
10449 
10450 ! calculates coupling coefficient in shallow water given k1,k2,k3
10451  real k1,k2,k3,k1x,k2x,k3x,k1y,k2y,k3y,k23x,k23y,k23,k1x0,k1y0, &
10452  k2x0,k2y0,k3x0,k3y0,k1zx,k1zy
10453  data pi4/0.785398163/
10454 !
10455  eps = 1.e-20
10456  g = 9.81
10457 !
10458  z4x = z4x
10459  z4y = z4y
10460 !
10461 ! print *,'entering cplesh depth = ',h
10462  k1x0=w1x0
10463  k1y0=w1y0
10464  k2x0=w2x0
10465  k2y0=w2y0
10466  k3x0=w3x0
10467  k3y0=w3y0
10468 
10469  tot1=0.
10470  tot2=0.
10471  tot3=0.
10472  tot4=0.
10473  tot5=0.
10474  z1=0.
10475  z2=0.
10476  z3=0.
10477  z4=0.
10478  z5=0.
10479  g=9.81
10480  gsq=g*g
10481 
10482  s1=1.
10483  s2=1.
10484  s3=-1.
10485 
10486 
10487  k1x=s1*k1x0
10488  k1y=s1*k1y0
10489  k2x=s2*k2x0
10490  k2y=s2*k2y0
10491  k3x=s3*k3x0
10492  k3y=s3*k3y0
10493 
10494  k1=sqrt(k1x**2+k1y**2)
10495  k2=sqrt(k2x**2+k2y**2)
10496  k3=sqrt(k3x**2+k3y**2)
10497 
10498  tnz1=tanz(k1*h)
10499  tnz2=tanz(k2*h)
10500  tnz3=tanz(k3*h)
10501  csz1=cosz(k1*h)
10502  csz2=cosz(k2*h)
10503  csz3=cosz(k3*h)
10504  om1=sqrt(g*k1*tnz1)
10505  om2=sqrt(g*k2*tnz2)
10506  om3=sqrt(g*k3*tnz3)
10507 
10508  som1=s1*om1
10509  som2=s2*om2
10510  som3=s3*om3
10511  dot23=k2x*k3x+k2y*k3y
10512 
10513  k23x=k2x+k3x
10514  k23y=k2y+k3y
10515  k23=sqrt(k23x**2+k23y**2)
10516  tnz23=tanz(k23*h)
10517  csz23=cosz(k23*h)
10518 
10519  omsq23=g*k23*tnz23
10520  dot123=k1x*k23x+k1y*k23y
10521 
10522 ! note the "i**2" factor is included in this term
10523  di=-(som2+som3)*(k2*k3*tnz2*tnz3-dot23) &
10524  +0.5*(som2*k3**2/(csz3)**2+som3*k2**2/(csz2)**2)
10525 
10526  e=0.5/g *(dot23-som2*som3/gsq*(om2**2+om3**2+som2*som3))
10527 
10528  p1=2.*(som1+som2+som3)*(om1**2.*omsq23/gsq-dot123)
10529 
10530  p2=-som1*(k23)**2/(csz23)**2
10531 
10532  p3=-(som2+som3)*k1**2/(csz1)**2
10533 
10534  z1=z1+di
10535  z2=z2+omsq23-(som2+som3)**2
10536  z3=z3+p1
10537  z4=z4+p2
10538  z5=z5+p3
10539  t1=di/(omsq23-(som2+som3)**2 + eps ) * (p1+p2+p3)
10540 
10541  t2=-di*som1/gsq *(om1**2+omsq23)
10542 
10543  p4=g*k1**2/(csz1)**2
10544 
10545  t3=e*(som1**3*(som2+som3)/g - g*dot123 - p4)
10546 
10547  t4=0.5*som1/gsq*dot23*((som1+som2+som3)*(om2**2+om3**2) &
10548  +som2*som3*(som2+som3))
10549 
10550  t5=-0.5*som1*om2**2*k3**2/gsq*(som1+som2+2.*som3) &
10551  -0.5*som1*om3**2*k2**2/gsq*(som1+2.*som2+som3)
10552 
10553  scpl1=t1+t2+t3+t4+t5
10554  tot1=tot1+t1
10555  tot2=tot2+t2
10556  tot3=tot3+t3
10557  tot4=tot4+t4
10558  tot5=tot5+t5
10559 
10560  s1=1.
10561  s2=-1.
10562  s3=1.
10563  k1zx=k1x0
10564  k1zy=k1y0
10565  k1x0=k2x0
10566  k1y0=k2y0
10567  k2x0=k3x0
10568  k2y0=k3y0
10569  k3x0=k1zx
10570  k3y0=k1zy
10571 
10572 
10573  k1x=s1*k1x0
10574  k1y=s1*k1y0
10575  k2x=s2*k2x0
10576  k2y=s2*k2y0
10577  k3x=s3*k3x0
10578  k3y=s3*k3y0
10579 
10580  k1=sqrt(k1x**2+k1y**2)
10581  k2=sqrt(k2x**2+k2y**2)
10582  k3=sqrt(k3x**2+k3y**2)
10583  tnz1=tanz(k1*h)
10584  tnz2=tanz(k2*h)
10585  tnz3=tanz(k3*h)
10586  csz1=cosz(k1*h)
10587  csz2=cosz(k2*h)
10588  csz3=cosz(k3*h)
10589  om1=sqrt(g*k1*tnz1)
10590  om2=sqrt(g*k2*tnz2)
10591  om3=sqrt(g*k3*tnz3)
10592  som1=s1*om1
10593  som2=s2*om2
10594  som3=s3*om3
10595  dot23=k2x*k3x+k2y*k3y
10596  k23x=k2x+k3x
10597  k23y=k2y+k3y
10598  k23=sqrt(k23x**2+k23y**2)
10599  tnz23=tanz(k23*h)
10600  csz23=cosz(k23*h)
10601  omsq23=g*k23*tnz23
10602  dot123=k1x*k23x+k1y*k23y
10603 
10604 ! note the "i**2" factor is included in this term
10605  di=-(som2+som3)*(k2*k3*tnz2*tnz3-dot23) &
10606  +0.5*(som2*k3**2/(csz3)**2+som3*k2**2/(csz2)**2)
10607 
10608  e=0.5/g *(dot23-som2*som3/gsq *(om2**2+om3**2+som2*som3))
10609 
10610  p1=2.*(som1+som2+som3)*(om1**2.*omsq23/gsq-dot123)
10611 
10612  p2=-som1*(k23)**2/(csz23)**2
10613 
10614  p3=-(som2+som3)*k1**2/(csz1)**2
10615  z1=z1+di
10616  z2=z2+omsq23-(som2+som3)**2
10617  z3=z3+p1
10618  z4=z4+p2
10619  z5=z5+p3
10620 
10621  t1=di/(omsq23-(som2+som3)**2) * (p1+p2+p3)
10622 
10623  t2=-di*som1/gsq *(om1**2+omsq23)
10624 
10625  p4=g*k1**2/(csz1)**2
10626 
10627  t3=e*(som1**3*(som2+som3)/g - g*dot123 - p4)
10628 
10629  t4=0.5*som1/gsq*dot23*((som1+som2+som3)*(om2**2+om3**2) &
10630  +som2*som3*(som2+som3))
10631 
10632  t5=-0.5*som1*om2**2*k3**2/gsq*(som1+som2+2.*som3) &
10633  -0.5*som1*om3**2*k2**2/gsq*(som1+2.*som2+som3)
10634 
10635  scpl2=t1+t2+t3+t4+t5
10636  tot1=tot1+t1
10637  tot2=tot2+t2
10638  tot3=tot3+t3
10639  tot4=tot4+t4
10640  tot5=tot5+t5
10641 
10642  s1=-1.
10643  s2=1.
10644  s3=1.
10645  k1zx=k1x0
10646  k1zy=k1y0
10647  k1x0=k2x0
10648  k1y0=k2y0
10649  k2x0=k3x0
10650  k2y0=k3y0
10651  k3x0=k1zx
10652  k3y0=k1zy
10653 
10654 
10655  k1x=s1*k1x0
10656  k1y=s1*k1y0
10657  k2x=s2*k2x0
10658  k2y=s2*k2y0
10659  k3x=s3*k3x0
10660  k3y=s3*k3y0
10661 
10662  k1=sqrt(k1x**2+k1y**2)
10663  k2=sqrt(k2x**2+k2y**2)
10664  k3=sqrt(k3x**2+k3y**2)
10665  tnz1=tanz(k1*h)
10666  tnz2=tanz(k2*h)
10667  tnz3=tanz(k3*h)
10668  csz1=cosz(k1*h)
10669  csz2=cosz(k2*h)
10670  csz3=cosz(k3*h)
10671  om1=sqrt(g*k1*tnz1)
10672  om2=sqrt(g*k2*tnz2)
10673  om3=sqrt(g*k3*tnz3)
10674  som1=s1*om1
10675  som2=s2*om2
10676  som3=s3*om3
10677  dot23=k2x*k3x+k2y*k3y
10678  k23x=k2x+k3x
10679  k23y=k2y+k3y
10680  k23=sqrt(k23x**2+k23y**2)
10681  tnz23=tanz(k23*h)
10682  csz23=cosz(k23*h)
10683  omsq23=g*k23*tnz23
10684  dot123=k1x*k23x+k1y*k23y
10685 
10686 ! note the "i**2" factor is included in this term
10687  di=-(som2+som3)*(k2*k3*tnz2*tnz3-dot23) &
10688  +0.5*(som2*k3**2/(csz3)**2+som3*k2**2/(csz2)**2)
10689 
10690  e=0.5/g *(dot23-som2*som3/gsq *(om2**2+om3**2+som2*som3))
10691 
10692  p1=2.*(som1+som2+som3)*(om1**2.*omsq23/gsq-dot123)
10693 
10694  p2=-som1*(k23)**2/(csz23)**2
10695 
10696  p3=-(som2+som3)*k1**2/(csz1)**2
10697  z1=z1+di
10698  z2=z2+omsq23-(som2+som3)**2
10699  z3=z3+p1
10700  z4=z4+p2
10701  z5=z5+p3
10702 
10703  t1=di/(omsq23-(som2+som3)**2) * (p1+p2+p3)
10704 
10705  t2=-di*som1/gsq*(om1**2+omsq23)
10706 
10707  p4=g*k1**2/(cosz(k1*h))**2
10708 
10709  t3=e*(som1**3*(som2+som3)/g - g*dot123 - p4)
10710 
10711  t4=0.5*som1/gsq*dot23*((som1+som2+som3)*(om2**2+om3**2) &
10712  +som2*som3*(som2+som3))
10713 
10714  t5=-0.5*som1*om2**2*k3**2/gsq*(som1+som2+2.*som3) &
10715  -0.5*som1*om3**2*k2**2/gsq*(som1+2.*som2+som3)
10716 
10717  scpl3=t1+t2+t3+t4+t5
10718  tot1=tot1+t1
10719  tot2=tot2+t2
10720  tot3=tot3+t3
10721  tot4=tot4+t4
10722  tot5=tot5+t5
10723 
10724  stot=(scpl1+scpl2+scpl3)
10725  om4=om2+om3-om1
10726  dsq=stot*stot*pi4*gsq/(om1*om2*om3*om4+eps) ! eps by GVV
10727  xc_hh = dsq
10728 !
10729 ! possible bug fixed
10730 !
10731  xc_hh = xc_hh*gsq
10732 !
10733  RETURN
all_vars::t2
real(sp), dimension(:,:), allocatable, target t2
Definition: mod_main.f90:1314
all_vars::h
real(sp), dimension(:), allocatable, target h
Definition: mod_main.f90:1131
all_vars::t1
real(sp), dimension(:,:), allocatable, target t1
Definition: mod_main.f90:1307
ice_constants::p4
real(kind=dbl_kind), parameter p4
Definition: ice_constants.f90:150
all_vars::s1
real(sp), dimension(:,:), allocatable, target s1
Definition: mod_main.f90:1308
m_constants::gsq
real gsq
Definition: swmod3.f90:28
ice_constants::p2
real(kind=dbl_kind), parameter p2
Definition: ice_constants.f90:150
ice_constants::p1
real(kind=dbl_kind), parameter p1
Definition: ice_constants.f90:150
all_vars::z1
real(sp), dimension(:,:), allocatable, target z1
Definition: mod_main.f90:1094
all_vars::s2
real(sp), dimension(:,:), allocatable, target s2
Definition: mod_main.f90:1316
Here is the call graph for this function:
Here is the caller graph for this function:

◆ xc_webb()

real function m_xnldata::xc_webb ( real, intent(in)  k1x,
real, intent(in)  k1y,
real, intent(in)  k2x,
real, intent(in)  k2y,
real, intent(in)  k3x,
real, intent(in)  k3y,
real, intent(in)  k4x,
real, intent(in)  k4y,
real, intent(in)  grav_w 
)

Definition at line 10755 of file swmod3.f90.

10755 !------------------------------------------------------------------------------
10756 !
10757 ! +-------+ ALKYON Hydraulic Consultancy & Research
10758 ! | | Gerbrant van Vledder
10759 ! | +---+
10760 ! | | +---+ Last update: 10 Sep. 2002
10761 ! +---+ | | Release: 5.0
10762 ! +---+
10763 !
10764 !
10765 ! SWAN (Simulating WAves Nearshore); a third generation wave model
10766 ! Copyright (C) 2004-2005 Delft University of Technology
10767 !
10768 ! This program is free software; you can redistribute it and/or
10769 ! modify it under the terms of the GNU General Public License as
10770 ! published by the Free Software Foundation; either version 2 of
10771 ! the License, or (at your option) any later version.
10772 !
10773 ! This program is distributed in the hope that it will be useful,
10774 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
10775 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10776 ! GNU General Public License for more details.
10777 !
10778 ! A copy of the GNU General Public License is available at
10779 ! http://www.gnu.org/copyleft/gpl.html#SEC3
10780 ! or by writing to the Free Software Foundation, Inc.,
10781 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
10782 !
10783 !
10784  implicit none
10785 !
10786 ! 0. Update history
10787 !
10788 ! 25/02/1999 Initial version
10789 ! 10/09/2002 Upgrade of documention and interface
10790 !
10791 ! 1. Purpose:
10792 !
10793 ! Compute deep water coupling coefficient for
10794 ! non-linear quadruplet interactions
10795 !
10796 !
10797 ! 2. Method
10798 !
10799 ! Webb (1978) and modified and corrected by Dungey and Hui (1979)
10800 !
10801 ! 3. Parameter list:
10802 !
10803 ! Type I/O Name Description
10804 !--------------------------------------------------------------------
10805  real, intent(in) :: k1x ! x-component of wave number k1
10806  real, intent(in) :: k1y ! y-component of wave number k1
10807  real, intent(in) :: k2x ! x-component of wave number k2
10808  real, intent(in) :: k2y ! y-component of wave number k2
10809  real, intent(in) :: k3x ! x-component of wave number k3
10810  real, intent(in) :: k3y ! y-component of wave number k3
10811  real, intent(in) :: k4x ! x-component of wave number k4
10812  real, intent(in) :: k4y ! y-component of wave number k4
10813  real, intent(in) :: grav_w ! gravitational acceleration m/s^2
10814 !
10815 ! 4. Error messages
10816 !
10817 ! 5. Called by:
10818 !
10819 ! X_CPLE
10820 !
10821 ! 6. Subroutines used:
10822 !
10823 ! 7. Remarks
10824 !
10825 ! 8. Structure
10826 !
10827 ! 9. Switches
10828 !
10829 ! 10. Source code:
10830 !------------------------------------------------------------------------------
10831 ! local variables
10832 !
10833 !
10834  double precision wsqp12 ! derived variable
10835  double precision wsqm13 ! derived variable
10836  double precision wsq13 ! derived variable
10837  double precision wsqm14 ! derived variable
10838  double precision wsq14 ! derived variable
10839  double precision wsq12 ! derived variable
10840  real z,z12,z13,z14 ! derived variables
10841  real dwebb ! final coefficient
10842  real p1,p2,p3,p4,p5,p6,p7,p8,p9 ! partial summations
10843  real w1,w2,w3,w4 ! radian frequencies
10844  real k1,k2,k3,k4 ! wave number magnitudes
10845  real dot12 ! k1*k2
10846  real dot13 ! k1*k3
10847  real dot14 ! k1*k4
10848  real dot23 ! k2*k3
10849  real dot24 ! k2*k4
10850  real dot34 ! k3*k4
10851  real pi_w ! pi
10852  real pi4 ! pi/4
10853  real eps ! internal accuracy
10854 !---------------------------------------------------------------------
10855 ! initialisations
10856 !---------------------------------------------------------------------
10857  pi_w = 4.*atan(1.)
10858  pi4 = 0.25*pi_w
10859 !
10860  eps = 1.0e-30
10861 !
10862  k1 = sqrt(k1x*k1x + k1y*k1y)
10863  k2 = sqrt(k2x*k2x + k2y*k2y)
10864  k3 = sqrt(k3x*k3x + k3y*k3y)
10865  k4 = sqrt(k4x*k4x + k4y*k4y)
10866 !
10867  w1 = sqrt(k1)
10868  w2 = sqrt(k2)
10869  w3 = sqrt(k3)
10870  w4 = sqrt(k4)
10871 !
10872  dot12 = k1x*k2x + k1y*k2y
10873  dot13 = k1x*k3x + k1y*k3y
10874  dot14 = k1x*k4x + k1y*k4y
10875  dot23 = k2x*k3x + k2y*k3y
10876  dot24 = k2x*k4x + k2y*k4y
10877  dot34 = k3x*k4x + k3y*k4y
10878 !
10879  wsqp12= sqrt((k1x+k2x)*(k1x+k2x)+(k1y+k2y)*(k1y+k2y))
10880  wsq12 = (w1+w2)*(w1+w2)
10881  wsqm13= sqrt((k1x-k3x)*(k1x-k3x)+(k1y-k3y)*(k1y-k3y))
10882  wsq13 = (w1-w3)*(w1-w3)
10883  wsqm14= sqrt((k1x-k4x)*(k1x-k4x)+(k1y-k4y)*(k1y-k4y))
10884  wsq14 = (w1-w4)*(w1-w4)
10885  z12 = wsqp12-wsq12
10886  z13 = wsqm13-wsq13
10887  z14 = wsqm14-wsq14
10888  z = 2.*wsq12*(k1*k2-dot12)*(k3*k4-dot34)
10889  p1 = z/(z12+eps)
10890  z = 2.*wsq13*(k1*k3+dot13)*(k2*k4+dot24)
10891  p2 = z/(z13+eps)
10892  z = 2.*wsq14*(k1*k4+dot14)*(k2*k3+dot23)
10893  p3 = z/(z14+eps)
10894  p4 = 0.5 *(dot12*dot34 + dot13*dot24 + dot14*dot23)
10895  p5 = 0.25*(dot13+dot24) * wsq13 * wsq13
10896  p6 = -0.25*(dot12+dot34) * wsq12 * wsq12
10897  p7 = 0.25*(dot14+dot23) * wsq14 * wsq14
10898  p8 = 2.5*k1*k2*k3*k4
10899  p9 = wsq12*wsq13*wsq14* (k1 + k2 + k3 + k4)
10900 !
10901  dwebb = p1 + p2 + p3 + p4 + p5 + p6 + p7 + p8 + p9
10902  xc_webb = grav_w**2*pi4*dwebb*dwebb/(w1*w2*w3*w4+eps)
10903 !
10904  return
swcomm3::grav_w
real grav_w
Definition: swmod1.f90:1721
ice_constants::p4
real(kind=dbl_kind), parameter p4
Definition: ice_constants.f90:150
swcomm3::pi_w
real pi_w
Definition: swmod1.f90:1721
ice_constants::p5
real(kind=dbl_kind), parameter p5
Definition: ice_constants.f90:150
ice_constants::p2
real(kind=dbl_kind), parameter p2
Definition: ice_constants.f90:150
ice_constants::p1
real(kind=dbl_kind), parameter p1
Definition: ice_constants.f90:150
all_vars::z
real(sp), dimension(:,:), allocatable, target z
Definition: mod_main.f90:1090
ice_constants::p6
real(kind=dbl_kind), parameter p6
Definition: ice_constants.f90:150
Here is the caller graph for this function:

◆ xnl_init()

subroutine m_xnldata::xnl_init ( real, dimension(nsigma), intent(in)  sigma,
real, dimension(ndir), intent(in)  dird,
integer, intent(in)  nsigma,
integer, intent(in)  ndir,
real, intent(in)  pftail,
real, intent(in)  x_grav,
real, dimension(ndepth), intent(in)  depth,
integer, intent(in)  ndepth,
integer, intent(in)  jquad,
integer, intent(in)  iqgrid,
integer, intent(out)  ierror 
)

Definition at line 1994 of file swmod3.f90.

1994 !------------------------------------------------------------------------------
1995 !
1996 ! +-------+ ALKYON Hydraulic Consultancy & Research
1997 ! | | Gerbrant van Vledder
1998 ! | +---+
1999 ! | | +---+ Last update: 6 May 2004
2000 ! +---+ | | Release: 5.03
2001 ! +---+
2002 !
2003 !
2004 ! SWAN (Simulating WAves Nearshore); a third generation wave model
2005 ! Copyright (C) 2004-2005 Delft University of Technology
2006 !
2007 ! This program is free software; you can redistribute it and/or
2008 ! modify it under the terms of the GNU General Public License as
2009 ! published by the Free Software Foundation; either version 2 of
2010 ! the License, or (at your option) any later version.
2011 !
2012 ! This program is distributed in the hope that it will be useful,
2013 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
2014 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2015 ! GNU General Public License for more details.
2016 !
2017 ! A copy of the GNU General Public License is available at
2018 ! http://www.gnu.org/copyleft/gpl.html#SEC3
2019 ! or by writing to the Free Software Foundation, Inc.,
2020 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
2021 !
2022 !
2023  use m_fileio
2024  use m_constants
2025 ! do not use m_xnldata
2026 !
2027  implicit none
2028 !
2029 ! 0. Update history
2030 !
2031 ! 10/01/2001 Initial version
2032 ! 14/02/2001 Release 3
2033 ! 06/11/2001 Depth forced to 1000 when iquad ==1,2
2034 ! 08/08/2002 Upgrade to version 4
2035 ! 19/08/2002 Extra test output
2036 ! 22/08/2002 User defined directions stored in Quad-system
2037 ! 26/08/2002 Minimum water depth in variable q_mindepth
2038 ! 09/09/2002 Initialized LASTQUADFILE
2039 ! 10/09/2002 Initialisation of Q_DSTEP
2040 ! 11/09/2002 Called of Q_ALLOC moved to location after Q_SETCFG
2041 ! Output unit luq_fil added
2042 ! 16/09/2002 Parameter IPROC added to take are of MPI
2043 ! 25/09/2002 Check added for directions of sector grid
2044 ! 25/04/2003 name q_alloc changed to q_allocate
2045 ! 04/06/2003 variable IQ_INT renamed IQ_INTEG
2046 ! 11/06/2003 Call to Q_SETCFG changed into Q_SETCONFIG
2047 ! Call to Q_CHKCFG changed into Q_CHKCONFIG
2048 ! Call to subroutine Q_SUMMARY added
2049 ! Compute size of points on locus, stored in KLOCUS
2050 ! 13/06/2003 Test parameters moved to Q_SETCONFIG
2051 ! 04/09/2003 Routine Q_SETVERSION added
2052 ! 27/04/2004 Check added for directions of sector grid
2053 ! 06/05/2004 Initialisation of IQ_INTERP removed
2054 !
2055 ! 1. Purpose:
2056 !
2057 ! Initialize coefficients, integration space, file i/o for computation
2058 ! nonlinear quadruplet wave-wave interaction
2059 !
2060 ! 2. Method
2061 !
2062 ! Set version number
2063 ! Set unit unit numbers
2064 ! Open quad related files
2065 ! Optionally reset configuration by a back door option
2066 ! Compute integration spaces for given water depths
2067 !
2068 ! 3. Parameter list:
2069 !
2070 !Type I/O Name Description
2071 !------------------------------------------------------------------------------
2072  integer, intent(in) :: nsigma ! Number of sigma values
2073  integer, intent(in) :: ndir ! Number of directions
2074  integer, intent(in) :: ndepth ! Number of water depths
2075  real, intent(in) :: sigma(nsigma) ! Radian frequencies
2076  real, intent(in) :: dird(ndir) ! Directions (degrees)
2077  real, intent(in) :: pftail ! power of spectral tail, e.g. -4 or -5
2078  real, intent(in) :: depth(ndepth) ! depths for which integration space must be computed
2079  real, intent(in) :: x_grav ! gravitational acceleration
2080  integer, intent(in) :: jquad ! Type of method for computing nonlinear interactions
2081  integer, intent(in) :: iqgrid ! Type of grid for computing nonlinear interactions
2082 ! integer, intent(in) :: iproc ! Processor number, controls output file for MPI
2083  integer, intent(out) :: ierror ! Error indicator. If no errors are detected IERR=0
2084 !
2085 ! 4. Error messages
2086 !
2087 ! An error message is produced within the QUAD system.
2088 ! If no errors are detected IERROR=0
2089 ! otherwise IERROR > 0
2090 !
2091 ! ierr Description of error
2092 ! -------------------------------
2093 ! 1 Invalid value of iquad
2094 ! 2 Invalid value of iq_grid
2095 ! 31 Incompatability between iq_grid and input directions for circle grid
2096 ! 32 Incompatability between iq_grid and input directions for sector grid grid
2097 ! 4 Error in deleting *.ERR file
2098 ! 5 Error generated by Q_SETCONFIG
2099 ! 6 Error generated by Q_CHKCFG
2100 ! 7 Error generated by Q_CTRGRID
2101 !
2102 ! 5. Called by:
2103 !
2104 ! host program, e.g. SWANQUAD5
2105 !
2106 ! 6. Subroutines used:
2107 !
2108 ! Q_SETVERSION
2109 ! Q_SETCONFIG
2110 ! Q_CHKCFG
2111 ! Q_SUMMARY
2112 ! Q_ALLOCATE
2113 ! Q_CTRGRID
2114 ! Q_INIT
2115 !
2116 ! 7. Remarks
2117 !
2118 ! 8. Structure
2119 !
2120 ! 9. Switches
2121 !
2122 ! 10. Source code
2123 !---------------------------------------------------------------------------------------
2124 !
2125 ! Local parameters
2126 !
2127  integer iuerr ! error indicator
2128  integer idepth ! index over water depths
2129  integer igrid ! status of quadruplet grid file
2130  integer ia,ik ! counters
2131 !
2132  real depmin ! minimum water depth
2133  real dstep ! directional step
2134  real dgap ! directional gap between first and last direction
2135 !
2136  call q_setversion ! set version number
2137 !------------------------------------------------------------------------------
2138 ! user defined settings
2139 !------------------------------------------------------------------------------
2140 ! q_mindepth = 0.1 ! Set minimum water depth
2141  q_mindepth = trshdep ! Set minimum water depth (=DEPMIN)
2142  q_maxdepth = 2000 ! Set maximum water depth
2143  q_dstep = 0.1 ! Set minimum step for coding depth files
2144  iscreen = 6 ! Identifier for screen output (UNIX=0, WINDOWS=6)
2145  iufind = 1 ! search for unit numbers automatically
2146 !----------------------------------------------------------------------------
2147 ! Initialisations
2148 !
2149  ierror = 0 ! set error condition
2150  iq_stack = 0 ! initialize stack for tracing subroutines
2151  qbase = 'xnl4v5' ! Base name for quadruplet files
2152  qf_error = 'xnl5_errors.txt' ! Text file with error messages
2153  lastquadfile = 'quad?????.bqf' ! Initialize name of last retrieved quad file
2154 !
2155 ! set values of physical quantities
2156 ! and store them in quad data area
2157 !
2158  q_grav = x_grav ! gravitational acceleration
2159  qf_tail = pftail ! Power of parametric spectral tail
2160  iq_type = jquad ! Type of method to compute transfer
2161  iq_prt = 0 ! Print output on, to file /qbase/.prt
2162  iq_test = 0 ! test level
2163  iq_trace = 0 ! level of subroutine trace
2164  iq_log = 0 ! Set logging of q_routines off
2165  iq_grid = iqgrid ! Grid type for computation of nonlinear transfer
2166  iq_screen = 0 ! enable output to screen
2167 !
2168 !------------------------------------------------------------------------------
2169 ! Check input
2170 !------------------------------------------------------------------------------
2171  if(iq_type<1 .or. iq_type>3) then
2172  ierror = 1
2173  goto 9999
2174  end if
2175 !
2176  if(iq_grid<1 .or. iq_grid>3) then
2177  ierror = 2
2178  goto 9999
2179  end if
2180 !
2181 ! Retrieve size of spectral grid from input
2182 !
2183  fqmin = sigma(1)/(4.*pih) ! minimum frequency in Hz
2184  fqmax = sigma(nsigma)/(4.*pih) ! maximum frequency in Hz
2185  nkq = nsigma ! number of frequencies/wave numbers
2186  naq = ndir ! number of directions
2187 !
2188 ! check if directions are given on full circle or in a symmetric sector
2189 !----------------------------------------------------------------------------
2190 ! 1: compute directional step
2191 ! 2: compute gap between first and last
2192 ! 3: compare gap with step
2193 !
2194  dstep = dird(2)-dird(1) ! directional step
2195  dgap = 180.- abs(180.- abs(dird(1)-dird(ndir))) ! directional gap
2196 !
2197 !----------------------------------------------------------------------
2198  if(iq_grid==1 .or. iq_grid==2) then
2199 !
2200 ! check if gap equal to step in the case of full circle
2201 !
2202  if(abs(dstep-dgap) < 0.001) then
2203  ierror = 31
2204  write(iscreen,'(a,i4,2f10.2)') 'XNL_INIT iq_grid dstep dgap:', &
2205  iq_grid,dstep,dgap
2206  goto 9999
2207  end if
2208 !
2209 ! check if sector is symmetric around zero in the case of sector grid
2210 !
2211  if(abs(dird(1)+dird(ndir)) > 0.01) then
2212  write(iscreen,'(a,i4,2f10.2)') &
2213  'XNL_INIT iq_grid dird(1) dird(n):',iq_grid,dird(1),dird(ndir)
2214  ierror = 32
2215  goto 9999
2216  end if
2217  end if
2218 !
2219  q_dird1 = dird(1)
2220  q_dird2 = dird(ndir)
2221 !
2222 ! assign unit numbers for QUAD related files
2223 !
2224 ! If IUFIND=0, fixed prespecified unit numbers must be given
2225 ! IUFIND=1, the numbers are searched automatically
2226 !
2227  if(iufind==0) then
2228  luq_err = 103
2229  luq_tst = 104
2230  luq_int = 105
2231  luq_log = 106
2232  luq_prt = 107
2233  luq_cfg = 108
2234  luq_bqf = 109
2235  luq_grd = 110
2236  luq_txt = 111
2237  luq_loc = 112
2238  luq_trf = 113
2239  luq_t13 = 114
2240  luq_fil = 117
2241  end if
2242 !
2243 ! delete old Error file, if it exists
2244 !
2245  tempfile = trim(qbase)//'.err'
2246  call z_fileio(tempfile,'DF',iufind,luq_err,iuerr)
2247  if(iuerr/=0) then
2248  call q_error('e','FILEIO','Problem in deleting error file *.ERR')
2249  ierror = 4
2250  goto 9999
2251  end if
2252 !
2253 ! create new files, first create logging file
2254 !
2255  tempfile = trim(qbase)//'.log'
2256  call z_fileio(tempfile,'UF',iufind,luq_log,iuerr) ! logging
2257  tempfile = trim(qbase)//'.prt'
2258  call z_fileio(tempfile,'UF',iufind,luq_prt,iuerr) ! general print file
2259  tempfile = trim(qbase)//'.tst'
2260  call z_fileio(tempfile,'UF',iufind,luq_tst,iuerr) ! test output
2261 !
2262  tempfile = trim(qbase)//'.int'
2263  call z_fileio(tempfile,'UF',iufind,luq_int,iuerr) ! logging for locus integration
2264  tempfile = trim(qbase)//'.trf'
2265  call z_fileio(tempfile,'UF',iufind,luq_trf,iuerr) ! transformation test
2266  tempfile = trim(qbase)//'.t13'
2267  call z_fileio(tempfile,'UF',iufind,luq_t13,iuerr) ! test output for integration of T13
2268 !
2269  write(luq_log,'(2a,i4)') 'XNL_INIT: ', &
2270  trim(qbase)//'.log connected to :',luq_log
2271  write(luq_log,'(2a,i4)') 'XNL_INIT: ', &
2272  trim(qbase)//'.prt connected to :',luq_prt
2273  write(luq_log,'(2a,i4)') 'XNL_INIT: ', &
2274  trim(qbase)//'.tst connected to :',luq_tst
2275 !
2276  write(luq_log,'(2a,i4)') 'XNL_INIT: ', &
2277  trim(qbase)//'.int connected to :',luq_int
2278  write(luq_log,'(2a,i4)') 'XNL_INIT: ', &
2279  trim(qbase)//'.trf connected to :',luq_trf
2280  write(luq_log,'(2a,i4)') 'XNL_INIT: ', &
2281  trim(qbase)//'.t13 connected to :',luq_t13
2282 !
2283  write(luq_prt,'(a)') &
2284  '---------------------------------------------------------------'
2285  write(luq_prt,'(a)') trim(q_version)
2286  write(luq_prt,'(a)') &
2287  'Solution of Boltzmann integral using Webb/Resio/Tracy method'
2288  write(luq_prt,'(a)') &
2289  '---------------------------------------------------------------'
2290  write(luq_prt,*)
2291  write(luq_prt,'(a)') 'Initialisation'
2292  write(luq_prt,*)
2293 !
2294 ! if(iproc >=0) write(luq_prt,'(a,i5)') '(MPI) processor number:',iproc
2295 !---------------------------------------------------------------------------------
2296 ! Reset configuration from file, using a backdoor
2297 !---------------------------------------------------------------------------------
2298  call q_setconfig(jquad)
2299  if (iq_err /=0) then
2300  ierror = 5
2301  goto 9999
2302  end if
2303 !---------------------------------------------------------------------------------
2304 ! check settings for inconsistencies
2305 !---------------------------------------------------------------------------------
2306  call q_chkconfig
2307  if (iq_err /=0) then
2308  ierror = 6
2309  goto 9999
2310  end if
2311 !---------------------------------------------------------------------------------
2312 ! determine minimum size of number of points on locus as stored in database
2313 !---------------------------------------------------------------------------------
2314  klocus = nlocus0
2315  if(iq_gauleg > 0) klocus = min(iq_gauleg,klocus)
2316  if(iq_lump > 0) klocus = min(iq_lump,klocus)
2317 !---------------------------------------------------------------------------------
2318 ! write summary of program settings
2319 !---------------------------------------------------------------------------------
2320  call q_summary
2321 !----------------------------------------------------------------------------------
2322 ! allocate data arrays
2323 !-----------------------------------------------------------------------------
2324  call q_allocate
2325 !------------------------------------------------------------------------------
2326 ! Generate interaction grid and coefficients for each valid water depth
2327 ! Q_CTRGRID controls grid generation
2328 !------------------------------------------------------------------------------
2329  do idepth=1,ndepth
2330  q_depth = depth(idepth)
2331 !
2332  if(jquad==1 .or. jquad==2) q_depth = q_maxdepth
2333 !
2334  if(q_depth <= q_mindepth) then
2335  call q_error('w','DEPTH','Invalid depth')
2336  write(luq_err,'(a,e12.5,f10.2)') 'Incorrect depth & minimum:', &
2337  q_depth,q_mindepth
2338  else
2339  call q_init
2340  call q_ctrgrid(2,igrid)
2341  if(iq_err /= 0) then
2342  ierror = 7
2343  goto 9999
2344  end if
2345  end if
2346 !
2347  if(jquad==1 .and. ndepth > 0) then
2348  write(luq_prt,'(a)') &
2349  'XNL_INIT: For deep water only one grid suffices'
2350  exit
2351  end if
2352  end do
2353 !
2354 !
2355 ! Create or open triplet output data file if iq_triq > 0
2356 !
2357 !
2358  9999 continue
2359 !
2360 !! if (iq_log ==0) call z_fileio(trim(qbase)//'.log','DF',iufind,luq_log,iuerr)
2361 !! if (iq_prt ==0) call z_fileio(trim(qbase)//'.prt','DF',iufind,luq_prt,iuerr)
2362 !
2363  if (iq_integ==0) then
2364  tempfile = trim(qbase)//'.int'
2365  call z_fileio(tempfile,'DF',iufind,luq_int,iuerr)
2366  end if
2367  if (iq_test ==0) then
2368  tempfile = trim(qbase)//'.tst'
2369  call z_fileio(tempfile,'DF',iufind,luq_tst,iuerr)
2370  end if
2371  if (iq_trf ==0) then
2372  tempfile = trim(qbase)//'.trf'
2373  call z_fileio(tempfile,'DF',iufind,luq_trf,iuerr)
2374  end if
2375  if (iq_t13 ==0) then
2376  tempfile = trim(qbase)//'.t13'
2377  call z_fileio(tempfile,'DF',iufind,luq_t13,iuerr)
2378  end if
2379 !
2380  return
mod_time::abs
Definition: mod_time.f90:64
m_constants
Definition: swmod3.f90:22
ice_constants::pih
real(kind=dbl_kind) pih
Definition: ice_constants.f90:206
m_fileio::z_fileio
subroutine z_fileio(filename, qual, iufind, iunit, iostat)
Definition: swmod3.f90:147
m_constants::trshdep
real trshdep
Definition: swmod3.f90:34
m_genarr::depth
real, dimension(:), allocatable, save depth
Definition: swmod2.f90:768
m_fileio::tempfile
character(len=80) tempfile
Definition: swmod3.f90:142
m_fileio
Definition: swmod3.f90:74
Here is the call graph for this function:

◆ xnl_main()

subroutine m_xnldata::xnl_main ( real, dimension(nsig,ndir), intent(in)  aspec,
real, dimension(nsig), intent(in)  sigma,
real, dimension(ndir), intent(in)  angle,
integer, intent(in)  nsig,
integer, intent(in)  ndir,
real, intent(in)  depth,
integer, intent(in)  iquad,
real, dimension(nsig,ndir), intent(out)  xnl,
real, dimension(nsig,ndir), intent(out)  diag,
integer, intent(in)  iproc,
integer, intent(out)  ierror 
)

Definition at line 2385 of file swmod3.f90.

2385 !-----------------------------------------------------------------------------!
2386 !
2387 ! +-------+ ALKYON Hydraulic Consultancy & Research
2388 ! | | Gerbrant Ph. van Vledder
2389 ! | +---+
2390 ! | | +---+ Last update: 7 May 2004
2391 ! +---+ | | Release: 5.04
2392 ! +---+
2393 !
2394 !
2395 ! SWAN (Simulating WAves Nearshore); a third generation wave model
2396 ! Copyright (C) 2004-2005 Delft University of Technology
2397 !
2398 ! This program is free software; you can redistribute it and/or
2399 ! modify it under the terms of the GNU General Public License as
2400 ! published by the Free Software Foundation; either version 2 of
2401 ! the License, or (at your option) any later version.
2402 !
2403 ! This program is distributed in the hope that it will be useful,
2404 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
2405 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2406 ! GNU General Public License for more details.
2407 !
2408 ! A copy of the GNU General Public License is available at
2409 ! http://www.gnu.org/copyleft/gpl.html#SEC3
2410 ! or by writing to the Free Software Foundation, Inc.,
2411 ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
2412 !
2413 !
2414 ! do not use m_xnldata
2415  use serv_xnl4v5
2416 !
2417  implicit none
2418 !
2419 ! 0. Update history
2420 !
2421 ! 25/02/1999 Initial version
2422 ! 25/07/1999 Various restructurations
2423 ! 12/10/1999 Error handling improved
2424 ! 15/10/1999 Existing test file deleted
2425 ! 25/10/1999 Parameter iq_filt added
2426 ! 29/10/1999 iq_call renamed to i_qmain and save statement added
2427 ! 08/12/1999 Call to CHKLAW included
2428 ! 16/12/1999 Extra output and check for wave number range
2429 ! 27/12/1999 Expansion of k-grid now in new subroutine Q_EXPAND
2430 ! 06/01/2000 Deallocate of KX and NSPECX removed
2431 ! 08/01/2000 Recontructed, subroutine Q_WRTVV splitted off
2432 ! 12/01/2000 Diagonal term added to interface
2433 ! 26/06/2000 Name changed to XNL_MAIN
2434 ! 01/02/2001 Interface change, spectrum must be given as Action density(sigma,theta)
2435 ! 06/11/2001 Water depth forced to 1000 when IQUAD==1,2
2436 ! 13/08/2002 Upgrade to release 4.0
2437 ! 20/08/2002 Action density array copied to internal A-array
2438 ! 09/09/2002 Upgrade to release 5
2439 ! 16/09/2002 Parameter IPROC included to take care of MPI processors
2440 ! 27/09/2002 Description of input argument SIGMA corrected
2441 ! 30/12/2003 Call to subroutine Q_ADDTAIL added
2442 ! 07/05/2004 Depth set to Q_MAXDEPTH for iquad=1,2
2443 !
2444 ! 1. Purpose:
2445 !
2446 ! Compute nonlinear transfer for a given action density spectrum
2447 ! on a given sigma and direction grid
2448 !
2449 ! 2. Method
2450 !
2451 ! Webb/Resio/Tracy/Van Vledder
2452 !
2453 ! 3. Parameter list:
2454 !
2455 ! Type I/O Name Description
2456 !---------------------------------------------------------------------------------------------
2457  integer,intent(in) :: nsig ! number of frequencies (sigma)
2458  integer,intent(in) :: ndir ! number of directions
2459  integer,intent(in) :: iquad ! method of computing nonlinear quadruplet interactions
2460  integer, intent(in) :: iproc ! MPI processor number
2461 !
2462  real, intent(in) :: aspec(nsig,ndir) ! Action density spectrum as a function of (sigma,theta)
2463  real, intent(in) :: sigma(nsig) ! radian frequencies
2464  real, intent(in) :: angle(ndir) ! directions in radians (sector or full circle)
2465  real, intent(in) :: depth ! water depth in m
2466  real, intent(out) :: xnl(nsig,ndir) ! nonlinear quadruplet interaction computed with
2467 ! a certain exact method (k,theta)
2468  real, intent(out) :: diag(nsig,ndir) ! diagonal term for semi-implicit integration
2469  integer, intent(out) :: ierror ! error indicator
2470 !
2471 !--------------------------------------------------------------------------------
2472 !
2473 ! 4. Error messages
2474 !
2475 ! 5. Called by:
2476 !
2477 ! host program
2478 !
2479 ! 6. Subroutines used
2480 !
2481 ! Q_DSCALE WAM depth scaling
2482 ! Q_XNL4V4 Xnl using Webb/Resio/Tracy/VanVledder
2483 ! Q_STACK Stack administration
2484 ! Q_CHKCONS Check conservation of energy, action and momentum
2485 !
2486 ! 7. Remarks
2487 !
2488 ! 8. Structure
2489 !
2490 ! 9. Switches
2491 !
2492 ! 10. Source code:
2493 !--------------------------------------------------------------------------------
2494 ! local variables
2495 !
2496  integer, save :: i_qmain ! counter number of calls of XNL_MAIN
2497  integer i_qlast ! value of iquad in last call
2498 !
2499  integer isig ! counter for sigma values
2500  integer idir ! counter of directions
2501  real q_dfac ! depth scale factor for nonlinear transfer
2502 !
2503  real sum_e ! sum of energy
2504  real sum_a ! sum of action
2505  real sum_mx ! sum of momentum in x-direction
2506  real sum_my ! sum of momentum in y-direction
2507 !
2508  data i_qmain /0/ ! keep track of number of calls of XNL_MAIN
2509  data i_qlast /0/ ! keep track of last call with IQUAD
2510 !
2511 !--------------------------------------------------------------------------------
2512 !
2513  iq_stack =0 ! initialize stack order every time qmain is called
2514 !
2515  call q_stack('+xnl_main')
2516 !
2517  i_qmain = i_qmain + 1
2518 !
2519  if(iq_prt>=1) then
2520  write(luq_prt,*)
2521  write(luq_prt,'(a,i4,f16.3,i4)') &
2522  'XNL_MAIN: Input arguments: iquad depth iproc:', &
2523  iquad,depth,iproc
2524  end if
2525 !
2526 ! initialisations for error handling
2527 !
2528  iq_err = 0 ! No errors detected at start
2529  q_depth = depth ! water depth to be used in computation
2530 !
2531  if(iquad==1 .or. iquad==2) q_depth=q_maxdepth
2532 ! !
2533 ! check water depth to be used in computation
2534 !
2535  if(q_depth <= q_mindepth) then
2536  xnl = 0.
2537  call q_error('w','DEPTH','Zero transfer returned')
2538  goto 9999
2539  end if
2540 !
2541 ! check if iquad has changed since last call, this is no more allowed
2542 !
2543 !! if (iquad /= i_qlast .and. i_qmain/=1) then
2544 !! call q_error('e','IQUAD','Value of IQUAD differs from initial value')
2545 !! ierror = 1
2546 !! goto 9999
2547 !! end if
2548 !-----------------------------------------------------------------------------+
2549 ! main choice between various options |
2550 !-----------------------------------------------------------------------------+
2551 !
2552  if(iquad>=1 .and. iquad <=3) then
2553 !
2554  a = aspec
2555  call q_xnl4v4(aspec,sigma,angle,nsig,ndir,depth,xnl,diag,ierror)
2556 !
2557  if(ierror/=0) then
2558  call q_error('e','wrtvv','Problem in Q_XNL4V4')
2559  goto 9999
2560  end if
2561 !------------------------------------------------------------------------------
2562 ! add parametric tail to transfer rate and diagonal term
2563 !------------------------------------------------------------------------------
2564 !
2565  if(iq_tail==1) call q_addtail(xnl,diag,nsig,ndir,qf_tail)
2566 !
2567 !------------------------------------------------------------------------------
2568 ! compute scale factor to include WAM depth scaling
2569 !------------------------------------------------------------------------------
2570 !
2571  if(iq_dscale ==1) then
2572  call q_dscale(aspec,sigma,angle,nsig,ndir,depth,q_grav,q_dfac)
2573 !
2574  xnl = xnl*q_dfac
2575 !
2576  if(iq_prt >=1) write(luq_prt,'(a,f7.4)') &
2577  'XNL_MAIN depth scale factor:',q_dfac
2578  end if
2579  end if
2580 !
2581 ! check conservation laws
2582 !
2583  call q_chkcons(xnl,nsig,ndir,sum_e,sum_a,sum_mx,sum_my)
2584 !
2585  if(iq_prt >= 1) then
2586  write(luq_prt,'(a)') 'XNL_MAIN: Conservation checks'
2587  write(luq_prt,'(a,4e13.5)') 'XNL_MAIN: E/A/MOMX/MOMY:', &
2588  sum_e,sum_a,sum_mx,sum_my
2589  end if
2590 !
2591  9999 continue
2592 !
2593  ierror = iq_err
2594 !
2595  if(iq_log >= 1) then
2596  write(luq_log,*)
2597  write(luq_log,'(a,i4)') 'XNL_MAIN: Number of warnings:',iq_warn
2598  write(luq_log,'(a,i4)') 'XNL_MAIN: Number of errors :',iq_err
2599  end if
2600 !
2601 !! i_qlast = iquad
2602 !
2603  call q_stack('-xnl_main')
2604 !
2605  return
swcomm3::iquad
integer iquad
Definition: swmod1.f90:2127
m_genarr::depth
real, dimension(:), allocatable, save depth
Definition: swmod2.f90:768
serv_xnl4v5
Definition: swmod3.f90:667
Here is the call graph for this function:

Variable Documentation

◆ a

real, dimension(:,:), allocatable m_xnldata::a

Definition at line 1910 of file swmod3.f90.

1910  real, allocatable :: a(:,:) ! Action density on wave number grid A(sigma,theta)

◆ a_pol

real, dimension(:), allocatable m_xnldata::a_pol

Definition at line 1834 of file swmod3.f90.

1834  real, allocatable :: a_pol(:) ! angles of polar locus

◆ aqname

character(len=17) m_xnldata::aqname

Definition at line 1731 of file swmod3.f90.

1731  character(len=17) aqname ! name of ASCII grid file

◆ bqname

character(len=17) m_xnldata::bqname

Definition at line 1732 of file swmod3.f90.

1732  character(len=17) bqname ! name of binary quadruplet grid file

◆ c_pol

real, dimension(:), allocatable m_xnldata::c_pol

Definition at line 1833 of file swmod3.f90.

1833  real, allocatable :: c_pol(:) ! cosines during polar generation of locus

◆ cple_loc

real, dimension(:), allocatable m_xnldata::cple_loc

Definition at line 1829 of file swmod3.f90.

1829  real, allocatable :: cple_loc(:) ! coupling coefficient around locus

◆ cple_mod

real, dimension(:), allocatable m_xnldata::cple_mod

Definition at line 1846 of file swmod3.f90.

1846  real, allocatable :: cple_mod(:) ! coupling coefficient around locus

◆ crf1

real m_xnldata::crf1

Definition at line 1932 of file swmod3.f90.

1932  real crf1 ! estimated circumference of locus

◆ cstack

character(len=21), dimension(mq_stack) m_xnldata::cstack

Definition at line 1928 of file swmod3.f90.

1928  character(len=21) cstack(mq_stack) ! Stack with module names

◆ dk0

real m_xnldata::dk0

Definition at line 1765 of file swmod3.f90.

◆ ds_loc

real, dimension(:), allocatable m_xnldata::ds_loc

Definition at line 1827 of file swmod3.f90.

1827  real, allocatable :: ds_loc(:) ! step size around locus

◆ ds_mod

real, dimension(:), allocatable m_xnldata::ds_mod

Definition at line 1844 of file swmod3.f90.

1844  real, allocatable :: ds_mod(:) ! step size around locus

◆ dt13

real, dimension(:), allocatable m_xnldata::dt13

Definition at line 1894 of file swmod3.f90.

1894  real, allocatable :: dt13(:) ! increment along locus

◆ eps_k

real m_xnldata::eps_k

Definition at line 1924 of file swmod3.f90.

1924  real eps_k ! absolute accuracy for equality check of k

◆ eps_q

real m_xnldata::eps_q

Definition at line 1923 of file swmod3.f90.

1923  real eps_q ! absolute accuracy for check of Q

◆ ff_tail

real m_xnldata::ff_tail

Definition at line 1949 of file swmod3.f90.

1949  real ff_tail ! fraction of maximum frequency where parametric tail starts

◆ fqmax

real m_xnldata::fqmax

Definition at line 1746 of file swmod3.f90.

1746  real fqmax ! highest frequency in Hz

◆ fqmin

real m_xnldata::fqmin

Definition at line 1745 of file swmod3.f90.

1745  real fqmin ! lowest frequency in Hz

◆ ia_k1

integer m_xnldata::ia_k1

Definition at line 1742 of file swmod3.f90.

1742  integer ia_k1,ik_k1 ! indices of main loop variables

◆ ia_k3

integer m_xnldata::ia_k3

Definition at line 1743 of file swmod3.f90.

1743  integer ia_k3,ik_k3 ! indices of main loop variables

◆ iag1

integer m_xnldata::iag1

Definition at line 1940 of file swmod3.f90.

1940  integer iag1,iag2 ! range of directions for precomputed interaction grid

◆ iag2

integer m_xnldata::iag2

Definition at line 1940 of file swmod3.f90.

◆ iamax

integer m_xnldata::iamax

Definition at line 1938 of file swmod3.f90.

1938  integer iamax ! maximum difference in indices for sector grids

◆ iaq1

integer m_xnldata::iaq1

Definition at line 1939 of file swmod3.f90.

1939  integer iaq1,iaq2 ! indices of do-loop for directions

◆ iaq2

integer m_xnldata::iaq2

Definition at line 1939 of file swmod3.f90.

◆ iaref

integer m_xnldata::iaref

Definition at line 1937 of file swmod3.f90.

1937  integer iaref ! index of first angle of reference wave numbers

◆ id_facmax

integer m_xnldata::id_facmax

Definition at line 1915 of file swmod3.f90.

1915  integer id_facmax ! Factor for determining range of depth search (Q_SEARCHGRID)

◆ ik_k1

integer m_xnldata::ik_k1

Definition at line 1742 of file swmod3.f90.

◆ ik_k3

integer m_xnldata::ik_k3

Definition at line 1743 of file swmod3.f90.

◆ iq_compact

integer m_xnldata::iq_compact

Definition at line 1613 of file swmod3.f90.

1613  integer iq_compact ! switch to compact data

◆ iq_cple

integer m_xnldata::iq_cple

Definition at line 1617 of file swmod3.f90.

1617  integer iq_cple ! type of coupling coefficient

◆ iq_disp

integer m_xnldata::iq_disp

Definition at line 1624 of file swmod3.f90.

1624  integer iq_disp ! type of dispersion relation, viz. depth dependency

◆ iq_dscale

integer m_xnldata::iq_dscale

Definition at line 1629 of file swmod3.f90.

1629  integer iq_dscale ! switch to activate depth scaling according to

◆ iq_err

integer m_xnldata::iq_err

Definition at line 1975 of file swmod3.f90.

1975  integer iq_err ! counts the number of errors

◆ iq_filt

integer m_xnldata::iq_filt

Definition at line 1634 of file swmod3.f90.

1634  integer iq_filt ! switch to activate filtering in wave number space

◆ iq_gauleg

integer m_xnldata::iq_gauleg

Definition at line 1638 of file swmod3.f90.

1638  integer iq_gauleg ! switch for Gauss-Legendre interpolation

◆ iq_geom

integer m_xnldata::iq_geom

Definition at line 1642 of file swmod3.f90.

1642  integer iq_geom ! type of scaling

◆ iq_grid

integer m_xnldata::iq_grid

Definition at line 1647 of file swmod3.f90.

1647  integer iq_grid ! type of spectral grid

◆ iq_integ

integer m_xnldata::iq_integ

Definition at line 1652 of file swmod3.f90.

1652  integer iq_integ ! option to output integration results

◆ iq_interp

integer m_xnldata::iq_interp

Definition at line 1658 of file swmod3.f90.

1658  integer iq_interp ! type of interpolation to retrieve action density

◆ iq_locus

integer m_xnldata::iq_locus

Definition at line 1662 of file swmod3.f90.

1662  integer iq_locus ! Option for computation of locus

◆ iq_log

integer m_xnldata::iq_log

Definition at line 1667 of file swmod3.f90.

1667  integer iq_log ! switch to activate logging to file QBASE//.LOG

◆ iq_lump

integer m_xnldata::iq_lump

Definition at line 1671 of file swmod3.f90.

1671  integer iq_lump ! switch to activate lumping on locus

◆ iq_make

integer m_xnldata::iq_make

Definition at line 1675 of file swmod3.f90.

1675  integer iq_make ! option to make quadruplet grid

◆ iq_mod

integer m_xnldata::iq_mod

Definition at line 1680 of file swmod3.f90.

1680  integer iq_mod ! option to redistribute points on locus

◆ iq_prt

integer m_xnldata::iq_prt

Definition at line 1684 of file swmod3.f90.

1684  integer iq_prt ! switch to activate print output, to file QBASE//.PRT

◆ iq_screen

integer m_xnldata::iq_screen

Definition at line 1692 of file swmod3.f90.

1692  integer iq_screen ! option to send output to the screen

◆ iq_search

integer m_xnldata::iq_search

Definition at line 1688 of file swmod3.f90.

1688  integer iq_search ! switch to determine search for a proper grid

◆ iq_stack

integer m_xnldata::iq_stack

Definition at line 1927 of file swmod3.f90.

1927  integer iq_stack ! Sequence number of stack with subroutine calls

◆ iq_sym

integer m_xnldata::iq_sym

Definition at line 1696 of file swmod3.f90.

1696  integer iq_sym ! switch to activate use of symmetry reduction

◆ iq_t13

integer m_xnldata::iq_t13

Definition at line 1718 of file swmod3.f90.

1718  integer iq_t13 ! option to output T13 integration

◆ iq_tail

integer m_xnldata::iq_tail

Definition at line 1700 of file swmod3.f90.

1700  integer iq_tail ! add parametric tail to transfer rate and diagnonal term

◆ iq_test

integer m_xnldata::iq_test

Definition at line 1704 of file swmod3.f90.

1704  integer iq_test ! test level, output is directed to unit luqtst

◆ iq_trace

integer m_xnldata::iq_trace

Definition at line 1709 of file swmod3.f90.

1709  integer iq_trace ! trace option

◆ iq_trf

integer m_xnldata::iq_trf

Definition at line 1714 of file swmod3.f90.

1714  integer iq_trf ! option to print transformed loci to special output file

◆ iq_type

integer m_xnldata::iq_type

Definition at line 1967 of file swmod3.f90.

1967  integer iq_type ! method for computing the nonlinear interactions

◆ iq_warn

integer m_xnldata::iq_warn

Definition at line 1981 of file swmod3.f90.

1981  integer iq_warn ! counts the number of warnings

◆ iq_xdia

integer m_xnldata::iq_xdia

Definition at line 1722 of file swmod3.f90.

1722  integer iq_xdia ! switch to activate output to extended DIA data file

◆ iscreen

integer m_xnldata::iscreen

Definition at line 1581 of file swmod3.f90.

1581  integer iscreen ! identifier for screen, set in XNL_INIT

◆ iufind

integer m_xnldata::iufind

Definition at line 1580 of file swmod3.f90.

1580  integer iufind ! Specifies handling of unit numbers, see Z_FILEIO

◆ jac_loc

real, dimension(:), allocatable m_xnldata::jac_loc

Definition at line 1828 of file swmod3.f90.

1828  real, allocatable :: jac_loc(:) ! jacobian term around locus

◆ jac_mod

real, dimension(:), allocatable m_xnldata::jac_mod

Definition at line 1845 of file swmod3.f90.

1845  real, allocatable :: jac_mod(:) ! jacobian term around locus

◆ k0x

real m_xnldata::k0x

Definition at line 1765 of file swmod3.f90.

1765  real k0x,k0y,dk0 ! components of initial wave number of locus,

◆ k0y

real m_xnldata::k0y

Definition at line 1765 of file swmod3.f90.

◆ k1x

real m_xnldata::k1x

Definition at line 1767 of file swmod3.f90.

1767  real k1x,k1y ! components of k1 wave number

◆ k1y

real m_xnldata::k1y

Definition at line 1767 of file swmod3.f90.

◆ k2a_mod

real, dimension(:), allocatable m_xnldata::k2a_mod

Definition at line 1850 of file swmod3.f90.

1850  real, allocatable :: k2a_mod(:) ! k2 angle around locus

◆ k2m_mod

real, dimension(:), allocatable m_xnldata::k2m_mod

Definition at line 1849 of file swmod3.f90.

1849  real, allocatable :: k2m_mod(:) ! k2 magnitude around locus

◆ k2x

real m_xnldata::k2x

Definition at line 1768 of file swmod3.f90.

1768  real k2x,k2y ! components of k2 wave number

◆ k2y

real m_xnldata::k2y

Definition at line 1768 of file swmod3.f90.

◆ k3x

real m_xnldata::k3x

Definition at line 1769 of file swmod3.f90.

1769  real k3x,k3y ! components of k3 wave number

◆ k3y

real m_xnldata::k3y

Definition at line 1769 of file swmod3.f90.

◆ k4a_mod

real, dimension(:), allocatable m_xnldata::k4a_mod

Definition at line 1852 of file swmod3.f90.

1852  real, allocatable :: k4a_mod(:) ! k4 angle around locus

◆ k4m_mod

real, dimension(:), allocatable m_xnldata::k4m_mod

Definition at line 1851 of file swmod3.f90.

1851  real, allocatable :: k4m_mod(:) ! k4 magnitude around locus

◆ k4x

real m_xnldata::k4x

Definition at line 1770 of file swmod3.f90.

1770  real k4x,k4y ! components of k4 wave number

◆ k4y

real m_xnldata::k4y

Definition at line 1770 of file swmod3.f90.

◆ k_pol

real, dimension(:), allocatable m_xnldata::k_pol

Definition at line 1832 of file swmod3.f90.

1832  real, allocatable :: k_pol(:) ! wave numbers during polar generation of locus

◆ klocus

integer m_xnldata::klocus

Definition at line 1755 of file swmod3.f90.

1755  integer klocus ! number of points on locus as stored in quadruplet database

◆ kmax_loc

real m_xnldata::kmax_loc

Definition at line 1778 of file swmod3.f90.

1778  real kmax_loc ! maximum wave number of locus along symmetry axis

◆ kmid

real m_xnldata::kmid

Definition at line 1779 of file swmod3.f90.

1779  real kmid ! wave number at midpoint of locus along symmetry axis

◆ kmidx

real m_xnldata::kmidx

Definition at line 1780 of file swmod3.f90.

1780  real kmidx ! x-component of wave number at midpoint of locus along symmetry axis

◆ kmidy

real m_xnldata::kmidy

Definition at line 1781 of file swmod3.f90.

1781  real kmidy ! y-component of wave number at midpoint of locus along symmetry axis

◆ kmin_loc

real m_xnldata::kmin_loc

Definition at line 1777 of file swmod3.f90.

1777  real kmin_loc ! minimum wave number of locus along symmetry axis

◆ kqmax

real m_xnldata::kqmax

Definition at line 1762 of file swmod3.f90.

1762  real kqmax ! highest wave number

◆ kqmin

real m_xnldata::kqmin

Definition at line 1761 of file swmod3.f90.

1761  real kqmin ! lowest wave number

◆ krefx

real m_xnldata::krefx

Definition at line 1766 of file swmod3.f90.

1766  real krefx,krefy ! components of reference wave number for quad-grid

◆ krefy

real m_xnldata::krefy

Definition at line 1766 of file swmod3.f90.

◆ lastquadfile

character(len=17) m_xnldata::lastquadfile

Definition at line 1733 of file swmod3.f90.

1733  character(len=17) lastquadfile ! name of last retrieved BQF file

◆ loc_area

real m_xnldata::loc_area

Definition at line 1783 of file swmod3.f90.

1783  real loc_area ! area of locus, measured in (kx-ky)- space

◆ loc_crf

real m_xnldata::loc_crf

Definition at line 1782 of file swmod3.f90.

1782  real loc_crf ! circumference of locus in (kx,ky)-space

◆ loc_xz

real m_xnldata::loc_xz

Definition at line 1784 of file swmod3.f90.

1784  real loc_xz ! x-coordinate of center of gravity of locus in (kx,ky)-space

◆ loc_yz

real m_xnldata::loc_yz

Definition at line 1785 of file swmod3.f90.

1785  real loc_yz ! y-coordinate of center of gravity of locus in (kx,ky)-space

◆ lq_grid

logical m_xnldata::lq_grid

Definition at line 1736 of file swmod3.f90.

1736  logical lq_grid ! flag to make (new) interaction grid

◆ luq_bqf

integer m_xnldata::luq_bqf

Definition at line 1585 of file swmod3.f90.

1585  integer luq_bqf ! binary file storing and retrieving precomputed loci

◆ luq_cfg

integer m_xnldata::luq_cfg

Definition at line 1586 of file swmod3.f90.

1586  integer luq_cfg ! user defined configuration

◆ luq_err

integer m_xnldata::luq_err

Definition at line 1587 of file swmod3.f90.

1587  integer luq_err ! file with error messages

◆ luq_fil

integer m_xnldata::luq_fil

Definition at line 1588 of file swmod3.f90.

1588  integer luq_fil ! test output for filtering

◆ luq_grd

integer m_xnldata::luq_grd

Definition at line 1589 of file swmod3.f90.

1589  integer luq_grd ! ASCII file storing and retrieving precomputed loci

◆ luq_int

integer m_xnldata::luq_int

Definition at line 1590 of file swmod3.f90.

1590  integer luq_int ! test file for test output of integration

◆ luq_loc

integer m_xnldata::luq_loc

Definition at line 1591 of file swmod3.f90.

1591  integer luq_loc ! statistics about computed loci

◆ luq_log

integer m_xnldata::luq_log

Definition at line 1592 of file swmod3.f90.

1592  integer luq_log ! logging

◆ luq_prt

integer m_xnldata::luq_prt

Definition at line 1593 of file swmod3.f90.

1593  integer luq_prt ! general print file for quadruplets

◆ luq_t13

integer m_xnldata::luq_t13

Definition at line 1597 of file swmod3.f90.

1597  integer luq_t13 ! test of basis integration

◆ luq_trf

integer m_xnldata::luq_trf

Definition at line 1594 of file swmod3.f90.

1594  integer luq_trf ! testing transformation of loci

◆ luq_tst

integer m_xnldata::luq_tst

Definition at line 1595 of file swmod3.f90.

1595  integer luq_tst ! test file for quadruplets

◆ luq_txt

integer m_xnldata::luq_txt

Definition at line 1596 of file swmod3.f90.

1596  integer luq_txt ! reading (error) text file

◆ mk1a

integer m_xnldata::mk1a

Definition at line 1986 of file swmod3.f90.

1986  integer mk1a,mk1b ! indices of k1 when test output is needed

◆ mk1b

integer m_xnldata::mk1b

Definition at line 1986 of file swmod3.f90.

◆ mk3a

integer m_xnldata::mk3a

Definition at line 1987 of file swmod3.f90.

1987  integer mk3a,mk3b ! indices of k3 when test output is needed

◆ mk3b

integer m_xnldata::mk3b

Definition at line 1987 of file swmod3.f90.

◆ mlocus

integer m_xnldata::mlocus

Definition at line 1752 of file swmod3.f90.

1752  integer mlocus ! maximum number of points on locus for defining arrays

◆ mq_stack

integer, parameter m_xnldata::mq_stack =10

Definition at line 1750 of file swmod3.f90.

1750  integer, parameter :: mq_stack=10 ! maximum number of elements in stack

◆ naq

integer m_xnldata::naq

Definition at line 1739 of file swmod3.f90.

1739  integer naq ! number of angles of quad-grad

◆ ncirc

integer m_xnldata::ncirc

Definition at line 1740 of file swmod3.f90.

1740  integer ncirc ! number of angles on a full circle

◆ nk1d

real, dimension(:), allocatable m_xnldata::nk1d

Definition at line 1912 of file swmod3.f90.

1912  real, allocatable :: nk1d(:) ! Internal 1d action density spectrum N(k)

◆ nkq

integer m_xnldata::nkq

Definition at line 1738 of file swmod3.f90.

1738  integer nkq ! number of wave numbers of quad-grid

◆ nlocus

integer m_xnldata::nlocus

Definition at line 1758 of file swmod3.f90.

1758  integer nlocus ! number of points on locus, equal to klocus

◆ nlocus0

integer m_xnldata::nlocus0

Definition at line 1753 of file swmod3.f90.

1753  integer nlocus0 ! preferred number of points on locus

◆ nlocus1

integer m_xnldata::nlocus1

Definition at line 1754 of file swmod3.f90.

1754  integer nlocus1 ! number of points on locus as computed in Q_CMPLOCUS

◆ nlocusx

integer m_xnldata::nlocusx

Definition at line 1759 of file swmod3.f90.

1759  integer nlocusx ! number of points on locus for use in computation (nlocusx <= nlocus)

◆ nspec

real, dimension(:,:), allocatable m_xnldata::nspec

Definition at line 1911 of file swmod3.f90.

1911  real, allocatable :: nspec(:,:) ! Action density on wave number grid N(kx,ky)

◆ pang

real m_xnldata::pang

Definition at line 1773 of file swmod3.f90.

1773  real pang ! angle related of P-vector, Pang = atan2(py,px), (radians)

◆ pmag

real m_xnldata::pmag

Definition at line 1772 of file swmod3.f90.

1772  real pmag ! magnitude of P-vector

◆ px

real m_xnldata::px

Definition at line 1771 of file swmod3.f90.

1771  real px,py ! components of difference k1-k3 wave number

◆ py

real m_xnldata::py

Definition at line 1771 of file swmod3.f90.

◆ q

real m_xnldata::q

Definition at line 1776 of file swmod3.f90.

1776  real q ! difference of radian frequencies, used in Resio-Tracy method

◆ q_a

real, dimension(:), allocatable m_xnldata::q_a

Definition at line 1908 of file swmod3.f90.

1908  real, allocatable :: q_a(:) ! directions of quadruplet grid in radians

◆ q_ad

real, dimension(:), allocatable m_xnldata::q_ad

Definition at line 1909 of file swmod3.f90.

1909  real, allocatable :: q_ad(:) ! directions of quadruplet grid in degrees

◆ q_ang1

real m_xnldata::q_ang1

Definition at line 1941 of file swmod3.f90.

1941  real q_ang1,q_ang2 ! lower and upper angle of grid in degrees

◆ q_ang2

real m_xnldata::q_ang2

Definition at line 1941 of file swmod3.f90.

◆ q_cg

real, dimension(:), allocatable m_xnldata::q_cg

Definition at line 1907 of file swmod3.f90.

1907  real, allocatable :: q_cg(:) ! group velocity (m/s)

◆ q_delta

real m_xnldata::q_delta

Definition at line 1942 of file swmod3.f90.

1942  real q_delta ! directional spacing of angular grid in radians

◆ q_deltad

real m_xnldata::q_deltad

Definition at line 1943 of file swmod3.f90.

1943  real q_deltad ! directional spacing of angular grid in degrees

◆ q_depth

real m_xnldata::q_depth

Definition at line 1917 of file swmod3.f90.

1917  real q_depth ! local water depth in m

◆ q_df

real, dimension(:), allocatable m_xnldata::q_df

Definition at line 1904 of file swmod3.f90.

1904  real, allocatable :: q_df(:) ! step size of frequency grid

◆ q_dird1

real m_xnldata::q_dird1

Definition at line 1916 of file swmod3.f90.

1916  real q_dird1,q_dird2 ! first and last direction of host model (via XNL_INIT) degrees

◆ q_dird2

real m_xnldata::q_dird2

Definition at line 1916 of file swmod3.f90.

◆ q_dk

real, dimension(:), allocatable m_xnldata::q_dk

Definition at line 1901 of file swmod3.f90.

1901  real, allocatable :: q_dk(:) ! width of wave number bins [1/m]

◆ q_dsig

real, dimension(:), allocatable m_xnldata::q_dsig

Definition at line 1906 of file swmod3.f90.

1906  real, allocatable :: q_dsig(:) ! step size of radian frequency grid

◆ q_dstep

real m_xnldata::q_dstep

Definition at line 1748 of file swmod3.f90.

1748  real q_dstep ! step size for generating BQF files

◆ q_f

real, dimension(:), allocatable m_xnldata::q_f

Definition at line 1903 of file swmod3.f90.

1903  real, allocatable :: q_f(:) ! frequencies accociated to wave number/depth

◆ q_ffac

real m_xnldata::q_ffac

Definition at line 1945 of file swmod3.f90.

1945  real q_ffac ! geometric factor between subsequent frequencies

◆ q_grav

real m_xnldata::q_grav

Definition at line 1601 of file swmod3.f90.

1601  real q_grav ! gravitational acceleration (Earth = 9.81 m/s^2)

◆ q_header

character(len=21) m_xnldata::q_header

Definition at line 1734 of file swmod3.f90.

1734  character(len=21) q_header ! header of Binary Quadruplet File as intended in BQF-file

◆ q_k

real, dimension(:), allocatable m_xnldata::q_k

Definition at line 1900 of file swmod3.f90.

1900  real, allocatable :: q_k(:) ! wave number grid [1/m]

◆ q_kfac

real m_xnldata::q_kfac

Definition at line 1946 of file swmod3.f90.

1946  real q_kfac ! geometric factor between subsequent wave numbers

◆ q_kpow

real, dimension(:), allocatable m_xnldata::q_kpow

Definition at line 1902 of file swmod3.f90.

1902  real, allocatable :: q_kpow(:) ! wave number to a certain power, used in filtering

◆ q_lambda

real m_xnldata::q_lambda

Definition at line 1920 of file swmod3.f90.

1920  real q_lambda ! geometric scaling factor for 'deep' water loci

◆ q_maxdepth

real m_xnldata::q_maxdepth

Definition at line 1918 of file swmod3.f90.

1918  real q_maxdepth ! maximum water depth, set in XNL_INIT, used in Q_CTRGRID

◆ q_mindepth

real m_xnldata::q_mindepth

Definition at line 1919 of file swmod3.f90.

1919  real q_mindepth ! minimum water depth, set in XNL_INIT, used in Q_CTRGRID

◆ q_scale

real m_xnldata::q_scale

Definition at line 1921 of file swmod3.f90.

1921  real q_scale ! additional scale factor resulting from SEARCH for neasrest grid

◆ q_sector

real m_xnldata::q_sector

Definition at line 1747 of file swmod3.f90.

1747  real q_sector ! half plane width in degrees (for iq_grid=1,2)

◆ q_sig

real, dimension(:), allocatable m_xnldata::q_sig

Definition at line 1905 of file swmod3.f90.

1905  real, allocatable :: q_sig(:) ! radian frequencies associated to wave number/depth

◆ q_sk

real, dimension(:), allocatable m_xnldata::q_sk

Definition at line 1897 of file swmod3.f90.

1897  real, allocatable :: q_sk(:) ! step size of extended wave number array

◆ q_version

character(len=60) m_xnldata::q_version

Definition at line 1574 of file swmod3.f90.

1574  character(len=60) q_version ! version string

◆ q_xk

real, dimension(:), allocatable m_xnldata::q_xk

Definition at line 1896 of file swmod3.f90.

1896  real, allocatable :: q_xk(:) ! extended wave number array starting at index 0

◆ qbase

character(len=20) m_xnldata::qbase

Definition at line 1577 of file swmod3.f90.

1577  character(len=20) qbase ! base name for I/O files

◆ qf_dmax

real m_xnldata::qf_dmax

Definition at line 1608 of file swmod3.f90.

1608  real qf_dmax ! maximum directional difference between k1 and k3

◆ qf_error

character(len=20) m_xnldata::qf_error

Definition at line 1578 of file swmod3.f90.

1578  character(len=20) qf_error ! name of file with error messages

◆ qf_frac

real m_xnldata::qf_frac

Definition at line 1609 of file swmod3.f90.

1609  real qf_frac ! fraction of maximum action density to filter

◆ qf_krat

real m_xnldata::qf_krat

Definition at line 1607 of file swmod3.f90.

1607  real qf_krat ! maximum ratio of the interacting wave numbers k1 and k3

◆ qf_tail

real m_xnldata::qf_tail

Definition at line 1602 of file swmod3.f90.

1602  real qf_tail ! power of spectral tail of E(f), e.g. -4,, -4.5, -5

◆ qk_tail

real m_xnldata::qk_tail

Definition at line 1948 of file swmod3.f90.

1948  real qk_tail ! power of spectral tail of N(k), computed from qf_tail

◆ qnl

real, dimension(:,:), allocatable m_xnldata::qnl

Definition at line 1913 of file swmod3.f90.

1913  real, allocatable :: qnl(:,:) ! Nonlinear energy transfer Snl(k,theta)

◆ quad_cple

real, dimension(:,:,:), allocatable m_xnldata::quad_cple

Definition at line 1816 of file swmod3.f90.

1816  real, allocatable :: quad_cple(:,:,:) ! coupling coefficient

◆ quad_ia2

integer, dimension(:,:,:), allocatable m_xnldata::quad_ia2

Definition at line 1800 of file swmod3.f90.

1800  integer, allocatable :: quad_ia2(:,:,:) ! lower direction index of k2

◆ quad_ia4

integer, dimension(:,:,:), allocatable m_xnldata::quad_ia4

Definition at line 1802 of file swmod3.f90.

1802  integer, allocatable :: quad_ia4(:,:,:) ! lower direction index of k4

◆ quad_ik2

integer, dimension(:,:,:), allocatable m_xnldata::quad_ik2

Definition at line 1799 of file swmod3.f90.

1799  integer, allocatable :: quad_ik2(:,:,:) ! lower wave number index of k2

◆ quad_ik4

integer, dimension(:,:,:), allocatable m_xnldata::quad_ik4

Definition at line 1801 of file swmod3.f90.

1801  integer, allocatable :: quad_ik4(:,:,:) ! lower wave number index of k4

◆ quad_jac

real, dimension(:,:,:), allocatable m_xnldata::quad_jac

Definition at line 1815 of file swmod3.f90.

1815  real, allocatable :: quad_jac(:,:,:) ! jacobian term

◆ quad_nloc

integer, dimension(:,:), allocatable m_xnldata::quad_nloc

Definition at line 1798 of file swmod3.f90.

1798  integer, allocatable :: quad_nloc(:,:) ! number of points on locus

◆ quad_sym

real, dimension(:,:,:), allocatable m_xnldata::quad_sym

Definition at line 1814 of file swmod3.f90.

1814  real, allocatable :: quad_sym(:,:,:) ! symmetry factor btween k1-k3 and k1-k4

◆ quad_t2

real, dimension(:,:,:), allocatable m_xnldata::quad_t2

Definition at line 1812 of file swmod3.f90.

1812  real, allocatable :: quad_t2(:,:,:) ! tail factors for k2 wave number

◆ quad_t4

real, dimension(:,:,:), allocatable m_xnldata::quad_t4

Definition at line 1813 of file swmod3.f90.

1813  real, allocatable :: quad_t4(:,:,:) ! tail factors for k4 wave number

◆ quad_w1k2

real, dimension(:,:,:), allocatable m_xnldata::quad_w1k2

Definition at line 1803 of file swmod3.f90.

1803  real, allocatable :: quad_w1k2(:,:,:) ! weight 1 of k2

◆ quad_w1k4

real, dimension(:,:,:), allocatable m_xnldata::quad_w1k4

Definition at line 1807 of file swmod3.f90.

1807  real, allocatable :: quad_w1k4(:,:,:) ! weight 1 of k4

◆ quad_w2k2

real, dimension(:,:,:), allocatable m_xnldata::quad_w2k2

Definition at line 1804 of file swmod3.f90.

1804  real, allocatable :: quad_w2k2(:,:,:) ! weight 2 of k2

◆ quad_w2k4

real, dimension(:,:,:), allocatable m_xnldata::quad_w2k4

Definition at line 1808 of file swmod3.f90.

1808  real, allocatable :: quad_w2k4(:,:,:) ! weight 2 of k4

◆ quad_w3k2

real, dimension(:,:,:), allocatable m_xnldata::quad_w3k2

Definition at line 1805 of file swmod3.f90.

1805  real, allocatable :: quad_w3k2(:,:,:) ! weight 3 of k2

◆ quad_w3k4

real, dimension(:,:,:), allocatable m_xnldata::quad_w3k4

Definition at line 1809 of file swmod3.f90.

1809  real, allocatable :: quad_w3k4(:,:,:) ! weight 3 of k4

◆ quad_w4k2

real, dimension(:,:,:), allocatable m_xnldata::quad_w4k2

Definition at line 1806 of file swmod3.f90.

1806  real, allocatable :: quad_w4k2(:,:,:) ! weight 4 of k2

◆ quad_w4k4

real, dimension(:,:,:), allocatable m_xnldata::quad_w4k4

Definition at line 1810 of file swmod3.f90.

1810  real, allocatable :: quad_w4k4(:,:,:) ! weight 4 of k4

◆ quad_ws

real, dimension (:,:,:), allocatable m_xnldata::quad_ws

Definition at line 1817 of file swmod3.f90.

1817  real, allocatable :: quad_ws (:,:,:) ! (weighted) step size

◆ quad_zz

real, dimension (:,:,:), allocatable m_xnldata::quad_zz

Definition at line 1811 of file swmod3.f90.

1811  real, allocatable :: quad_zz (:,:,:) ! compound product of cple*ds*sym/jac

◆ r_cple

real, dimension(:), allocatable m_xnldata::r_cple

Definition at line 1891 of file swmod3.f90.

◆ r_header

character(len=21) m_xnldata::r_header

Definition at line 1735 of file swmod3.f90.

1735  character(len=21) r_header ! header of Binary Quadruplet File as exists in BQF-file

◆ r_ia2

integer, dimension(:), allocatable m_xnldata::r_ia2

Definition at line 1886 of file swmod3.f90.

1886  integer, allocatable :: r_ia2(:)

◆ r_ia4

integer, dimension(:), allocatable m_xnldata::r_ia4

Definition at line 1888 of file swmod3.f90.

1888  integer, allocatable :: r_ia4(:)

◆ r_ik2

integer, dimension(:), allocatable m_xnldata::r_ik2

Definition at line 1885 of file swmod3.f90.

1885  integer, allocatable :: r_ik2(:)

◆ r_ik4

integer, dimension(:), allocatable m_xnldata::r_ik4

Definition at line 1887 of file swmod3.f90.

1887  integer, allocatable :: r_ik4(:)

◆ r_jac

real, dimension(:), allocatable m_xnldata::r_jac

Definition at line 1891 of file swmod3.f90.

◆ r_sym

real, dimension(:), allocatable m_xnldata::r_sym

Definition at line 1891 of file swmod3.f90.

◆ r_tail2

real, dimension(:), allocatable m_xnldata::r_tail2

Definition at line 1892 of file swmod3.f90.

1892  real, allocatable :: r_tail2(:),r_tail4(:)

◆ r_tail4

real, dimension(:), allocatable m_xnldata::r_tail4

Definition at line 1892 of file swmod3.f90.

◆ r_w1k2

real, dimension(:), allocatable m_xnldata::r_w1k2

Definition at line 1889 of file swmod3.f90.

1889  real, allocatable :: r_w1k2(:),r_w2k2(:),r_w3k2(:),r_w4k2(:)

◆ r_w1k4

real, dimension(:), allocatable m_xnldata::r_w1k4

Definition at line 1890 of file swmod3.f90.

1890  real, allocatable :: r_w1k4(:),r_w2k4(:),r_w3k4(:),r_w4k4(:)

◆ r_w2k2

real, dimension(:), allocatable m_xnldata::r_w2k2

Definition at line 1889 of file swmod3.f90.

◆ r_w2k4

real, dimension(:), allocatable m_xnldata::r_w2k4

Definition at line 1890 of file swmod3.f90.

◆ r_w3k2

real, dimension(:), allocatable m_xnldata::r_w3k2

Definition at line 1889 of file swmod3.f90.

◆ r_w3k4

real, dimension(:), allocatable m_xnldata::r_w3k4

Definition at line 1890 of file swmod3.f90.

◆ r_w4k2

real, dimension(:), allocatable m_xnldata::r_w4k2

Definition at line 1889 of file swmod3.f90.

◆ r_w4k4

real, dimension(:), allocatable m_xnldata::r_w4k4

Definition at line 1890 of file swmod3.f90.

◆ r_ws

real, dimension(:), allocatable m_xnldata::r_ws

Definition at line 1891 of file swmod3.f90.

◆ r_zz

real, dimension(:), allocatable m_xnldata::r_zz

Definition at line 1891 of file swmod3.f90.

1891  real, allocatable :: r_zz(:),r_jac(:),r_cple(:),r_sym(:),r_ws(:)

◆ rel_k

real m_xnldata::rel_k

Definition at line 1925 of file swmod3.f90.

1925  real rel_k ! relative accuracy for equality check of k

◆ s_loc

real, dimension(:), allocatable m_xnldata::s_loc

Definition at line 1824 of file swmod3.f90.

1824  real, allocatable :: s_loc(:) ! coordinate along locus

◆ s_mod

real, dimension(:), allocatable m_xnldata::s_mod

Definition at line 1843 of file swmod3.f90.

1843  real, allocatable :: s_mod(:) ! coordinate along locus

◆ sang

real m_xnldata::sang

Definition at line 1774 of file swmod3.f90.

1774  real sang ! angle of symmytry axis of locus, SANG = PANG +/ pi° (radians)

◆ sk_max

real m_xnldata::sk_max

Definition at line 1898 of file swmod3.f90.

1898  real sk_max ! maximum wave number in extended array

◆ sub_name

character(len=20) m_xnldata::sub_name

Definition at line 1576 of file swmod3.f90.

1576  character(len=20) sub_name ! Name of active subroutine

◆ sym_loc

real, dimension(:), allocatable m_xnldata::sym_loc

Definition at line 1830 of file swmod3.f90.

1830  real, allocatable :: sym_loc(:) ! factor for symmetry between k3 and k4

◆ sym_mod

real, dimension(:), allocatable m_xnldata::sym_mod

Definition at line 1847 of file swmod3.f90.

1847  real, allocatable :: sym_mod(:) ! factor for symmetry between k3 and k4

◆ t_cple

real, dimension(:), allocatable m_xnldata::t_cple

Definition at line 1879 of file swmod3.f90.

1879  real, allocatable :: t_cple(:) ! transformed coupling coefficient

◆ t_ia2

integer, dimension(:), allocatable m_xnldata::t_ia2

Definition at line 1864 of file swmod3.f90.

1864  integer, allocatable :: t_ia2(:) ! transformed direction for k2

◆ t_ia4

integer, dimension(:), allocatable m_xnldata::t_ia4

Definition at line 1866 of file swmod3.f90.

1866  integer, allocatable :: t_ia4(:) ! transformed weight for k4

◆ t_ik2

integer, dimension(:), allocatable m_xnldata::t_ik2

Definition at line 1863 of file swmod3.f90.

1863  integer, allocatable :: t_ik2(:) ! transformed weight for k2-magnitude

◆ t_ik4

integer, dimension(:), allocatable m_xnldata::t_ik4

Definition at line 1865 of file swmod3.f90.

1865  integer, allocatable :: t_ik4(:) ! transformed tail factor for k2

◆ t_jac

real, dimension(:), allocatable m_xnldata::t_jac

Definition at line 1880 of file swmod3.f90.

1880  real, allocatable :: t_jac(:) ! tranformed jacobian term

◆ t_sym

real, dimension(:), allocatable m_xnldata::t_sym

Definition at line 1878 of file swmod3.f90.

1878  real, allocatable :: t_sym(:) ! transformed symetry factor

◆ t_tail2

real, dimension(:), allocatable m_xnldata::t_tail2

Definition at line 1876 of file swmod3.f90.

1876  real, allocatable :: t_tail2(:) ! tail factor for k2

◆ t_tail4

real, dimension(:), allocatable m_xnldata::t_tail4

Definition at line 1877 of file swmod3.f90.

1877  real, allocatable :: t_tail4(:) ! tail factor for k4

◆ t_w1k2

real, dimension(:), allocatable m_xnldata::t_w1k2

Definition at line 1867 of file swmod3.f90.

1867  real, allocatable :: t_w1k2(:) ! transformed weight 1 for k2

◆ t_w1k4

real, dimension(:), allocatable m_xnldata::t_w1k4

Definition at line 1871 of file swmod3.f90.

1871  real, allocatable :: t_w1k4(:) ! transformed weight 1 for k4

◆ t_w2k2

real, dimension(:), allocatable m_xnldata::t_w2k2

Definition at line 1868 of file swmod3.f90.

1868  real, allocatable :: t_w2k2(:) ! transformed weight 2 for k2

◆ t_w2k4

real, dimension(:), allocatable m_xnldata::t_w2k4

Definition at line 1872 of file swmod3.f90.

1872  real, allocatable :: t_w2k4(:) ! transformed weight 2 for k4

◆ t_w3k2

real, dimension(:), allocatable m_xnldata::t_w3k2

Definition at line 1869 of file swmod3.f90.

1869  real, allocatable :: t_w3k2(:) ! transformed weight 3 for k2

◆ t_w3k4

real, dimension(:), allocatable m_xnldata::t_w3k4

Definition at line 1873 of file swmod3.f90.

1873  real, allocatable :: t_w3k4(:) ! transformed weight 3 for k4

◆ t_w4k2

real, dimension(:), allocatable m_xnldata::t_w4k2

Definition at line 1870 of file swmod3.f90.

1870  real, allocatable :: t_w4k2(:) ! transformed weight 4 for k2

◆ t_w4k4

real, dimension(:), allocatable m_xnldata::t_w4k4

Definition at line 1874 of file swmod3.f90.

1874  real, allocatable :: t_w4k4(:) ! transformed weight 4 for k4

◆ t_ws

real, dimension(:), allocatable m_xnldata::t_ws

Definition at line 1881 of file swmod3.f90.

1881  real, allocatable :: t_ws(:) ! transformed weighted/step size

◆ t_zz

real, dimension(:), allocatable m_xnldata::t_zz

Definition at line 1875 of file swmod3.f90.

1875  real, allocatable :: t_zz(:) ! product term

◆ wa_k2

real, dimension(:), allocatable m_xnldata::wa_k2

Definition at line 1858 of file swmod3.f90.

1858  real, allocatable :: wa_k2(:) ! position of k2 and k4 wave number

◆ wa_k4

real, dimension(:), allocatable m_xnldata::wa_k4

Definition at line 1859 of file swmod3.f90.

1859  real, allocatable :: wa_k4(:) ! w.r.t. discrete a-grid

◆ wk_k2

real, dimension(:), allocatable m_xnldata::wk_k2

Definition at line 1856 of file swmod3.f90.

1856  real, allocatable :: wk_k2(:) ! position of k2 and k4 wave number

◆ wk_k4

real, dimension(:), allocatable m_xnldata::wk_k4

Definition at line 1857 of file swmod3.f90.

1857  real, allocatable :: wk_k4(:) ! w.r.t. discrete k-grid

◆ wk_max

real m_xnldata::wk_max

Definition at line 1763 of file swmod3.f90.

1763  real wk_max ! maximum weight for wave number interpolation, set in Q_INIT

◆ wt_k2

real, dimension(:), allocatable m_xnldata::wt_k2

Definition at line 1860 of file swmod3.f90.

1860  real, allocatable :: wt_k2(:) ! weight factor in tail,

◆ wt_k4

real, dimension(:), allocatable m_xnldata::wt_k4

Definition at line 1861 of file swmod3.f90.

1861  real, allocatable :: wt_k4(:) ! wt==1 for wave numbers inside k-grid

◆ x2_loc

real, dimension(:), allocatable m_xnldata::x2_loc

Definition at line 1821 of file swmod3.f90.

1821  real, allocatable :: x2_loc(:) ! k2x coordinates around locus

◆ x2_mod

real, dimension(:), allocatable m_xnldata::x2_mod

Definition at line 1838 of file swmod3.f90.

1838  real, allocatable :: x2_mod(:) ! k2x coordinates along locus

◆ x4_loc

real, dimension(:), allocatable m_xnldata::x4_loc

Definition at line 1825 of file swmod3.f90.

1825  real, allocatable :: x4_loc(:) ! k4x coordinates around locus

◆ x4_mod

real, dimension(:), allocatable m_xnldata::x4_mod

Definition at line 1840 of file swmod3.f90.

1840  real, allocatable :: x4_mod(:) ! k4x coordinates along locus

◆ xang

real m_xnldata::xang

Definition at line 1775 of file swmod3.f90.

1775  real xang ! angle of locus for the case that w1=w3, Xang=atan2(-px,py), (radians)

◆ y2_loc

real, dimension(:), allocatable m_xnldata::y2_loc

Definition at line 1822 of file swmod3.f90.

1822  real, allocatable :: y2_loc(:) ! k2y coordinates around locus

◆ y2_mod

real, dimension(:), allocatable m_xnldata::y2_mod

Definition at line 1839 of file swmod3.f90.

1839  real, allocatable :: y2_mod(:) ! k2y coordinates along locus

◆ y4_loc

real, dimension(:), allocatable m_xnldata::y4_loc

Definition at line 1826 of file swmod3.f90.

1826  real, allocatable :: y4_loc(:) ! k4y coordinates around locus

◆ y4_mod

real, dimension(:), allocatable m_xnldata::y4_mod

Definition at line 1841 of file swmod3.f90.

1841  real, allocatable :: y4_mod(:) ! k4y coordinates along locus

◆ z_loc

real, dimension(:), allocatable m_xnldata::z_loc

Definition at line 1823 of file swmod3.f90.

1823  real, allocatable :: z_loc(:) ! data value around locus

◆ z_mod

real, dimension(:), allocatable m_xnldata::z_mod

Definition at line 1842 of file swmod3.f90.

1842  real, allocatable :: z_mod(:) ! data value around locus
Generated by   doxygen 1.8.15