! File: example2.f90
!
! This file is part of the SpanLib library.
! Copyright (C) 2006  Stephane Raynaud
! Contact: stephane dot raynaud at gmail dot com
!
! This library is free software; you can redistribute it and/or
! modify it under the terms of the GNU Lesser General Public
! License as published by the Free Software Foundation; either
! version 2.1 of the License, or (at your option) any later version.
!
! This library is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
! Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public
! License along with this library; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

program example2

	! This simple example shows how to use PCA and SVD from this package.
	! Warning: it requires netcdf for in/outputs.
	!
	! This example works in a very similar way to the first fortran example,
	! with the same initial dataset.
	!
	! To mimics the use of two different datasets, two geographical
	! regions are decomposed using SVD. As for MSSA, a pre-PCA is
	! performed (independantly for the two regions).
	! One region is situated in the east of the basin, the other
	! one is on the west.
	! The dominant EOFs from the SVD decomposition are reconstructed
	! back to the physical space and stored in the output netcdf file
	! along with their PCs.
	!
	! Note:
	!	This example should run only a few seconds.
	!	If it is not the case, your BLAS/LAPACK librairy is not optimized.

	use spanlib
	use netcdf

	implicit none

	! Parameters
	! ----------
	integer,parameter :: pcaNkeep=10, svdNkeep=5,&
		& lons1(2)=(/70,150/),lats1(2)=(/16,45/),& ! East
		& lons2(2)=(/10,40/),lats2(2)=(/12,49/)    ! West
	real(wp), parameter ::new_missing_value=-999.d0
	character(len=20), parameter :: input_nc_file="data2.cdf", &
		& output_nc_file="output_fortran2.nc", var_name='ssta'

	! Other declarations
	! ------------------
	real(wp), allocatable :: lon1(:), lat1(:), &
		& lon2(:), lat2(:), time(:), sst1(:,:,:), sst2(:,:,:)
	logical, allocatable :: mask1(:,:),mask2(:,:)
	real(wp), allocatable :: packed_sst1(:,:),packed_sst2(:,:),&
		& pcaSstRec1(:,:,:),pcaSstRec2(:,:,:)
	real(wp), allocatable :: svdEv(:), &
		& pcaEofs1(:,:),pcaEofs2(:,:),pcaPcs1(:,:),pcaPcs2(:,:), &
		& svdEofs1(:,:),svdEofs2(:,:),svdPcs1(:,:),svdPcs2(:,:)
	real(wp), allocatable :: &
		& svdEofsRec1(:,:,:), svdEofsRec2(:,:,:), &
		& packed_svdEofsRec1(:,:), packed_svdEofsRec2(:,:), &
		& packed_svdSstRec1(:,:), packed_svdSstRec2(:,:), &
		& packed_pcaSstRec1(:,:), packed_pcaSstRec2(:,:)
	character(len=20) :: lon_units, lat_units, var_units, &
		&	lon_name, lat_name, time_name, time_units
	integer :: ncid, dimids(6), varids(6), sstids(9)
	integer(kind=4) :: i,nlon1,nlat1,nlon2,nlat2,ntime,ns1,ns2
	real(wp) :: missing_value

	! Precision
	! ---------
	if(wp==8)then
		print*,'Using double precision'
	else
		print*,'Using simple precision'
	end if

	! Get the initial sst field from the netcdf file
	! ----------------------------------------------
	print*,'Reading inputs...'
	call err(nf90_open(input_nc_file, nf90_nowrite, ncid))
	call err(nf90_inq_varid(ncid, var_name, sstids(1)))
	! Dimensions
	nlon1 = lons1(2)-lons1(1)+1 ;	nlat1 = lats1(2)-lats1(1)+1
	nlon2 = lons2(2)-lons2(1)+1 ; nlat2 = lats2(2)-lats2(1)+1
	call err(nf90_inquire_variable(ncid, sstids(1), dimids=dimids(1:3)))
	call err(nf90_inquire_dimension(ncid,dimids(1),name=lon_name))
	call err(nf90_inquire_dimension(ncid,dimids(2),name=lat_name))
	call err(nf90_inquire_dimension(ncid, dimids(3), &
		&	name=time_name, len=ntime))
	! Allocations
	allocate(sst1(nlon1,nlat1,ntime),sst2(nlon2,nlat2,ntime))
	allocate(mask1(nlon1,nlat1),mask2(nlon2,nlat2))
	allocate(lon1(nlon1),lat1(nlat1))
	allocate(lon2(nlon2),lat2(nlat2))
	allocate(time(ntime))
	! SST boxes and attributes
	call err(nf90_get_var(ncid, sstids(1), sst1,&
		& start=(/lons1(1),lats1(1),1/), &
		& count=(/lons1(2)-lons1(1)+1,lats1(2)-lats1(1)+1,ntime/)))
	call err(nf90_get_var(ncid, sstids(1), sst2,&
		& start=(/lons2(1),lats2(1),1/), &
		& count=(/lons2(2)-lons2(1)+1,lats2(2)-lats2(1)+1,ntime/)))
	call err(nf90_get_att(ncid,sstids(1),'missing_value',missing_value))
	call err(nf90_get_att(ncid,sstids(1),'units',var_units))
	! Longitudes
	call err(nf90_inq_varid(ncid, lon_name, varids(1)))
	call err(nf90_get_var(ncid, varids(1), lon1, &
		& start=(/lons1(1)/), count=(/lons1(2)-lons1(1)+1/)))
	call err(nf90_get_att(ncid, varids(1), 'units', lon_units))
	call err(nf90_get_var(ncid, varids(1), lon2, &
		& start=(/lons2(1)/), count=(/lons2(2)-lons2(1)+1/)))
	! Latitudes
	call err(nf90_inq_varid(ncid, lat_name, varids(1)))
	call err(nf90_get_var(ncid, varids(1), lat1, &
		& start=(/lats1(1)/), count=(/lats1(2)-lats1(1)+1/)))
	call err(nf90_get_att(ncid, varids(1), 'units', lat_units))
	call err(nf90_get_var(ncid, varids(1), lat2, &
		& start=(/lats2(1)/), count=(/lats2(2)-lats2(1)+1/)))
	! Time
	call err(nf90_inq_varid(ncid, time_name, varids(1)))
	call err(nf90_get_var(ncid, varids(1), time))
	call err(nf90_get_att(ncid, varids(1), 'units', time_units))
	call err(nf90_close(ncid))

	! Format (pack) data to have only one space dimension
	! ---------------------------------------------------
	print*,'Packing...'
	mask1 = (sst1(:,:,1) /= missing_value)
	mask2 = (sst2(:,:,1) /= missing_value)
	ns1 = count(mask1) ; ns2 = count(mask2)
	allocate(packed_sst1(ns1, ntime))
	allocate(packed_sst2(ns2, ntime))
	do i=1, ntime
		packed_sst1(:,i) = pack(sst1(:,:,i), mask1)
		packed_sst2(:,i) = pack(sst2(:,:,i), mask2)
	end do
	where(sst1==missing_value)sst1 = new_missing_value
	where(sst2==missing_value)sst2 = new_missing_value

	! Perform a PCA to reduce the d.o.f
	! ---------------------------------
	print*,'[sl_pca] Pre-PCA ...'
	allocate(pcaEofs1(ns1, pcaNkeep))
	allocate(pcaPcs1(ntime,pcaNkeep))
	call sl_pca(packed_sst1, pcaNkeep, xeof=pcaEofs1, pc=pcaPcs1)
	allocate(pcaEofs2(ns2, pcaNkeep))
	allocate(pcaPcs2(ntime,pcaNkeep))
	call sl_pca(packed_sst2, pcaNkeep, xeof=pcaEofs2, pc=pcaPcs2)
	deallocate(packed_sst1,packed_sst2)

	! Perform a SVD on previous PCs
	! -----------------------------
	print*,'[sl_svd] SVD...'
	allocate(svdEofs1(pcaNkeep,svdNkeep),svdPcs1(ntime,svdNkeep))
	allocate(svdEofs2(pcaNkeep,svdNkeep),svdPcs2(ntime,svdNkeep))
	allocate(svdEv(svdNkeep))
	call sl_svd(transpose(pcaPcs1),transpose(pcaPcs2),&
		& svdNkeep,leof=svdEofs1,reof=svdEofs2,&
		& lpc=svdPcs1,rpc=svdPcs2,ev=svdEv)
	deallocate(pcaPcs1,pcaPcs2)

	! Swicth SVD EOFs to the physical space (!)
	! -----------------------------------------
	print*,'[sl_pca_rec] Back EOF to the physical space ...'
	allocate(packed_svdEofsRec1(ns1,svdNkeep))
	allocate(packed_svdEofsRec2(ns2,svdNkeep))
	call sl_pca_rec(pcaEofs1, transpose(svdEofs1), packed_svdEofsRec1)
	call sl_pca_rec(pcaEofs2, transpose(svdEofs2), packed_svdEofsRec2)

	! Switch SST to the physical space
	! --------------------------------
	! SVD to pre-PCA
	print*,'[sl_pca_rec] Back SST to the physical space ...'
	allocate(packed_svdSstRec1(pcaNkeep,ntime))
	allocate(packed_svdSstRec2(pcaNkeep,ntime))
	call sl_pca_rec(svdEofs1,svdPcs1,packed_svdSstRec1)
	call sl_pca_rec(svdEofs2,svdPcs2,packed_svdSstRec2)
	! Pre-PCA to physical
	allocate(packed_pcaSstRec1(ns1,ntime),packed_pcaSstRec2(ns2,ntime))
	call sl_pca_rec(pcaEofs1,transpose(packed_svdSstRec1),&
		& packed_pcaSstRec1)
	call sl_pca_rec(pcaEofs2,transpose(packed_svdSstRec2),&
		& packed_pcaSstRec2)
	deallocate(pcaEofs1,svdEofs1,pcaEofs2,svdEofs2)
	deallocate(packed_svdSstRec1,packed_svdSstRec2)

	! Unpacking
	! ---------
	print*,'Unpacking...'
	allocate(svdEofsRec1(nlon1,nlat1,svdNkeep))
	allocate(svdEofsRec2(nlon2,nlat2,svdNkeep))
	allocate(pcaSstRec1(nlon1,nlat1,ntime))
	allocate(pcaSstRec2(nlon2,nlat2,ntime))
	! Eofs
	do i=1, svdNkeep
		svdEofsRec1(:,:,i) = unpack(packed_svdEofsRec1(:,i), &
			& mask1, new_missing_value)
		svdEofsRec2(:,:,i) = unpack(packed_svdEofsRec2(:,i), &
			& mask2, new_missing_value)
		where(.not.mask1)svdEofsRec1(:,:,i) = new_missing_value
		where(.not.mask2)svdEofsRec2(:,:,i) = new_missing_value
	end do
	! SST
	do i=1, ntime
		pcaSstRec1(:,:,i) = unpack(packed_pcaSstRec1(:,i), &
			& mask1, new_missing_value)
		pcaSstRec2(:,:,i) = unpack(packed_pcaSstRec2(:,i), &
			& mask2, new_missing_value)
		where(.not.mask1)pcaSstRec1(:,:,i) = new_missing_value
		where(.not.mask2)pcaSstRec2(:,:,i) = new_missing_value
	end do

	! Write out the phase composites of the first oscillation
	! -------------------------------------------------------
	print*,'Writing out...'
	! File
	call err(nf90_create(output_nc_file, nf90_write, ncid))
	! Dimensions
	call err(nf90_def_dim(ncid, 'lon_box1', nlon1, dimids(1)))
	call err(nf90_def_dim(ncid, 'lat_box1', nlat1, dimids(2)))
	call err(nf90_def_dim(ncid, 'lon_box2', nlon2, dimids(3)))
	call err(nf90_def_dim(ncid, 'lat_box2', nlat2, dimids(4)))
	call err(nf90_def_dim(ncid, 'time', ntime, dimids(5)))
	call err(nf90_def_dim(ncid, 'mode', svdNkeep, dimids(6)))

	! Box 1
	call err(nf90_def_var(ncid, 'lon_box1', nf90_float, dimids(1), &
		& varids(1)))
	call err(nf90_put_att(ncid, varids(1), 'long_name', &
		& 'Longitude'))
	call err(nf90_put_att(ncid, varids(1), 'units', lon_units))
	call err(nf90_def_var(ncid, 'lat_box1', nf90_float, dimids(2), &
		& varids(2)))
	call err(nf90_put_att(ncid, varids(2), 'long_name', &
		& 'Latitude'))
	call err(nf90_put_att(ncid, varids(2), 'units', lat_units))
	! Box 2
	call err(nf90_def_var(ncid, 'lon_box2', nf90_float, dimids(3), &
		& varids(3)))
	call err(nf90_put_att(ncid, varids(3), 'long_name', &
		& 'Longitude'))
	call err(nf90_put_att(ncid, varids(3), 'units', lon_units))
	call err(nf90_def_var(ncid, 'lat_box2', nf90_float, dimids(4), &
		& varids(4)))
	call err(nf90_put_att(ncid, varids(4), 'long_name', &
		& 'Latitude'))
	call err(nf90_put_att(ncid, varids(4), 'units', lat_units))
	! Time
	call err(nf90_def_var(ncid, 'time', nf90_float, dimids(5), &
		& varids(5)))
	call err(nf90_put_att(ncid, varids(5), 'long_name', 'Time'))
	call err(nf90_put_att(ncid, varids(5), 'units', time_units))
	! Mode
	call err(nf90_def_var(ncid, 'mode', nf90_float, dimids(6), &
		& varids(6)))
	call err(nf90_put_att(ncid, varids(6), 'long_name', 'Mode'))
	call err(nf90_put_att(ncid, varids(6), 'units', 'level'))
	! Original fields
	! * box1
	call err(nf90_def_var(ncid, 'sst_box1', nf90_float, &
		& (/dimids(1),dimids(2),dimids(5)/), sstids(1)))
	call err(nf90_put_att(ncid, sstids(1), 'long_name', &
		& 'SST anomaly / original field / box 1'))
	call err(nf90_put_att(ncid, sstids(1), 'units', var_units))
	call err(nf90_put_att(ncid, sstids(1), 'missing_value', &
		& new_missing_value))
	! * box2
	call err(nf90_def_var(ncid, 'sst_box2', nf90_float, &
	 & (/dimids(3),dimids(4),dimids(5)/), sstids(2)))
	call err(nf90_put_att(ncid, sstids(2), 'long_name', &
		& 'SST anomaly / original field / box 2'))
	call err(nf90_put_att(ncid, sstids(2), 'units', var_units))
	call err(nf90_put_att(ncid, sstids(2), 'missing_value', &
		& new_missing_value))
	! SVD EOFs
	! * box1
	call err(nf90_def_var(ncid, 'eofs_box1', nf90_float, &
	 & (/dimids(1),dimids(2),dimids(6)/),sstids(3)))
	call err(nf90_put_att(ncid, sstids(3), 'long_name', &
		& 'SVD EOFs of SST anomaly / box 1'))
	call err(nf90_put_att(ncid, sstids(3), 'missing_value', &
		& new_missing_value))
	! * box2
	call err(nf90_def_var(ncid, 'eofs_box2', nf90_float, &
	 & (/dimids(3),dimids(4),dimids(6)/),sstids(4)))
	call err(nf90_put_att(ncid, sstids(4), 'long_name', &
		& 'SVD EOFs of SST anomaly / box 2'))
	call err(nf90_put_att(ncid, sstids(4), 'missing_value', &
		& new_missing_value))
	! SVD PCs
	! * Box 1
	call err(nf90_def_var(ncid, 'pcs_box1', nf90_float, &
		& (/dimids(5),dimids(6)/),sstids(5)))
	call err(nf90_put_att(ncid, sstids(5), 'long_name', &
		& 'SVD EOFs of SST anomaly / box 1'))
	call err(nf90_put_att(ncid, sstids(5), 'units', var_units))
	call err(nf90_put_att(ncid, sstids(5), 'missing_value', &
		& new_missing_value))
	! * Box 2
	call err(nf90_def_var(ncid, 'pcs_box2', nf90_float, &
		& (/dimids(5),dimids(6)/),sstids(6)))
	call err(nf90_put_att(ncid, sstids(6), 'long_name', &
		& 'SVD EOFs of SST anomaly / box 2'))
	call err(nf90_put_att(ncid, sstids(6), 'units', var_units))
	call err(nf90_put_att(ncid, sstids(6), 'missing_value', &
		& new_missing_value))
	! SVD eigen values
	call err(nf90_def_var(ncid, 'ev', nf90_float, &
		& dimids(6),sstids(7)))
	call err(nf90_put_att(ncid, sstids(7), 'long_name', &
		& 'Eigen values'))
	! Reconstructed SST
	! * box1
	call err(nf90_def_var(ncid, 'sstrec_box1', nf90_float, &
	 & (/dimids(1),dimids(2),dimids(5)/),sstids(8)))
	call err(nf90_put_att(ncid, sstids(8), 'long_name', &
		& 'Reconstructed SST anomaly / box 1'))
	call err(nf90_put_att(ncid, sstids(8), 'missing_value', &
		& new_missing_value))
	! * box2
	call err(nf90_def_var(ncid, 'sstrec_box2', nf90_float, &
	 & (/dimids(3),dimids(4),dimids(5)/),sstids(9)))
	call err(nf90_put_att(ncid, sstids(9), 'long_name', &
		& 'Reconstructed SST anomaly / box 2'))
	call err(nf90_put_att(ncid, sstids(9), 'missing_value', &
		& new_missing_value))

	! Values
	call err(nf90_enddef(ncid))
	call err(nf90_put_var(ncid, varids(1), lon1))
	call err(nf90_put_var(ncid, varids(2), lat1))
	call err(nf90_put_var(ncid, varids(3), lon2))
	call err(nf90_put_var(ncid, varids(4), lat2))
	call err(nf90_put_var(ncid, varids(5), time))
	call err(nf90_put_var(ncid, varids(6), &
		& float((/(i,i=1,svdNkeep)/))))
	call err(nf90_put_var(ncid, sstids(1), sst1))
	call err(nf90_put_var(ncid, sstids(2), sst2))
	call err(nf90_put_var(ncid, sstids(3), svdEofsRec1))
	call err(nf90_put_var(ncid, sstids(4), svdEofsRec2))
	call err(nf90_put_var(ncid, sstids(5), svdPcs1))
	call err(nf90_put_var(ncid, sstids(6), svdPcs2))
	call err(nf90_put_var(ncid, sstids(7), svdEv))
	call err(nf90_put_var(ncid, sstids(8), pcaSstRec1))
	call err(nf90_put_var(ncid, sstids(9), pcaSstRec2))

	call err(nf90_close(ncid))

end program example2

subroutine err(jstatus)

	use netcdf

	integer :: jstatus

	if (jstatus .ne. nf90_noerr) then
		print *, trim(nf90_strerror(jstatus))
		stop
	end if

end subroutine err


global{
  int x = 8;
}

header{
  int fibo(int n);
}

int main(){
  int res = fibo(x);

  print("Fibo de: ");
  print(x);
  print(" es :");
  print(res);
  print("\n");
}

int fibo(int n){
  if (n == 1){
    return 1;
  }elif(n == 0){
    return 0;
  }
  return fibo(n - 1) + fibo(n - 2);
}


!!## SUBROUTINE MODULE: <pQuadrature_GL>
MODULE SUB_pQuadrature_GL
!!### PURPOSE
!! Set up an polar-angle $[0,\Pi]$
!! Quadrature using the Gauss-Legendre quadrature set.

!!### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!### EXTERNAL PROCEDURES
USE SUB_Quadrature_GL                          !!((05-B-SUB_Quadrature_GL.f90))
USE SUB_CLEAR                                  !!((04-A-SUB_CLEAR.f90))
USE FUN_Reverse                                !!((04-A-FUN_Reverse.f90))

!!### DEFAULT IMPLICIT
IMPLICIT NONE

!!### DEFAULT ACCESS
PRIVATE

!!### PROCEDURE LISTING
INTERFACE pQuadrature_GL
 MODULE PROCEDURE pQuadrature_GL_Rsp
 MODULE PROCEDURE pQuadrature_GL_Rdp
END INTERFACE

!!### PUBLIC ACCESS LIST
PUBLIC :: pQuadrature_GL

!!### MODULE PROCEDURES
CONTAINS

!!### PURE SUBROUTINE: <pQuadrature_GL_Rsp>
PURE SUBROUTINE pQuadrature_GL_Rsp( pOrder , xp,wp , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-B-SUB_pQuadrature_GL.f90.hdr"
!!--begin--
INCLUDE "06-B-SUB_pQuadrature_GL.f90.bdy"
!!--end--
END SUBROUTINE

!!### PURE SUBROUTINE: <pQuadrature_GL_Rdp>
PURE SUBROUTINE pQuadrature_GL_Rdp( pOrder , xp,wp , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-B-SUB_pQuadrature_GL.f90.hdr"
!!--begin--
INCLUDE "06-B-SUB_pQuadrature_GL.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE


!! Defines basic types
!!
!! Most data in _BoxLib_ applications can be represented
!! with default types.  The exception is that for almost all
!! cases we need to use double precision floats.

module bl_types

  implicit none

  !! Double precision floating point data are declared as
  !! REAL(KIND=dp_t), this is akin to the old non-standard
  !! REAL*8, or DOUBLE PRECISION

  ! integer, parameter :: dp_t = kind(0.0d0)
  integer, parameter, public :: dp_t = selected_real_kind(15,307)

  !! Single precision floating point data are declared as
  !! REAL(kind=sp_t), or simply as REAL.

  ! integer, parameter :: sp_t = kind(0.0)
  integer, parameter, public :: sp_t = selected_real_kind(6, 37)

  !! Quad precision floating point data
  !! This is tricky, by definition a selected_real_kind returns -1 if
  !! type with required precision and range can't be found, so if we don't
  !! have extended precision reals on this processor, just use dp
  integer, parameter, private :: qp_t_0 = selected_real_kind(30,1000)
  integer, parameter, public :: qp_t = (1 + sign(1,qp_t_0))/2*qp_t_0 + (1 - sign(1,qp_t_0))/2*dp_t

  !! A long long data type used to attempt to get sufficient
  !! decimal digits to compute box volumes.
  integer, parameter, private :: i4_t = selected_int_kind(9)
  integer, parameter, private :: i8_t = selected_int_kind(15)
  ! integer, parameter, public :: ll_t = selected_int_kind(15)
  integer, parameter, public :: ll_t = (1 + sign(1,i8_t))/2*i8_t + (1 - sign(1,i8_t))/2*i4_t

  !! Prints useful type information for some of the basic type
  public :: bl_types_info

!  logical, private, parameter :: bigendian = IACHAR(TRANSFER(1,"a")) == 0

contains

  subroutine bl_types_info(unit)
    integer, intent(in) :: unit
    write(unit=unit,fmt="(A)") "BL_TYPES_INFO"
    write(unit=unit,fmt="(2X,A)") "Real Types"

    write(unit=unit,fmt="(2x,A)") "  NAME   KIND RANGE PRECISION  DIGITS"
    write(unit=unit,fmt=100) &
         "  DP_T = ", dp_t, range(0.0_dp_t), precision(0.0_dp_t), digits(0.0_dp_t)
    write(unit=unit,fmt=100) &
         "  SP_T = ", sp_t, range(0.0_sp_t), precision(0.0_sp_t), digits(0.0_sp_t)
    if ( qp_t_0 > 0 ) then
       write(unit=unit,fmt="(2x,A,I4)") "QP_T_0 = ", qp_t_0
    else
       write(unit=unit,fmt="(2x,A)") &
            "QP_T_0 = Not Defined: see bl_types.f90 for possible adjustments"
    end if
    write(unit=unit,fmt=100) &
         "QP_T   = ", qp_t, range(0.0_qp_t), precision(0.0_qp_t), digits(0.0_qp_t)

    write(unit=unit,fmt="(2X,A)") "Integer Types"
    write(unit=unit,fmt="(2x,A)")    "  NAME   KIND RANGE  DIGITS"
    write(unit=unit,fmt=200) "  i4_T = ", &
         i4_t, range(0_i4_t), digits(0_i4_t)
    if ( i8_t > 0 ) then
       write(unit=unit,fmt="(2x,A,i4)") "  i8_T = ", i8_t
    else
       write(unit=unit,fmt="(2x,A)") &
            "  i8_T = Not Defined: see bl_types.f90 for possible adjustments"
    end if
    write(unit=unit,fmt=200) "  LL_T = ", ll_t, range(0_ll_t), digits(0_ll_t)
100 format(2x,A,I4,2X,I4,I10, I8)
200 format(2x,A,I4,2X,I4,I8)
  end subroutine bl_types_info

!  function bl_is_bigendian() result(r)
!    logical :: r
!    r = bigendian
!  end function bl_is_bigendian

  function quad_precision_supported()
    logical :: quad_precision_supported
    quad_precision_supported = qp_t_0 .eq. qp_t
  end function quad_precision_supported

  function int8_supported()
    logical :: int8_supported
    int8_supported = i8_t .eq. ll_t
  end function int8_supported

end module bl_types


<ompts:test>
<ompts:testdescription>Test which checks the omp do private clause by counting up a variable in a parallelized loop. Each thread has a private variable (1) and an variable (2) declared by for private. First it stores the result of its last iteration in variable (2). Then this thread waits some time before it stores the value of the variable (2) in its private variable (1). At the beginning of the next iteration the value of (1) is assigned to (2). At the end all private variables (1) are added to a total sum in a critical section and compared with the correct result.</ompts:testdescription>
<ompts:version>2.0</ompts:version>
<ompts:directive>omp do private</ompts:directive>
<ompts:dependences>omp parallel private, omp flush, omp critical</ompts:dependences>
<ompts:testcode>
      SUBROUTINE do_some_work()
        IMPLICIT NONE
        INTEGER i
        INTRINSIC sqrt
        DOUBLE PRECISION sum

        INCLUDE "omp_testsuite.f"
        sum=0.0
        DO i=0, LOOPCOUNT-1
          sum = sum + sqrt(REAL(i))
        ENDDO

      END

      INTEGER FUNCTION <ompts:testcode:functionname>do_private</ompts:testcode:functionname>()
        IMPLICIT NONE
        INTEGER sum, known_sum
<ompts:orphan:vars>
        INTEGER sum0, sum1, i
        COMMON /orphvars/ sum0, sum1, i
</ompts:orphan:vars>

        INCLUDE "omp_testsuite.f"

        sum  = 0
        sum0 = 0
        sum1 = 0

!$omp parallel private(sum1)
        sum0 = 0
        sum1 = 0

<ompts:orphan>
!$omp do <ompts:check>private(sum0)</ompts:check> schedule(static,1)
        DO i=1, LOOPCOUNT
          sum0 = sum1
!$omp flush
          sum0 = sum0 + i
          CALL do_some_work()
!$omp flush
!          print *, sum0
          sum1 = sum0
        END DO
!$omp end do
</ompts:orphan>

!$omp critical
        sum = sum + sum1
!$omp end critical
!$omp end parallel

        known_sum = (LOOPCOUNT*(LOOPCOUNT+1))/2
!        print *, "sum:", sum, "known_sum", known_sum
        IF ( known_sum .EQ. sum) THEN
          <testfunctionname></testfunctionname> = 1
        ELSE
          <testfunctionname></testfunctionname> = 0
        END IF
      END FUNCTION
</ompts:testcode>
</ompts:test>


program ch1204
    ! Simple Transformational Use
    implicit none

    real, dimension(1:5) :: x = [ 1., 2., 3., 4., 5. ]

    print *, 'sine of ', x, ' = ', sin(x)
    print *, 'sum of ', x, ' = ', sum(x)
end program


*----------------------------------------------------------------------*
      subroutine get_symblk_rank1(xblk,xfull,sym,psign,
     &                            ndimt,ndim,nsym)
*----------------------------------------------------------------------*
*     extract symmetry block from rank 1 matrix given in full form
*     xfull is in upper triangular form
*     psign = +1 for symmetric matrix
*     psign = -1 for anti-symmetric matrix
*     adapted from jeppe olsen
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
      include 'multd2h.h'

      integer, parameter ::
     &     ntest = 00

      integer, intent(in) ::
     &     sym, nsym, ndim(nsym), ndimt
      real(8), intent(in) ::
     &     xfull(*), psign
      real(8), intent(out) ::
     &     xblk(*)

      integer ::
     &     irsym, icsym, isym, nrow, ncol,
     &     irow, icol, ibrow, ibcol, ioff,
     &     icabs, irabs, icrmin, icrmax, form
      real(8) ::
     &     fac

      if (ntest.ge.100) then
        call write_title(lulog,wst_dbg_subr,'get_symblk_rank1')
        write(lulog,*) 'symmetry of block: ',sym
        write(lulog,*) 'input matrix:'
        call prtrlt(xfull,ndimt)
      end if

      ioff = 0
      do irsym = 1, nsym
        icsym = multd2h(sym,irsym)

        nrow = ndim(irsym)
        ncol = ndim(icsym)

        ibrow = 1
        do isym = 1, irsym-1
          ibrow = ibrow + ndim(isym)
        end do
        ibcol = 1
        do isym = 1, icsym-1
          ibcol = ibcol + ndim(isym)
        end do

        do irow = 1, nrow
          irabs = ibrow + irow-1
          do icol = 1, ncol
            icabs = ibcol + icol-1
            icrmax = max(icabs,irabs)
            icrmin = min(icabs,irabs)

            fac = 1d0
            if (irabs.lt.icabs) fac = psign

c dbg
c            print *,'->',ioff + (icol-1)*nrow+irow,
c     &           icrmax*(icrmax-1)/2+icrmin
c dbg
            xblk(ioff + (icol-1)*nrow+irow) =
     &           fac*xfull(icrmax*(icrmax-1)/2+icrmin)

          end do
        end do
        ioff = ioff + nrow*ncol

      end do

      if (ntest.ge.100) then
        write(lulog,*) 'output matrix:'
        form = sym
        if (sym.eq.1) form=0
        call wr_blkmat(xblk,ndim,ndim,nsym,form)
      end if

      return
      end


      SUBROUTINE TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC, Z, LDZ,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To reduce the descriptor system pair (C,A-lambda E) to the
C     RQ-coordinate form by computing an orthogonal transformation
C     matrix Z such that the transformed descriptor system pair
C     (C*Z,A*Z-lambda E*Z) has the descriptor matrix E*Z in an upper
C     trapezoidal form.
C     The right orthogonal transformations performed to reduce E can
C     be optionally accumulated.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPZ   CHARACTER*1
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'U':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of rows of matrices A and E.  L >= 0.
C
C     N       (input) INTEGER
C             The number of columns of matrices A, E, and C.  N >= 0.
C
C     P       (input) INTEGER
C             The number of rows of matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading L-by-N part of this array contains
C             the transformed matrix A*Z.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,L).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the descriptor matrix E.
C             On exit, the leading L-by-N part of this array contains
C             the transformed matrix E*Z in upper trapezoidal form,
C             i.e.
C
C                      ( E11 )
C                E*Z = (     ) ,  if L >= N ,
C                      (  R  )
C             or
C
C                E*Z = ( 0  R ),  if L < N ,
C
C             where R is an MIN(L,N)-by-MIN(L,N) upper triangular
C             matrix.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,L).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Z.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'N':  Z is not referenced.
C             If COMPZ = 'I':  on entry, Z need not be set;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix Z,
C                              which is the product of Householder
C                              transformations applied to A, E, and C
C                              on the right.
C             If COMPZ = 'U':  on entry, the leading N-by-N part of this
C                              array must contain an orthogonal matrix
C                              Z1;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix
C                              Z1*Z.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)).
C             For optimum performance
C             LWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)*NB),
C             where NB is the optimal blocksize.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine computes the RQ factorization of E to reduce it
C     the upper trapezoidal form.
C
C     The transformations are also applied to the rest of system
C     matrices
C
C         A <- A * Z,  C <- C * Z.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( L*N*N )  floating point operations.
C
C     CONTRIBUTOR
C
C     C. Oara, University "Politehnica" Bucharest.
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the RASP routine RPDSRQ.
C
C     REVISIONS
C
C     July 1999, V. Sima, Research Institute for Informatics, Bucharest.
C
C     KEYWORDS
C
C     Descriptor system, matrix algebra, matrix operations,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPZ
      INTEGER            INFO, L, LDA, LDC, LDE, LDWORK, LDZ, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                   E( LDE, * ), Z( LDZ, * )
C     .. Local Scalars ..
      LOGICAL            ILZ
      INTEGER            ICOMPZ, LN, WRKOPT
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DGERQF, DLASET, DORMRQ, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode COMPZ.
C
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'U' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
C
C     Test the input parameters.
C
      INFO = 0
      WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, P ) )
      IF( ICOMPZ.EQ.0 ) THEN
         INFO = -1
      ELSE IF( L.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, L ) ) THEN
         INFO = -6
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -12
      ELSE IF( LDWORK.LT.WRKOPT ) THEN
         INFO = -14
      END IF
      IF( INFO .NE. 0 ) THEN
         CALL XERBLA( 'TG01DD', -INFO )
         RETURN
      END IF
C
C     Initialize Q if necessary.
C
      IF( ICOMPZ.EQ.3 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
C
C     Quick return if possible.
C
      IF( L.EQ.0 .OR. N.EQ.0 ) THEN
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      LN = MIN( L, N )
C
C     Compute the RQ decomposition of E, E = R*Z.
C
C     Workspace: need   MIN(L,N) + L;
C                prefer MIN(L,N) + L*NB.
C
      CALL DGERQF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN )
C
C     Apply transformation on the rest of matrices.
C
C     A <--  A * Z'.
C     Workspace: need   MIN(L,N) + L;
C                prefer MIN(L,N) + L*NB.
C
      CALL DORMRQ( 'Right', 'Transpose', L, N, LN, E( L-LN+1,1 ), LDE,
     $              DWORK, A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN )
C
C     C <-- C * Z'.
C     Workspace: need   MIN(L,N) + P;
C                prefer MIN(L,N) + P*NB.
C
      CALL DORMRQ( 'Right', 'Transpose', P, N, LN, E( L-LN+1,1 ), LDE,
     $              DWORK, C, LDC, DWORK( LN+1 ), LDWORK-LN, INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN )
C
C     Z <-- Z1 * Z'.
C     Workspace: need   MIN(L,N) + N;
C                prefer MIN(L,N) + N*NB.
C
      IF( ILZ ) THEN
         CALL DORMRQ( 'Right', 'Transpose', N, N, LN, E( L-LN+1,1 ),
     $                LDE, DWORK, Z, LDZ, DWORK( LN+1 ), LDWORK-LN,
     $                INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN )
      END IF
C
C     Set lower triangle of E to zero.
C
      IF( L.LT.N ) THEN
         CALL DLASET( 'Full', L, N-L, ZERO, ZERO, E, LDE )
         IF( L.GE.2 ) CALL DLASET( 'Lower', L-1, L, ZERO, ZERO,
     $                             E( 2, N-L+1 ), LDE )
      ELSE
         IF( N.GE.2 ) CALL DLASET( 'Lower', N-1, N, ZERO, ZERO,
     $                             E( L-N+2, 1 ), LDE )
      END IF
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TG01DD ***
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                     C
C ROUTINES TO FILL THE ARRAYS INCLUDING ALL THE SCALAR INTEGRALS      C
C     FOR THE STOP PAIR HADROPRODUCTION WITH QUARK INCOMING STATE     C
C                                                                     C
C     SCALAR_ARRAY_TB_B_GS(MASSIN,SK3B0A,SK3B0B,SK3B0C,SK3B0D,SK3B0P) C
C     SCALAR_ARRAY_TB_C_GS(MASSIN,SK3C0A,SK3C0B,SK3C0C,SK3D0)         C
C     SCALAR_ARRAY_TB_B_QS(MASSIN,SK3B0A,SK3B0B,SK3B0C,SK3B0D,SK3B0P) C
C     SCALAR_ARRAY_TB_C_QS(MASSIN,SK3C0A,SK3C0B,SK3C0C,SK3D0)         C
C                                                                     C
C COMMENTED OUT IF FUNCTION IS NOT NEEDED FOR GIVEN INITIAL STATE     C
C                                                                     C
C                                                                     C
C    INPUT  : MASSIN(1:2,1:6)                                         C
C                                                                     C
C             CONTAINING IN THE FIRST ROW  : S,T,U,T1,U1              C
C                               SECOND ROW : STOP-1 MASS SQUARED      C
C                                            STOP-2 MASS SQUARED      C
C                                            SQUARK MASS SQUARED      C
C                                            GLUINO MASS SQUARED      C
C                                            TOP MASS SQUARED         C
C                                            MASS SCALE SQUARED       C
C                                            SBOTTOM-1 MASS SQUARED   C
C                                            SBOTTOM-2 MASS SQUARED   C
C                                                                     C
C                                                                     C
C    OUTPUT : SK3B0A(1:7)         B_0(K1,M,M)                         C
C             SK3B0B(1:8)         B_0(K1+K2,M,M)                      C
C             SK3B0C(1:3)         B_0(P1,M1,M2)                       C
C             SK3B0D(1:3,1:2)     B_0(K1+P1,M1,M2)                    C
C             SK3B0P(1:4)         B_0'(K1/P1,M1,M2)                   C
C                                                                     C
C             SK3C0A(1:10)        C_0(K1,K2,M1,M2,M3)                 C
C             SK3C0B(1:6)         C_0(P1,P2,M1,M2,M3)                 C
C             SK3C0C(1:8,1:2)     C_0(K1,P1,M1,M2,M3)                 C
C             SK3D0(1:11,1:2)     D_0(........)                       C
C                                                                     C
C   N.B. : THE INTEGRAL MEASURE IS D^NQ/(I*Pi^2)                      C
C          ALL VARIABLES REAL*8, ONLY THE REAL PARTS OF THE INTEGRALS C
C                                                                     C
C                                                                     C
C    NECESSARY SUBROUTINES :  XSPENCE.F                               C
C                             XWOPOINT_2.F                            C
C                             XTHREEPOINT_2.F                         C
C                             XDENNER_2.F                             C
C                                                                     C
C    CALLED FUNCTIONS : B_FIN                                         C
C                       BP_FIN                                        C
C                       C_FIN                                         C
C                       D_FIN                                         C
C                       LIR2,LIC2                                     C
C                                                                     C
C                                                                     C
C    LAST MODIFIED : 28.01.08 (SBOTTOM INTEGRALS)                     C
C                                                                     C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c ---------------------------------------------------------------------
      subroutine SCALAR_ARRAY_TB_B_QS(m2,sba,sbb,sbc,sbd,sbp)

      implicit none

      integer n1,n2
      real*8 m2(1:2,1:8)
      real*8 sba(1:7),sbb(1:8),sbc(1:3),sbd(1:3,1:2)
      real*8 sbp(1:4)

      real*8 m1(1:2,1:8)
      real*8 B02,BP02

      m2(1,6) = 1.D-16

      do n1=1,7
         sba(n1) = 1.D40
      end do

      do n1=1,8
         sbb(n1) = 1.D40
      end do

      do n1=1,3
         sbc(n1) = 1.D40
      end do

      do n1=1,3
         do n2=1,2
            sbd(n1,n2) = 1.D40
         end do
      end do

      do n1=1,4
         sbp(n1) = 1.D40
      end do

      do n1=1,8
         m1(2,n1) = sqrt(abs(m2(2,n1)))
      end do

      sba(1) = B02(0.D0,m1(2,4),m1(2,4),m2(2,6))
      sba(2) = B02(0.D0,m1(2,5),m1(2,5),m2(2,6))
      sba(3) = B02(0.D0,m1(2,3),m1(2,4),m2(2,6))
      sba(4) = B02(0.D0,m1(2,3),m1(2,3),m2(2,6))
      sba(5) = B02(0.D0,m1(2,2),m1(2,2),m2(2,6))
      sba(6) = B02(0.D0,m1(2,7),m1(2,7),m2(2,6))
      sba(7) = B02(0.D0,m1(2,8),m1(2,8),m2(2,6))

      sbb(1) = B02(m2(1,1),0.D0,0.D0,m2(2,6))
      sbb(2) = B02(m2(1,1),m1(2,1),m1(2,1),m2(2,6))
      sbb(3) = B02(m2(1,1),m1(2,4),m1(2,4),m2(2,6))
      sbb(4) = B02(m2(1,1),m1(2,5),m1(2,5),m2(2,6))
      sbb(5) = B02(m2(1,1),m1(2,3),m1(2,3),m2(2,6))
      sbb(6) = B02(m2(1,1),m1(2,2),m1(2,2),m2(2,6))
      sbb(7) = B02(m2(1,1),m1(2,7),m1(2,7),m2(2,6))
      sbb(8) = B02(m2(1,1),m1(2,8),m1(2,8),m2(2,6))

      sbc(1) = B02(m2(2,1),m1(2,1),0.D0,m2(2,6))
      sbc(2) = B02(m2(2,1),m1(2,4),m1(2,5),m2(2,6))
      sbc(3) = B02(m2(2,1),m1(2,4),0.D0   ,m2(2,6))

c      sbd(1,1) = B02(m2(1,2),m1(2,1),0.D0,   m2(2,6))
c      sbd(2,1) = B02(m2(1,2),m1(2,4),m1(2,5),m2(2,6))
c      sbd(3,1) = B02(m2(1,2),m1(2,4),0.D0,   m2(2,6))

c      sbd(1,2) = B02(m2(1,3),m1(2,1),0.D0,   m2(2,6))
c      sbd(2,2) = B02(m2(1,3),m1(2,4),m1(2,5),m2(2,6))
c      sbd(3,2) = B02(m2(1,3),m1(2,4),0.D0,   m2(2,6))

      sbp(1) = BP02(m2(2,1),m1(2,1),0.D0,m2(2,6))
      sbp(2) = BP02(m2(2,1),m1(2,4),m1(2,5),m2(2,6))
      sbp(3) = BP02(0.D0,m1(2,3),m1(2,4),m2(2,6))
      sbp(4) = BP02(m2(2,1),m1(2,4),0.D0   ,m2(2,6))

      return
      end

c ---------------------------------------------------------------------
      subroutine SCALAR_ARRAY_TB_C_QS(m2,sca,scb,scc,sd)

      implicit none

      integer n1,n2
      real*8 m2(1:2,1:8)
      real*8 sca(1:10),scb(1:6),scc(1:8,1:2)
      real*8 sd(1:11,1:2)

      real*8 m1(1:2,1:8)
      real*8 Lir2,eps1
      real*8 zeta2,xw1,xx1,s
ctp      real*8 dummy1, dummy2
      complex*16 cw1,cw2,cw3,cw4,cw5,cx1,cx2,cx3,cx4,cx5
      complex*16 C03,D04,CSPEN

      Lir2(s) = real( CSPEN(dcmplx(s)) )

      eps1 = 1.D-8

      do n1=1,10
         sca(n1) = 1.D40
      end do

      do n1=1,6
         scb(n1) = 1.D40
      end do

      do n1=1,8
         do n2=1,2
            scc(n1,n2) = 1.D40
         end do
      end do

      do n1=1,11
         do n2=1,2
            sd(n1,n2) = 1.D40
         end do
      end do

      do n1=1,8
         m1(2,n1) = sqrt(abs(m2(2,n1)))
      end do

      zeta2 = ( 4.D0*atan(1.D0) )**2 /6.D0
      xw1 = sqrt(1.D0-4.D0*m2(2,1)/m2(1,1))
      xx1 = ( 1.D0 - xw1 )/( 1.D0 + xw1 )

      cw1 = sqrt( dcmplx( 1.D0-4.D0*m2(2,1)/m2(1,1)) )
      cx1 = ( 1.D0 - cw1 )/( 1.D0 + cw1 )
      cw2 = sqrt( dcmplx( 1.D0-4.D0*m2(2,2)/m2(1,1)) )
      cx2 = ( 1.D0 - cw2 )/( 1.D0 + cw2 )
      cw3 = sqrt( dcmplx( 1.D0-4.D0*m2(2,3)/m2(1,1)) )
      cx3 = ( 1.D0 - cw3 )/( 1.D0 + cw3 )
      cw4 = sqrt( dcmplx( 1.D0-4.D0*m2(2,4)/m2(1,1)) )
      cx4 = ( 1.D0 - cw4 )/( 1.D0 + cw4 )
      cw5 = sqrt( dcmplx( 1.D0-4.D0*m2(2,5)/m2(1,1)) )
      cx5 = ( 1.D0 - cw5 )/( 1.D0 + cw5 )

      scc(1,1) = (  log(-m2(1,4)/m2(2,1))**2
     &            + Lir2(m2(1,2)/m2(2,1))
     &            + zeta2/4.D0              )/m2(1,4)
      scc(1,2) = (  log(-m2(1,5)/m2(2,1))**2
     &            + Lir2(m2(1,3)/m2(2,1))
     &            + zeta2/4.D0              )/m2(1,5)

c   the three point functions with two vanishing external masses
c   according to roland resp. wim
      sca(1) = (  log(m2(1,1)/m2(2,1))**2 /2.D0
     &          - 7.D0/2.D0*zeta2                )/m2(1,1)
c      sca(2) = real( log(-cx1)**2 ) /(2.D0*m2(1,1))
c      sca(3) = real( log(-cx4)**2 ) /(2.D0*m2(1,1))
c      sca(4) = real( log(-cx5)**2 ) /(2.D0*m2(1,1))
      sca(5) = real(  CSPEN(1.D0 + m2(2,4)*cx3/m2(2,3))
     &               + CSPEN(1.D0 + m2(2,4)/cx3/m2(2,3))
     &               - 2.D0*Lir2(1.D0 - m2(2,4)/m2(2,3))
     &               + log(-cx3)**2                   )/m2(1,1)
      sca(6) = real(  CSPEN(1.D0 + m2(2,3)*cx4/m2(2,4))
     &               + CSPEN(1.D0 + m2(2,3)/cx4/m2(2,4))
     &               - 2.D0*Lir2(1.D0 - m2(2,3)/m2(2,4))
     &               + log(-cx4)**2                   )/m2(1,1)
c      sca(7) = real( log(-cx3)**2 ) /(2.D0*m2(1,1))
c      sca(8) = real( log(-cx2)**2 ) /(2.D0*m2(1,1))

      scb(1) = (  - 2.D0*log(xx1)*log(1.D0-xx1)
     &            - 2.D0*Lir2(xx1)
     &            + log(xx1)**2/2.D0
     &            - 4.D0*zeta2                  )/m2(1,1)/xw1
      scb(2) = (  2.D0 * Lir2(-xx1)
     &          + log(xx1)**2 /2.D0
     &          + zeta2              )/(m2(1,1)*xw1)
      scb(3)=real(C03(m2(2,1),m2(2,1),m2(1,1),m1(2,4),m1(2,5),m1(2,4)))
      scb(4)=real(C03(m2(2,1),m2(2,1),m2(1,1),m1(2,5),m1(2,4),m1(2,5)))
      scb(5)=real(C03(m2(2,1),m2(2,1),m2(1,1),m1(2,4),0.D0   ,m1(2,4)))
      scb(6)=real(C03(m2(2,1),m2(2,1),m2(1,1),0.D0   ,m1(2,4),0.D0   ))

ctp      dummy1 = C_fin_w(m2(1,1),m2(2,1),m2(2,1),m2(2,4),m2(2,5),m2(2,4))
ctp      dummy2 = C_fin_w(m2(1,1),m2(2,1),m2(2,1),m2(2,5),m2(2,4),m2(2,5))
ctp      if ( abs(scb(3)-dummy1)/abs(scb(3)+dummy1) .gt. 1.e-6 ) then
ctp         print*, " C_QS: problem 1 ",dummy1,scb(3)
ctp      end if
ctp      if ( abs(scb(4)-dummy2)/abs(scb(4)+dummy2) .gt. 1.e-6 ) then
ctp         print*, " C_QS: problem 2 ",dummy2,scb(4)
ctp      end if

ctp      scc(2,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,3)))
      scc(2,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,3),m1(2,5),m1(2,4)))
      scc(6,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,3),0.D0   ,m1(2,4)))
c      scc(3,1) = ( - Lir2(m2(1,2)/m2(2,1)) + zeta2 )/m2(1,4)
ctp      scc(4,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,4)))
ctp      scc(5,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,4),m1(2,5),m1(2,5)))
c      scc(4,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,4),m1(2,3),m1(2,4)))
c      scc(5,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,5)))

ctp      scc(2,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,3)))
      scc(2,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,3),m1(2,5),m1(2,4)))
      scc(6,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,3),0.D0   ,m1(2,4)))
c      scc(3,2) = ( - Lir2(m2(1,3)/m2(2,1)) + zeta2 )/m2(1,5)
ctp      scc(4,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,4)))
ctp      scc(5,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,4),m1(2,5),m1(2,5)))
c      scc(4,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,4),m1(2,5),m1(2,4)))
c      scc(5,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,5)))

c   the special four point function according to prd40
      sd(1,1) = (  2.D0*log(m2(1,1)/m2(2,1))*log(-m2(1,4)/m2(2,1))
     &           - 4.D0*zeta2        )/(m2(1,1)*m2(1,4))
c      sd(2,1) = (- 2.D0*log(xx1)*log(1.D0-xx1)
c     &           + 2.D0*log(xx1)*log(1.D0+xx1)
c     &           - 2.D0*log(xx1)*log(-m2(1,4)/m2(2,1))
c     &           - 2.D0*Lir2(xx1)
c     &           + 2.D0*Lir2(-xx1)
c     &           - 3.D0*zeta2        )/(m2(1,1)*m2(1,4)*xw1)
c      sd(3,1) = (  2.D0*log(-m2(1,4)/m2(2,1))*log(-m2(1,5)/m2(2,1))
c     &           - 7.D0*zeta2/2.D0     )/(m2(1,4)*m2(1,5))

      sd(1,2) = (  2.D0*log(m2(1,1)/m2(2,1))*log(-m2(1,5)/m2(2,1))
     &           - 4.D0*zeta2        )/(m2(1,1)*m2(1,5))
c      sd(2,2) = (- 2.D0*log(xx1)*log(1.D0-xx1)
c     &           + 2.D0*log(xx1)*log(1.D0+xx1)
c     &           - 2.D0*log(xx1)*log(-m2(1,5)/m2(2,1))
c     &           - 2.D0*Lir2(xx1)
c     &           + 2.D0*Lir2(-xx1)
c     &           - 3.D0*zeta2        )/(m2(1,1)*m2(1,5)*xw1)
c      sd(3,2) = (  2.D0*log(-m2(1,5)/m2(2,1))*log(-m2(1,4)/m2(2,1))
c     &           - 7.D0*zeta2/2.D0     )/(m2(1,5)*m2(1,4))

c   the general four point functions
c      sd(4,1) = real(D04(m2(2,1),eps1,eps1,m2(2,1),m2(1,2),m2(1,1),
c     &                   m1(2,4),m1(2,5),m1(2,5),m1(2,5)))
c      sd(5,1) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,2),
c     &                   m1(2,4),m1(2,4),m1(2,4),m1(2,5)))
c      sd(6,1) = real(D04(eps1,m2(2,1),eps1,m2(2,1),m2(1,3),m2(1,2),
c     &                   m1(2,5),m1(2,5),m1(2,4),m1(2,4)))
      sd(7,1) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,2),
     &                   m1(2,4),m1(2,3),m1(2,4),m1(2,5)))
      sd(8,1) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,2),
     &                   m1(2,4),m1(2,3),m1(2,4),0.D0   ))

c      sd(4,2) = real(D04(m2(2,1),eps1,eps1,m2(2,1),m2(1,3),m2(1,1),
c     &                   m1(2,4),m1(2,5),m1(2,5),m1(2,5)))
c      sd(5,2) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,3),
c     &                   m1(2,4),m1(2,4),m1(2,4),m1(2,5)))
c      sd(6,2) = real(D04(eps1,m2(2,1),eps1,m2(2,1),m2(1,2),m2(1,3),
c     &                   m1(2,5),m1(2,5),m1(2,4),m1(2,4)))
      sd(7,2) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,3),
     &                   m1(2,4),m1(2,3),m1(2,4),m1(2,5)))
      sd(8,2) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,3),
     &                   m1(2,4),m1(2,3),m1(2,4),0.D0   ))

      return
      end

c ---------------------------------------------------------------------
      subroutine SCALAR_ARRAY_TB_B_GS(m2,sba,sbb,sbc,sbd,sbp)

      implicit none

      integer n1,n2
      real*8 m2(1:2,1:8)
      real*8 sba(1:7),sbb(1:8),sbc(1:3),sbd(1:3,1:2)
      real*8 sbp(1:4)

      real*8 m1(1:2,1:8)
      real*8 B02,BP02

      m2(1,6) = 1.D-16

      do n1=1,7
         sba(n1) = 1.D40
      end do

      do n1=1,8
         sbb(n1) = 1.D40
      end do

      do n1=1,3
         sbc(n1) = 1.D40
      end do

      do n1=1,3
         do n2=1,2
            sbd(n1,n2) = 1.D40
         end do
      end do

      do n1=1,4
         sbp(n1) = 1.D40
      end do

      do n1=1,8
         m1(2,n1) = sqrt(abs(m2(2,n1)))
      end do

      sba(1) = B02(0.D0,m1(2,4),m1(2,4),m2(2,6))
      sba(2) = B02(0.D0,m1(2,5),m1(2,5),m2(2,6))
c      sba(3) = B02(0.D0,m1(2,3),m1(2,4),m2(2,6))
      sba(4) = B02(0.D0,m1(2,3),m1(2,3),m2(2,6))
      sba(5) = B02(0.D0,m1(2,2),m1(2,2),m2(2,6))
      sba(6) = B02(0.D0,m1(2,7),m1(2,7),m2(2,6))
      sba(7) = B02(0.D0,m1(2,8),m1(2,8),m2(2,6))

      sbb(1) = B02(m2(1,1),0.D0,0.D0,m2(2,6))
      sbb(2) = B02(m2(1,1),m1(2,1),m1(2,1),m2(2,6))
      sbb(3) = B02(m2(1,1),m1(2,4),m1(2,4),m2(2,6))
      sbb(4) = B02(m2(1,1),m1(2,5),m1(2,5),m2(2,6))
      sbb(5) = B02(m2(1,1),m1(2,3),m1(2,3),m2(2,6))
      sbb(6) = B02(m2(1,1),m1(2,2),m1(2,2),m2(2,6))
      sbb(7) = B02(m2(1,1),m1(2,7),m1(2,7),m2(2,6))
      sbb(8) = B02(m2(1,1),m1(2,8),m1(2,8),m2(2,6))

      sbc(1) = B02(m2(2,1),m1(2,1),0.D0,m2(2,6))
      sbc(2) = B02(m2(2,1),m1(2,4),m1(2,5),m2(2,6))
      sbc(3) = B02(m2(2,1),m1(2,4),0.D0,m2(2,6))

      sbd(1,1) = B02(m2(1,2),m1(2,1),0.D0,   m2(2,6))
      sbd(2,1) = B02(m2(1,2),m1(2,4),m1(2,5),m2(2,6))
      sbd(3,1) = B02(m2(1,2),m1(2,4),0.D0,   m2(2,6))

      sbd(1,2) = B02(m2(1,3),m1(2,1),0.D0,   m2(2,6))
      sbd(2,2) = B02(m2(1,3),m1(2,4),m1(2,5),m2(2,6))
      sbd(3,2) = B02(m2(1,3),m1(2,4),0.D0,   m2(2,6))

      sbp(1) = BP02(m2(2,1),m1(2,1),0.D0,m2(2,6))
      sbp(2) = BP02(m2(2,1),m1(2,4),m1(2,5),m2(2,6))
c      sbp(3) = BP02(0.D0,m1(2,3),m1(2,4),m2(2,6))
      sbp(4) = BP02(m2(2,1),m1(2,4),0.D0,m2(2,6))

      return
      end

c ---------------------------------------------------------------------
      subroutine SCALAR_ARRAY_TB_C_GS(m2,sca,scb,scc,sd)

      implicit none

      integer n1,n2
      real*8 m2(1:2,1:8)
      real*8 sca(1:10),scb(1:6),scc(1:8,1:2)
      real*8 sd(1:11,1:2)

      real*8 m1(1:2,1:6)
      real*8 Lir2,t,m12,ms2,mu2,mg2,dumc_1,dumd_1,dumd_2,eps1,epsi
      real*8 tg,ug,mdiff
      real*8 zeta2,xw1,xx1,s
ctp      real*8 dummy1, dummy2
      complex*16 cw1,cw2,cw3,cw4,cw5,cx1,cx2,cx3,cx4,cx5
      complex*16 cw7,cw8,cx7,cx8,msc2,mgc2,sc,mdiffc
      complex*16 C03,D04,CSPEN
ctp      complex*16 Cc

      Lir2(s) = real( CSPEN(dcmplx(s)) )
c               divergent three point functions, roland's (0.34)
c               copied from neutralino-gluino case:
c               SCC(2,1) = C_FIN(P1,K1,MS,0,0)
c                        = dumc_1(t,m12,ms2,msc2,mu2)
      dumc_1(t,m12,ms2,msc2,mu2) =
     &  (   Lir2(t/ms2) - Lir2(m12/ms2)
     &    + real( log( 1.D0 - t/msc2     )**2 )
     &    - real( log( 1.D0 - m12/msc2 )**2 )
     &    + log(ms2/mu2) * log( abs(-(t-ms2)/(ms2-m12) ) ) )
     &  /(t-m12)

c               divergent four point function, roland's (0.41) gen.
c               copied from neutralino-gluino case:
c               SCD(1,2) = D_FIN(K2,K1,P2,0,0,0,MS)
c                        = dumd_1(u,mg2,m12,ms2,msc2,s,sc,mu2,zeta2)
      dumd_1(t,m12,mg2,ms2,msc2,s,sc,mu2,zeta2) =
     &  ( - 2.D0 * Lir2( 1.D0 + (ms2-m12)/(t-ms2) )
     &    - 2.D0 * Lir2( 1.D0 + (ms2-mg2)/(t-ms2) )
     &    - Lir2( 1.D0 + (ms2-m12)*(ms2-mg2)/s/ms2 )
     &    - 3.D0/2.D0 * zeta2
     &    - real( log( 1.D0 + (msc2-m12)*(msc2-mg2)/s/msc2 )
     &             * (   log( -(msc2-m12)*(msc2-mg2)/s/msc2 )
     &                 - log( (msc2-m12)/mu2)
     &                 - log( (msc2-mg2)/mu2)
     &                 + log( -s*msc2/mu2**2)         )              )
     &    + log( s/mu2  )**2 /2.D0
     &    - log( s/ms2  )**2 /2.D0
     &    + 2.D0*real( log( -sc/mu2 )
     &                 *log( -(t-msc2)/msc2) )
     &    - real( log( (msc2-m12)/mu2 )
     &           *log( (msc2-m12)/msc2) )
     &    - real( log( (msc2-mg2)/mu2 )
     &           *log( (msc2-mg2)/msc2) )                        )
     &  /s/(t-ms2)

      dumd_2(tg,ug,mg2,ms2,mdiff,mdiffc,mu2) =
     &  -1.D0/(tg*ug -mdiff**2) *(
     &             log(mdiff**2/mg2/mu2)* log( abs(mdiff**2/tg/ug) )
     &           + real( log( -mdiffc/tg )**2 )
     &           + real( log( -mdiffc/ug )**2 )
     &           + 4.d0*Lir2(1.D0 +mdiff/tg)
     &           + 4.d0*Lir2(1.D0 +mdiff/ug)
     &           + 2.d0*Lir2(1.D0 -tg*ug/mdiff**2) )

      eps1 = 1.D-8
      epsi = 1.D-8

      mgc2 = m2(2,4) * dcmplx(1.D0,-epsi)
      sc   = m2(1,1) * dcmplx(1.D0,epsi)

      mdiff  = m2(2,4) - m2(2,1)
      mdiffc = mdiff * dcmplx(1.D0,epsi)
      tg    = m2(1,2) - m2(2,4)
      ug    = m2(1,3) - m2(2,4)

      do n1=1,10
         sca(n1) = 1.D40
      end do

      do n1=1,6
         scb(n1) = 1.D40
      end do

      do n1=1,8
         do n2=1,2
            scc(n1,n2) = 1.D40
         end do
      end do

      do n1=1,11
         do n2=1,2
            sd(n1,n2) = 1.D40
         end do
      end do

      do n1=1,6
         m1(2,n1) = sqrt(abs(m2(2,n1)))
      end do

      zeta2 = ( 4.D0*atan(1.D0) )**2 /6.D0
      xw1 = sqrt(1.D0-4.D0*m2(2,1)/m2(1,1))
      xx1 = ( 1.D0 - xw1 )/( 1.D0 + xw1 )

      cw1 = sqrt( dcmplx( 1.D0-4.D0*m2(2,1)/m2(1,1)) )
      cx1 = ( 1.D0 - cw1 )/( 1.D0 + cw1 )
      cw2 = sqrt( dcmplx( 1.D0-4.D0*m2(2,2)/m2(1,1)) )
      cx2 = ( 1.D0 - cw2 )/( 1.D0 + cw2 )
      cw3 = sqrt( dcmplx( 1.D0-4.D0*m2(2,3)/m2(1,1)) )
      cx3 = ( 1.D0 - cw3 )/( 1.D0 + cw3 )
      cw4 = sqrt( dcmplx( 1.D0-4.D0*m2(2,4)/m2(1,1)) )
      cx4 = ( 1.D0 - cw4 )/( 1.D0 + cw4 )
      cw5 = sqrt( dcmplx( 1.D0-4.D0*m2(2,5)/m2(1,1)) )
      cx5 = ( 1.D0 - cw5 )/( 1.D0 + cw5 )
      cw7 = sqrt( dcmplx( 1.D0-4.D0*m2(2,7)/m2(1,1)) )
      cx7 = ( 1.D0 - cw7 )/( 1.D0 + cw7 )
      cw8 = sqrt( dcmplx( 1.D0-4.D0*m2(2,8)/m2(1,1)) )
      cx8 = ( 1.D0 - cw8 )/( 1.D0 + cw8 )

      scc(1,1) = (  log(-m2(1,4)/m2(2,1))**2
     &            + Lir2(m2(1,2)/m2(2,1))
     &            + zeta2/4.D0              )/m2(1,4)
      scc(1,2) = (  log(-m2(1,5)/m2(2,1))**2
     &            + Lir2(m2(1,3)/m2(2,1))
     &            + zeta2/4.D0              )/m2(1,5)

c   the three point functions with two vanishing external masses
c   according to roland resp. wim
      sca(1) = (  log(m2(1,1)/m2(2,1))**2 /2.D0
     &          - 7.D0/2.D0*zeta2                )/m2(1,1)
      sca(2) = real( log(-cx1)**2 ) /(2.D0*m2(1,1))
      sca(3) = real( log(-cx4)**2 ) /(2.D0*m2(1,1))
      sca(4) = real( log(-cx5)**2 ) /(2.D0*m2(1,1))
c      sca(5) = real(  CSPEN(1.D0 + m2(2,4)*cx3/m2(2,3))
c     &               + CSPEN(1.D0 + m2(2,4)/cx3/m2(2,3))
c     &               - 2.D0*Lir2(1.D0 - m2(2,4)/m2(2,3))
c     &               + log(-cx3)**2                   )/m2(1,1)
c      sca(6) = real(  CSPEN(1.D0 + m2(2,3)*cx4/m2(2,4))
c     &               + CSPEN(1.D0 + m2(2,3)/cx4/m2(2,4))
c     &               - 2.D0*Lir2(1.D0 - m2(2,3)/m2(2,4))
c     &               + log(-cx4)**2                   )/m2(1,1)
      sca(7) = real( log(-cx3)**2 ) /(2.D0*m2(1,1))
      sca(8) = real( log(-cx2)**2 ) /(2.D0*m2(1,1))
      sca(9)  = real( log(-cx7)**2 ) /(2.D0*m2(1,1))
      sca(10) = real( log(-cx8)**2 ) /(2.D0*m2(1,1))

      scb(1) = (  - 2.D0*log(xx1)*log(1.D0-xx1)
     &            - 2.D0*Lir2(xx1)
     &            + log(xx1)**2/2.D0
     &            - 4.D0*zeta2                  )/m2(1,1)/xw1
      scb(2) = (  2.D0 * Lir2(-xx1)
     &          + log(xx1)**2 /2.D0
     &          + zeta2              )/(m2(1,1)*xw1)
      scb(3)=real(C03(m2(2,1),m2(2,1),m2(1,1),m1(2,4),m1(2,5),m1(2,4)))
      scb(4)=real(C03(m2(2,1),m2(2,1),m2(1,1),m1(2,5),m1(2,4),m1(2,5)))
      scb(5)=real(C03(m2(2,1),m2(2,1),m2(1,1),m1(2,4),0.D0   ,m1(2,4)))
      scb(6)=real(C03(m2(2,1),m2(2,1),m2(1,1),0.D0   ,m1(2,4),0.D0   ))

ctp      dummy1 = C_fin_w(m2(1,1),m2(2,1),m2(2,1),m2(2,4),m2(2,5),m2(2,4))
ctp      dummy2 = C_fin_w(m2(1,1),m2(2,1),m2(2,1),m2(2,5),m2(2,4),m2(2,5))
ctp      if ( abs(scb(3)-dummy1)/abs(scb(3)+dummy1) .gt. 1.e-6 ) then
ctp         print*, " C_QS: problem 1 ",dummy1,scb(3)
ctp      end if
ctp      if ( abs(scb(4)-dummy2)/abs(scb(4)+dummy2) .gt. 1.e-6 ) then
ctp         print*, " C_QS: problem 2 ",dummy2,scb(4)
ctp      end if

ctp      scc(2,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,3)))
c      scc(2,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,3),m1(2,5),m1(2,4)))
      scc(3,1) = ( - Lir2(m2(1,2)/m2(2,1)) + zeta2 )/m2(1,4)
ctp      scc(4,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,4)))
ctp      scc(5,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,4),m1(2,5),m1(2,5)))
      scc(4,1)=real(C03(m2(1,2),m2(2,1),eps1,m1(2,4),m1(2,5),m1(2,4)))
      scc(5,1)=real(C03(m2(1,2),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,5)))
ctp      scc(6,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,3),0.D0   ,m1(2,4)))
      scc(7,1) = real(C03(m2(1,2),m2(2,1),eps1,m1(2,4),0.D0   ,m1(2,4)))
c     Cfin(p1,k1,mg,0,0)
      scc(8,1) = dumc_1(m2(1,2),m2(2,1),m2(2,4),mgc2,m2(2,6))

ctp      scc(2,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,3)))
c      scc(2,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,3),m1(2,5),m1(2,4)))
      scc(3,2) = ( - Lir2(m2(1,3)/m2(2,1)) + zeta2 )/m2(1,5)
ctp      scc(4,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,4)))
ctp      scc(5,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,4),m1(2,5),m1(2,5)))
      scc(4,2)=real(C03(m2(1,3),m2(2,1),eps1,m1(2,4),m1(2,5),m1(2,4)))
      scc(5,2)=real(C03(m2(1,3),m2(2,1),eps1,m1(2,5),m1(2,4),m1(2,5)))
ctp      scc(6,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,3),0.D0   ,m1(2,4)))
      scc(7,2) = real(C03(m2(1,3),m2(2,1),eps1,m1(2,4),0.D0   ,m1(2,4)))
c     Cfin(p1,k1,mg,0,0)
      scc(8,2) = dumc_1(m2(1,3),m2(2,1),m2(2,4),mgc2,m2(2,6))

C  from old stop code: C(p02,p12,p22;m0,m1,m2)                        C
C                                                                     C
C             p1  -----\_  m1                                         C
C                      | \_                                           C
C                      |   \_                                         C
C                  m2  |    _----  p0 = p1+p2                         C
C                      |  _/                                          C
C                      |_/                                            C
C             p2  -----/   m0                                         C
C                                                                     C
C called as   C03(p02,p12,p22;m0,m1,m2)                               C
C             Cc (p02,p12,p22;m1,m2,m0)                               C
C                                                                     C

c   the special four point function according to prd40
      sd(1,1) = (  2.D0*log(m2(1,1)/m2(2,1))*log(-m2(1,4)/m2(2,1))
     &           - 4.D0*zeta2        )/(m2(1,1)*m2(1,4))
      sd(2,1) = (- 2.D0*log(xx1)*log(1.D0-xx1)
     &           + 2.D0*log(xx1)*log(1.D0+xx1)
     &           - 2.D0*log(xx1)*log(-m2(1,4)/m2(2,1))
     &           - 2.D0*Lir2(xx1)
     &           + 2.D0*Lir2(-xx1)
     &           - 3.D0*zeta2        )/(m2(1,1)*m2(1,4)*xw1)
      sd(3,1) = (  2.D0*log(-m2(1,4)/m2(2,1))*log(-m2(1,5)/m2(2,1))
     &           - 7.D0*zeta2/2.D0     )/(m2(1,4)*m2(1,5))

      sd(1,2) = (  2.D0*log(m2(1,1)/m2(2,1))*log(-m2(1,5)/m2(2,1))
     &           - 4.D0*zeta2        )/(m2(1,1)*m2(1,5))
      sd(2,2) = (- 2.D0*log(xx1)*log(1.D0-xx1)
     &           + 2.D0*log(xx1)*log(1.D0+xx1)
     &           - 2.D0*log(xx1)*log(-m2(1,5)/m2(2,1))
     &           - 2.D0*Lir2(xx1)
     &           + 2.D0*Lir2(-xx1)
     &           - 3.D0*zeta2        )/(m2(1,1)*m2(1,5)*xw1)
      sd(3,2) = (  2.D0*log(-m2(1,5)/m2(2,1))*log(-m2(1,4)/m2(2,1))
     &           - 7.D0*zeta2/2.D0     )/(m2(1,5)*m2(1,4))

c   the general four point functions
      sd(4,1) = real(D04(m2(2,1),eps1,eps1,m2(2,1),m2(1,2),m2(1,1),
     &                m1(2,4),m1(2,5),m1(2,5),m1(2,5)))
      sd(5,1) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,2),
     &                m1(2,4),m1(2,4),m1(2,4),m1(2,5)))
      sd(6,1) = real(D04(eps1,m2(2,1),eps1,m2(2,1),m2(1,3),m2(1,2),
     &                m1(2,5),m1(2,5),m1(2,4),m1(2,4)))
c      sd(7,1) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,2),
c     &                m1(2,4),m1(2,3),m1(2,4),m1(2,5)))
      sd(8,1) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,2),
     &                   m1(2,4),m1(2,4),m1(2,4),0.D0   ))
      sd(9,1) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,2),
     &                   m1(2,4),m1(2,3),m1(2,4),0.D0   ))
      sd(10,1) = dumd_1(m2(1,2),m2(2,1),m2(2,1),
     &                  m2(2,4),mgc2,m2(1,1),sc,m2(2,6),zeta2)
      sd(11,1) = dumd_2(tg,ug,m2(2,4),m2(2,1),mdiff,mdiffc,m2(2,6))

      sd(4,2) = real(D04(m2(2,1),eps1,eps1,m2(2,1),m2(1,3),m2(1,1),
     &                m1(2,4),m1(2,5),m1(2,5),m1(2,5)))
      sd(5,2) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,3),
     &                m1(2,4),m1(2,4),m1(2,4),m1(2,5)))
      sd(6,2) = real(D04(eps1,m2(2,1),eps1,m2(2,1),m2(1,2),m2(1,3),
     &                m1(2,5),m1(2,5),m1(2,4),m1(2,4)))
c      sd(7,2) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,3),
c     &                m1(2,4),m1(2,3),m1(2,4),m1(2,5)))
      sd(8,2) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,3),
     &                   m1(2,4),m1(2,3),m1(2,4),0.D0   ))
      sd(9,2) = real(D04(eps1,eps1,m2(2,1),m2(2,1),m2(1,1),m2(1,3),
     &                   m1(2,4),m1(2,4),m1(2,4),0.D0   ))
      sd(10,2) = dumd_1(m2(1,3),m2(2,1),m2(2,1),
     &                  m2(2,4),mgc2,m2(1,1),sc,m2(2,6),zeta2)
      sd(11,2) = sd(11,1)

      return
      end


      SUBROUTINE NF01BW( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix-vector product x <-- (J'*J + c*I)*x, for the
C     Jacobian J as received from SLICOT Library routine NF01BD:
C
C          /  dy(1)/dwb(1)  |  dy(1)/dtheta  \
C     Jc = |       :        |       :        | .
C          \  dy(L)/dwb(L)  |  dy(L)/dtheta  /
C
C     This is a compressed representation of the actual structure
C
C         /   J_1    0    ..   0   |  L_1  \
C         |    0    J_2   ..   0   |  L_2  |
C     J = |    :     :    ..   :   |   :   | .
C         |    :     :    ..   :   |   :   |
C         \    0     0    ..  J_L  |  L_L  /
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the vector x.
C             N = BN*BSN + ST >= 0.  (See parameter description below.)
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             The integer parameters describing the structure of the
C             matrix J, as follows:
C             IPAR(1) must contain ST, the number of parameters
C                     corresponding to the linear part.  ST >= 0.
C             IPAR(2) must contain BN, the number of blocks, BN = L,
C                     for the parameters corresponding to the nonlinear
C                     part.  BN >= 0.
C             IPAR(3) must contain BSM, the number of rows of the blocks
C                     J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the
C                     number of rows of the matrix J, if BN <= 1.
C             IPAR(4) must contain BSN, the number of columns of the
C                     blocks J_k, k = 1:BN.  BSN >= 0.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 4.
C
C     DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
C             The real parameters needed for solving the problem.
C             The entry DPAR(1) must contain the real scalar c.
C
C     LDPAR   (input) INTEGER
C             The length of the array DPAR.  LDPAR >= 1.
C
C     J       (input) DOUBLE PRECISION array, dimension (LDJ, NC)
C             where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
C             The leading NR-by-NC part of this array must contain
C             the (compressed) representation (Jc) of the Jacobian
C             matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM,
C             if BN > 1.
C
C     LDJ     (input) INTEGER
C             The leading dimension of array J.  LDJ >= MAX(1,NR).
C
C     X       (input/output) DOUBLE PRECISION array, dimension
C             (1+(N-1)*INCX)
C             On entry, this incremented array must contain the
C             vector x.
C             On exit, this incremented array contains the value of the
C             matrix-vector product (J'*J + c*I)*x.
C
C     INCX    (input) INTEGER
C             The increment for the elements of X.  INCX >= 1.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= NR.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The associativity of matrix multiplications is used; the result
C     is obtained as:  x_out = J'*( J*x ) + c*x.
C
C     CONTRIBUTORS
C
C     A. Riedel, R. Schneider, Chemnitz University of Technology,
C     Mar. 2001, during a stay at University of Twente, NL.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001,
C     Mar. 2002.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations,
C     Wiener system.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N
C     .. Array Arguments ..
      DOUBLE PRECISION  DPAR(*), DWORK(*), J(LDJ,*), X(*)
      INTEGER           IPAR(*)
C     .. Local Scalars ..
      INTEGER           BN, BSM, BSN, IBSM, IBSN, IX, JL, M, NTHS, ST,
     $                  XL
      DOUBLE PRECISION  C
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMV, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     ..
C     .. Executable Statements ..
C
      INFO = 0
C
      IF ( N.LT.0 ) THEN
         INFO = -1
      ELSEIF ( LIPAR.LT.4 ) THEN
         INFO = -3
      ELSEIF ( LDPAR.LT.1 ) THEN
         INFO = -5
      ELSEIF ( INCX.LT.1 ) THEN
         INFO = -9
      ELSE
         ST   = IPAR(1)
         BN   = IPAR(2)
         BSM  = IPAR(3)
         BSN  = IPAR(4)
         NTHS = BN*BSN
         IF ( BN.GT.1 ) THEN
            M = BN*BSM
         ELSE
            M = BSM
         END IF
         IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN
            INFO = -2
         ELSEIF ( N.NE.NTHS + ST ) THEN
            INFO = -1
         ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN
            INFO = -7
         ELSEIF ( LDWORK.LT.M ) THEN
            INFO = -11
         END IF
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'NF01BW', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
      C = DPAR(1)
C
      IF ( M.EQ.0 ) THEN
C
C        Special case, void Jacobian: x <-- c*x.
C
         CALL DSCAL( N, C, X, INCX )
         RETURN
      END IF
C
      IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN
C
C        Special case, l <= 1 or BSN = 0: the Jacobian is represented
C        as a full matrix. Adapted code from NF01BX is included in-line.
C
         CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO,
     $               DWORK, 1 )
         CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X,
     $               INCX )
         RETURN
      END IF
C
C     General case: l > 1, BSN > 0, BSM > 0.
C
      JL = BSN + 1
      IX = BSN*INCX
      XL = BN*IX + 1
C
      IF ( ST.GT.0 ) THEN
         CALL DGEMV( 'NoTranspose', M, ST, ONE, J(1,JL), LDJ, X(XL),
     $               INCX, ZERO, DWORK, 1 )
      ELSE
         DWORK(1) = ZERO
         CALL DCOPY( M, DWORK(1), 0, DWORK, 1 )
      END IF
      IBSN = 1
C
      DO 10 IBSM = 1, M, BSM
         CALL DGEMV( 'NoTranspose', BSM, BSN, ONE, J(IBSM,1), LDJ,
     $               X(IBSN), INCX, ONE, DWORK(IBSM), 1 )
         CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), LDJ,
     $               DWORK(IBSM), 1, C, X(IBSN), INCX )
         IBSN = IBSN + IX
   10 CONTINUE
C
      IF ( ST.GT.0 )
     $   CALL DGEMV( 'Transpose', M, ST, ONE, J(1,JL), LDJ, DWORK, 1, C,
     $               X(XL), INCX )
C
      RETURN
C
C *** Last line of NF01BW ***
      END


c
c
c     =====================================================
      subroutine rp1(maxm,meqn,mwaves,mbc,mx,ql,qr,auxl,auxr,
     &			wave,s,amdq,apdq)
c     =====================================================
c
c     # Riemann solver for the acoustics equations in 1d,
c     #  variable coefficients
c
c     # On input, ql contains the state vector at the left edge of each cell
c     #           qr contains the state vector at the right edge of each cell
c
c     # On output, wave contains the waves,
c     #            s the speeds,
c     #
c     #            amdq = A^- Delta q,
c     #            apdq = A^+ Delta q,
c     #                   the decomposition of the flux difference
c     #                       f(qr(i-1)) - f(ql(i))
c     #                   into leftgoing and rightgoing parts respectively.
c     #
c
c     # Note that the i'th Riemann problem has left state qr(i-1,:)
c     #                                    and right state ql(i,:)
c     # From the basic clawpack routines, this routine is called with ql = qr
c
c
      implicit double precision (a-h,o-z)
c
      dimension auxl(1-mbc:maxm+mbc, 2)
      dimension auxr(1-mbc:maxm+mbc, 2)
      dimension wave(1-mbc:maxm+mbc, meqn, mwaves)
      dimension    s(1-mbc:maxm+mbc, mwaves)
      dimension   ql(1-mbc:maxm+mbc, meqn)
      dimension   qr(1-mbc:maxm+mbc, meqn)
      dimension apdq(1-mbc:maxm+mbc, meqn)
      dimension amdq(1-mbc:maxm+mbc, meqn)
      common /comlim/ mylim,mrplim(2)
c
c     local arrays
c     ------------
      dimension delta(2)
c
c
c     # split the jump in q at each interface into waves
c
c     # find a1 and a2, the coefficients of the 2 eigenvectors:
      do 20 i = 2-mbc, mx+mbc
         delta(1) = ql(i,1) - qr(i-1,1)
         delta(2) = ql(i,2) - qr(i-1,2)

c        # impedances:
	 zi = auxl(i,1)*auxl(i,2)
	 zim = auxl(i-1,1)*auxl(i-1,2)

	 a1 = (-delta(1) + zi*delta(2)) / (zim + zi)
	 a2 =  (delta(1) + zim*delta(2)) / (zim + zi)
c
c        # Compute the waves.
c
         wave(i,1,1) = -a1*zim
         wave(i,2,1) = a1
         s(i,1) = -auxl(i-1,2)
c
         wave(i,1,2) = a2*zi
         wave(i,2,2) = a2
         s(i,2) = auxl(i,2)
c
   20    continue
c
c
c     # compute the leftgoing and rightgoing fluctuations:
c     # Note s(i,1) < 0   and   s(i,2) > 0.
c
      do 220 m=1,meqn
         do 220 i = 2-mbc, mx+mbc
            amdq(i,m) = s(i,1)*wave(i,m,1)
            apdq(i,m) = s(i,2)*wave(i,m,2)
  220       continue
c
      if (mylim .gt. 0) then
c
c        # apply limiter here rather than using default in limiter.f
c
         do 40 i=1,mx
c           # limit 1-wave by looking at wave to right:
	    a1i = wave(i,2,1)
	    if (a1i .eq. 0.d0) go to 30

	    if (mylim .eq. 1) then
c               # Lax-Liu limiter:
                delta(1) = ql(i+1,1) - qr(i,1)
                delta(2) = ql(i+1,2) - qr(i,2)
	      else if (mylim .eq. 2) then
c               # Transmission-based limiter for acoutics:
                delta(1) = wave(i+1,1,1)
                delta(2) = wave(i+1,2,1)
	      endif

c           # impedances:
      	    zi = auxl(i,1)*auxl(i,2)
	    zim = auxl(i-1,1)*auxl(i-1,2)

	    a1ip1 = (-delta(1) + zi*delta(2)) / (zim + zi)
	    wlimitr = philim(a1i, a1ip1, mrplim(1))
	    wave(i,1,1) = wlimitr * wave(i,1,1)
	    wave(i,2,1) = wlimitr * wave(i,2,1)

   30       continue
c
c           # limit 2-wave by looking at wave to left:
	    a2i = wave(i,2,2)
	    if (a2i .eq. 0.d0) go to 40

	    if (mylim .eq. 1) then
c               # Lax-Liu limiter:
                delta(1) = ql(i-1,1) - qr(i-2,1)
                delta(2) = ql(i-1,2) - qr(i-2,2)
	      else if (mylim .eq. 2) then
c               # Transmission-based limiter for acoutics:
                delta(1) = wave(i-1,1,2)
                delta(2) = wave(i-1,2,2)
	      endif

c           # impedances:
      	    zi = auxl(i,1)*auxl(i,2)
	    zim = auxl(i-1,1)*auxl(i-1,2)

	    a2im1 =  (delta(1) + zim*delta(2)) / (zim + zi)
	    wlimitr = philim(a2i, a2im1, mrplim(2))
	    wave(i,1,2) = wlimitr * wave(i,1,2)
	    wave(i,2,2) = wlimitr * wave(i,2,2)
   40       continue
         endif

      return
      end


PROGRAM calc_etadot

!! Prepare input data for FLEXPART, esp. vertical velocity as
!! etadot or etadot * dp/deta

!*----------------------------------------------------------------
! author: L. Haimberger
! date:   03/2010
! version: V4.0
!
!## Program calc_etadot
!
! **Prepares input data for POP model meteorological preprocessor**
!
!-----------------------------------------------------------------
!
! Calculation of etapoint on a regular \(\lambda-\phi\) grid and writing
! `U,V,ETAPOINT,T,PS,Q,SD,MSL,TCC,10U, 10V, 2T,2D,LSP,CP,SSHF,SSR,
! EWSS,NSSS`
! to an output file (input and output in GRIB 1 or 2 format).
!  etapoint is defined as the total time derivative of
!  ECMWF vertical coordinate eta multiplied by the derivative
!  of pressure with respect to eta:
!  \[\frac{\mathrm{d}\eta}{\mathrm{d}t}\frac{\partial p}{\partial \eta}\]
!
!### Version history and authors:
! - 04/1994: Leopold Haimberger, Gerhard Wotawa
!
! - 2003-05-11: Alexander Beck
!
! - 12/2006: L. Haimberger V2.0,
!           handle arbitrary regular grids and T799 resolution data
!
! - 03/2010: L. Haimberger V4.0,
!           handle GRIB edition 2 fields and T1279 resolution data
! - 04-06/2019: Petra Seibert,
!            beautify code and add FORD documentation
!
!-----------------------------------------------------------------
!  #
!## Input required:
!
!     UNIT  FILE      PARAMETER(S)    DATA REPRESENTATION
!
!     11    fort.11   T,U,V           regular lambda phi grid
!     12    fort.12   D               regular lambda phi grid
!     13    fort.13   LNSP            spherical harmonics
!     14    fort.14   SD,MSL,TCC,10U,
!                     10V,2T,2D       regular lambda phi grid
!     16    fort.16   LSP,CP,SSHF,
!                     SSR,EWSS,NSSS   regular lambda phi grid
!     17    fort.17   Q               regular lambda phi grid
!
!------------------------------------------------------------------
!
!### Output produced:
!
!    UNIT  FILE      PARAMETER(S)      DATA REPRESENTATION
!
!    15    fort.15   `U,V,ETA,T,PS,
!                    `Q,SD,MSL,TCC,`
!                    `10U,10V,2T,2D,`  regular lambda phi grid
!                    `LSP,CP,SSHF,`
!                    `SSR,EWSS,NSSS`
!
!------------------------------------------------------------------

  USE PHTOGR
  USE GRTOPH
  USE FTRAFO
  USE RWGRIB2
  USE GRIB_API

  IMPLICIT NONE

  REAL, ALLOCATABLE, DIMENSION (:,:) :: LNPS
  REAL, ALLOCATABLE, DIMENSION (:,:) :: Z
  REAL, ALLOCATABLE, DIMENSION (:,:,:) :: T, UV , UV2
  REAL, ALLOCATABLE, DIMENSION (:,:,:) :: QA,OM,OMR
  REAL, ALLOCATABLE, DIMENSION (:,:,:) :: DIV, ETA,ETAR
  REAL, ALLOCATABLE, DIMENSION (:,:) :: DPSDL, DPSDM
  REAL, ALLOCATABLE, DIMENSION (:,:,:) :: PS,DPSDT
  REAL, ALLOCATABLE, DIMENSION (:,:,:) :: SURF,FLUX,OROLSM
  REAL, ALLOCATABLE, DIMENSION (:) :: WSAVE,H,SINL,COSL,WSAVE2
  REAL, ALLOCATABLE, DIMENSION (:) :: BREITE, GBREITE,AK, BK,pv

! Arrays for Gaussian grid calculations
  REAL  :: X1,X2,RMS,MW,SIG,LAM
  REAL,ALLOCATABLE :: CUA(:,:,:),CVA(:,:,:)

  REAL, ALLOCATABLE, DIMENSION (:,:) :: P,PP,P2
  REAL, ALLOCATABLE, DIMENSION (:,:) :: XMN,HILFUV
  REAL, ALLOCATABLE, DIMENSION (:) :: LNPMN,LNPMN2,LNPMN3
  REAL, ALLOCATABLE, DIMENSION (:) :: WEIGHT
  REAL, ALLOCATABLE, DIMENSION (:,:) :: UGVG
  REAL, ALLOCATABLE, DIMENSION (:,:) :: DG, ETAG
  REAL, ALLOCATABLE, DIMENSION (:,:) :: GWSAVE
  REAL, ALLOCATABLE, DIMENSION (:) :: PSG,HILF

! end arrays for Gaussian grid calculations

  INTEGER, ALLOCATABLE, DIMENSION (:) :: MLAT,MPSURF,MPFLUX,MPORO,MPAR
  INTEGER, ALLOCATABLE :: GIFAX(:,:)

  REAL PI,COSB,DAK,DBK,P00
  REAL URLAR8,JMIN1,LLLAR8,MAXBMIN1,PIR8,DCOSB

  INTEGER I,J,K,L,IERR,M,LTEST,MK,NGI,NGJ
  INTEGER MFLUX,MSURF,MORO
  INTEGER LUNIT,LUNIT2

  INTEGER MAXL, MAXB, MLEVEL, LEVOUT,LEVMIN,LEVMAX
  INTEGER MOMEGA,MOMEGADIFF,MGAUSS,MSMOOTH, MNAUF,META,METADIFF
  INTEGER MDPDETA,METAPAR
  REAL RLO0, RLO1, RLA0, RLA1
  CHARACTER*300 MLEVELIST

  INTEGER MAUF, MANF,IFAX(10)

  INTEGER IGRIB(1),iret,ogrib

  CHARACTER*80 FILENAME

  NAMELIST /NAMGEN/ &
    MAXL, MAXB, &
    MLEVEL,MLEVELIST,MNAUF,METAPAR, &
    RLO0, RLO1, RLA0, RLA1, &
    MOMEGA,MOMEGADIFF,MGAUSS,MSMOOTH,META,METADIFF,&
    MDPDETA

  LTEST=1

  CALL POSNAM (4,'NAMGEN')
  READ (4,NAMGEN)

  MAUF=INT(360.*(REAL(MAXL)-1.)/(RLO1-RLO0)+0.0001)
!      PRINT*, MAUF

  MANF=INT(REAL(MAUF)/360.*(360.+RLO0)+1.0001)
  IF (MANF .gt. MAUF) MANF=MANF-MAUF

!------------------------------------------------------------------
!! ALLOCATE VARIABLES
!------------------------------------------------------------------

  ALLOCATE (LNPS(0:(MNAUF+1)*(MNAUF+2)-1,1))
  ALLOCATE (H(0:(MNAUF+2)*(MNAUF+3)/2))
  ALLOCATE (OM(MAXL, MAXB, MLEVEL))
  ALLOCATE (ETA(MAXL,MAXB,MLEVEL))
  ALLOCATE (PS(MAXL, MAXB,1),DPSDT(MAXL, MAXB,1))
  ALLOCATE (WSAVE(4*MAUF+15),WSAVE2(4*MAUF+15))
  ALLOCATE (BREITE(MAXB),AK(MLEVEL+1),BK(MLEVEL+1),PV(2*MLEVEL+2))
  ALLOCATE (MPAR(2))
  ALLOCATE (COSL(MAXL),SINL(MAXL))
  ALLOCATE (CUA(2,4,MLEVEL),CVA(2,4,MLEVEL))

!------------------------------------------------------------------
! GAUSS STUFF
!------------------------------------------------------------------

  IF (MGAUSS .EQ. 1) THEN
    LUNIT=0
    FILENAME='fort.18'

    CALL GRIB_OPEN_FILE(LUNIT, TRIM(FILENAME),'R')

    CALL GRIB_NEW_FROM_FILE(LUNIT,IGRIB(1), IRET)

! we can close the file
    CALL GRIB_CLOSE_FILE(LUNIT)
!      call grib_get(igrib(1),'gridType', j)

    NGJ=MNAUF+1

    ALLOCATE (GWSAVE(8*NGJ+15,NGJ/2))
    ALLOCATE(GIFAX(10,NGJ))
    ALLOCATE (GBREITE(NGJ),WEIGHT(NGJ))
    ALLOCATE (MLAT(NGJ))
    ALLOCATE (P(0:((MNAUF+3)*(MNAUF+4))/2,NGJ/2))
    ALLOCATE (PP(NGJ/2,0:((MNAUF+3)*(MNAUF+4))/2))
    ALLOCATE (Z(0:((MNAUF+3)*(MNAUF+4))/2,MAXB))

    CALL GRIB_GET(IGRIB(1),'numberOfPointsAlongAMeridian', NGJ)

!   get as a integer
    call grib_get(igrib(1),'pl', MLAT)

    NGI=SUM(MLAT)

    CALL GRIB_GET(IGRIB(1),'numberOfVerticalCoordinateValues',MK)

    IF (MK/2-1 .NE. MLEVEL) THEN
      WRITE(*,*) 'FATAL: Number of model levels',mk, &
        ' does not agree with', MLEVEL,' in namelist'
      STOP
    END IF
    call grib_get(igrib(1),'pv',pv)
    AK=PV(1:1+MLEVEL)
    BK=PV(2+MLEVEL:2*MLEVEL+2)

    ALLOCATE (LNPMN(0:(MNAUF+1)*(MNAUF+2)-1))
    ALLOCATE (LNPMN2(0:(MNAUF+1)*(MNAUF+2)-1))
    ALLOCATE (UGVG(NGI, 2*MLEVEL),HILFUV(2*MAXL,2))
    ALLOCATE (DPSDL(NGI,1),DPSDM(NGI,1))
    ALLOCATE (PSG(NGI),HILF(NGI))
    ALLOCATE (UV(MAXL, MAXB, 2*MLEVEL))
!      ALLOCATE (UV2(MAXL, MAXB, 2*MLEVEL))
    ALLOCATE (XMN(0:(MNAUF+1)*(MNAUF+2)-1, 2*MLEVEL))
    ALLOCATE (DG(NGI,MLEVEL),ETAG(NGI,MLEVEL))

!! Initialisieren  Legendretransformation auf das LaT/LON Gitter

    PI=ACOS(-1.D0)

!$OMP PARALLEL DO
    DO 20 J=1,MAXB
      BREITE(J)=SIN((RLA1-(J-1.D0)*(RLA1-RLA0)/(MAXB-1))* PI/180.D0)
      CALL PLGNFA(MNAUF,BREITE(J),Z(0,J))
20  CONTINUE
!$OMP END PARALLEL DO

! Avoid possible Pole problem
!      IF (RLA0 .EQ. -90.0) BREITE(MAXB)=sin(-89.99*PI/180.d0)
!      IF (RLA1 .EQ. 90.0)  BREITE(1)=sin(89.99*PI/180.d0)

!* Initialisation of fields for FFT and Legendre transformation
! to Gaussian grid and back to phase space
    X1=-1.D0
    X2=1.D0
    CALL GAULEG(X1,X2,GBREITE,WEIGHT,NGJ)

!$OMP PARALLEL DO PRIVATE(M)
    DO J=1,NGJ/2
      CALL PLGNFA(MNAUF,GBREITE(J),P(:,J))
      DO M=0,(MNAUF+3)*(MNAUF+4)/2
        PP(J,M)=P(M,J)
      END DO
    END DO
!$OMP END PARALLEL DO

!       MPAR(1)=152
    FILENAME='fort.12'
!!  read LNSP in SH
    CALL READSPECTRAL(FILENAME,LNPMN,MNAUF,1,MLEVEL,(/152/),AK,BK)
    CALL SET99(WSAVE,IFAX,mauf)
    CALL PHGCUT(LNPMN,PS,WSAVE,IFAX,Z,MNAUF,MNAUF,MAUF,MANF,MAXL,MAXB,1)
    CALL STATIS(MAXL,MAXB,1,EXP(PS),RMS,MW,SIG)
    WRITE(*,'(A,T20,3F12.4)') 'STATISTICS PS: ',RMS,MW,SIG

    DO J=1,NGJ/2
      CALL SET99(GWSAVE(1,J),GIFAX(1,J),MLAT(J))
    END DO
    CALL PHGR213(LNPMN,HILF,GWSAVE,GIFAX,P,MLAT,MNAUF,NGI,NGJ,1)
    PSG=HILF
    CALL GRPH213(LNPMN2,PSG,GWSAVE,GIFAX,PP,WEIGHT,MLAT,MNAUF,NGI,NGJ,1)
    CALL PHGR213(LNPMN2,HILF,GWSAVE,GIFAX,P,MLAT,MNAUF,NGI,NGJ,1)

    HILF=exp(PSG)-exp(HILF)

    CALL STATIS(NGI,1,1,HILF,RMS,MW,SIG)
    WRITE(*,'(A,T20,3F12.4)') 'STATISTICS ratio of PS: ',RMS,MW,SIG

    PSG=EXP(PSG)
    HILF=PSG
    CALL STATIS(NGI,1,1,HILF,RMS,MW,SIG)
    WRITE(*,'(A,T20,3F12.4)') 'STATISTICS PSG: ',RMS,MW,SIG

111 FILENAME='fort.10'
!!  read u,v in SH
    CALL READSPECTRAL(FILENAME,XMN,MNAUF,2*MLEVEL,MLEVEL,(/131,132/),AK,BK)

!!  Transformieren des Windes auf das Gaussgitter
    CALL PHGR213(XMN,UGVG,GWSAVE,GIFAX,P,MLAT,MNAUF,NGI,NGJ,2*MLEVEL)
    DO K=1,MLEVEL
! North Pole
      CALL JSPPOLE(XMN(:,K),1,MNAUF,.TRUE.,CUA(:,:,K))
      CALL JSPPOLE(XMN(:,MLEVEL+K),1,MNAUF,.TRUE.,CVA(:,:,K))
! South Pole
      CALL JSPPOLE(XMN(:,K),-1,MNAUF,.TRUE.,CUA(:,3:4,K))
      CALL JSPPOLE(XMN(:,MLEVEL+K),-1,MNAUF,.TRUE.,CVA(:,3:4,K))
    END DO

    DO K=1,2*MLEVEL
      IF (MSMOOTH .ne. 0) CALL SPFILTER(XMN(:,K),MNAUF,MSMOOTH)
    END DO
    CALL PHGCUT(XMN,UV,WSAVE,IFAX,Z,MNAUF,MNAUF,MAUF,MANF,MAXL,MAXB,2*MLEVEL)

112 FILENAME='fort.13'
!!  read DIV in SH
    CALL READSPECTRAL(FILENAME,XMN,MNAUF,MLEVEL,MLEVEL,(/155/),AK,BK)
!! Transformieren der horizontalen Divergenz auf das Gaussgitter
    CALL PHGR213(XMN,DG,GWSAVE,GIFAX,P,MLAT,MNAUF,NGI,NGJ,MLEVEL)
    CALL STATIS(MAXL,MAXB,1,DG,RMS,MW,SIG)
    WRITE(*,'(A,T20,3p,3F12.4)') 'STATISTICS DG-PS: ',RMS,MW,SIG

!! Berechnung des Gradienten des Logarithmus des Bodendrucks auf dem Gaussgitter
    CALL PHGRAD(LNPMN,DPSDL,DPSDM,GWSAVE,GIFAX,P,H,MLAT,MNAUF,NGI,NGJ,1)

!! Berechnung der Vertikalgeschwindigkeit auf dem Gaussgitter
    CALL CONTGL(HILF,DPSDL,DPSDM,DG,UGVG(:,1),UGVG(:,MLEVEL+1), &
      GBREITE,ETAG,MLAT,AK,BK,NGI,NGJ,MLEVEL)
! note that HILF is ps on input and  dpsdt*ps on output

     CALL STATIS(MAXL,MAXB,1,ETAG,RMS,MW,SIG)
     WRITE(*,'(A,T20,3p,3F12.4)') 'STATISTICS ETAG-PS: ',RMS,MW,SIG
    CALL GRPH213(XMN,ETAG,GWSAVE,GIFAX,PP,WEIGHT,MLAT,MNAUF,NGI,NGJ,MLEVEL)
     CALL STATIS(MAXL,MAXB,1,ETAG,RMS,MW,SIG)
     WRITE(*,'(A,T20,3p,3F12.4)') 'STATISTICS ETAG-PS: ',RMS,MW,SIG
    DO K=1,MLEVEL
      IF (MSMOOTH .ne. 0) CALL SPFILTER(XMN(:,K),MNAUF,MSMOOTH)
    END DO

    CALL PHGCUT(XMN,ETA,WSAVE,IFAX,Z,MNAUF,MNAUF,MAUF,MANF,MAXL,MAXB,MLEVEL)
    CALL STATIS(MAXL,MAXB,1,ETA,RMS,MW,SIG)
    WRITE(*,'(A,T20,3p,3F12.4)') 'STATISTICS ETA-PS: ',RMS,MW,SIG

    CALL GRPH213(XMN,HILF,GWSAVE,GIFAX,PP,WEIGHT,MLAT, MNAUF,NGI,NGJ,1)
    CALL STATIS(MAXL,MAXB,1,HILF,RMS,MW,SIG)
    WRITE(*,'(A,T20,3p,3F12.4)') 'STATISTICS HILF-PS: ',RMS,MW,SIG

    IF (MSMOOTH .ne. 0) CALL SPFILTER(XMN(:,1),MNAUF,MSMOOTH)
    CALL PHGCUT(XMN,DPSDT,WSAVE,IFAX,Z,MNAUF,MNAUF,MAUF,MANF,MAXL,MAXB,1)

    CALL STATIS(MAXL,MAXB,1,DPSDT,RMS,MW,SIG)
    WRITE(*,'(A,T20,3F12.4)') 'STATISTICS DPSDT: ',RMS,MW,SIG

    IF (MOMEGADIFF .ne. 0) THEN
!! Berechnung von Omega auf dem Gaussgitter

      CALL OMEGA(PSG,DPSDL,DPSDM,DG,UGVG(:,1),UGVG(:,MLEVEL+1), &
        GBREITE,ETAG,MLAT,AK,BK,NGI ,NGJ,MLEVEL)
      CALL GRPH213(XMN,ETAG,GWSAVE,GIFAX,PP,WEIGHT,MLAT,MNAUF,NGI,NGJ,MLEVEL)
      DO K=1,MLEVEL
        IF (MSMOOTH .ne. 0) CALL SPFILTER(XMN(:,K),MNAUF,MSMOOTH)
      END DO
      CALL PHGCUT(XMN,OM,WSAVE,IFAX,Z,MNAUF,MNAUF,MAUF,MANF,MAXL,MAXB,MLEVEL)

    END IF ! MOMEGA

    CALL GRPH213(XMN,PSG,GWSAVE,GIFAX,PP,WEIGHT,MLAT,MNAUF,NGI,NGJ,1)

    CALL STATIS(MAXL,MAXB,1,PSG,RMS,MW,SIG)
    WRITE(*,'(A,T20,3F12.4)') 'STATISTICS PSG-PS: ',RMS,MW,SIG

    CALL PHGCUT(XMN,PS,WSAVE,IFAX,Z,MNAUF,MNAUF,MAUF,MANF,MAXL,MAXB,1)

    CALL STATIS(MAXL,MAXB,1,PS,RMS,MW,SIG)
    WRITE(*,'(A,T20,3F12.4)') 'STATISTICS PS: ',RMS,MW,SIG

114 DEALLOCATE(HILF,PSG,DPSDL,DPSDM,ETAG,DG,LNPMN)

!      ALLOCATE (UV(MAXL, MAXB, 2*MLEVEL))
! CALL GRPH213(XMN,UGVG,GWSAVE,GIFAX,PP,WEIGHT,MLAT,
!     *MNAUF,NGI,NGJ,2*MLEVEL)
!        DO K=1,2*MLEVEL
!          IF (MSMOOTH .ne. 0) CALL SPFILTER(XMN(:,K),MNAUF,MSMOOTH)
!        END DO
!        CALL PHGCUT(XMN,UV,WSAVE,IFAX,Z,
!     *MNAUF,MNAUF,MAUF,MANF,MAXL,MAXB,2*MLEVEL)
    DEALLOCATE(PP,P,UGVG,MLAT,GBREITE,WEIGHT,GWSAVE,XMN)
!        CALL ETAGAUSS(Z,WSAVE
!     *,BREITE,UV,ETA,OM,PS,
!     *MAUF,MAXB,MAXL,MANF,MNAUF,MLEVEL,MSMOOTH)

  ELSE

!-----------------------------------------------------------------
!     READING OF PREPARED METEOROLOGICAL FIELDS
!
!     THE FOLLOWING FIELDS ARE EXPECTED:
!
!     UNIT 11: T,U,V        (REGULAR GRID)
!     UNIT 17: Q            (REGULAR GRID)
!     UNIT 13: D            (REGULAR GRID)
!     UNIT 12: LNSP         (SPHERICAL HARMONICS)
!     UNIT 14: SURFACE DATA (REGULAR GRID)
!     UNIT 16: FLUX DATA    (REGULAR GRID)
!------------------------------------------------------------------

    ALLOCATE (MLAT(MAXB))
    MLAT=MAXL
    ALLOCATE (Z(0:((MNAUF+3)*(MNAUF+4))/2,1))
    ALLOCATE (DPSDL(MAXL,MAXB),DPSDM(MAXL,MAXB))
    ALLOCATE (UV(MAXL, MAXB, 2*MLEVEL),DIV(MAXL,MAXB,MLEVEL))

!------------------------------------------------------------------
!! READING OF SURFACE PRESSURE
!------------------------------------------------------------------

    FILENAME='fort.12'
    CALL READSPECTRAL(FILENAME,LNPS,MNAUF,1,MLEVEL,(/152/),AK,BK)

!------------------------------------------------------------------
!! READING OF U,V
!------------------------------------------------------------------

! OPENING OF UNBLOCKED GRIB FILE

    FILENAME='fort.10'
    CALL READLATLON(FILENAME,UV,MAXL,MAXB,2*MLEVEL,(/131,132/))

    PI=ACOS(-1.D0)
    DO J=1,MAXB
      BREITE(J)=SIN((RLA1-(J-1.D0)*(RLA1-RLA0)/(MAXB-1))*PI/180.D0)
    END DO

! Avoid possible Pole problem
!      IF (RLA0 .EQ. -90.0) BREITE(MAXB)=sin(-89.99*PI/180.d0)
!      IF (RLA1 .EQ. 90.0)  BREITE(1)=sin(89.99*PI/180.d0)

    DO K=1,2*MLEVEL
      DO J=1,MAXB
        COSB=SQRT(1.0-(BREITE(J))*(BREITE(J)))
        IF (RLA0 .EQ. -90.0 .AND. J .EQ. MAXB .OR. &
            RLA1 .EQ.  90.0 .AND. J .EQ. 1) THEN
          UV(:,J,K)=UV(:,J,K)/1.D6
        ELSE
          UV(:,J,K)=UV(:,J,K)*COSB
        END IF
      END DO
    END DO

!------------------------------------------------------------------
!! READING OF LNSP on grid
!------------------------------------------------------------------

! For debugging only
!      FILENAME='LNSPG_G.20060330.600'
!      INQUIRE(FILE=FILENAME,EXIST=EX)
!      CALL READLATLON(FILENAME,QA,
!     *MAXL,MAXB,1,1,(/152/))

!------------------------------------------------------------------
!! READING OF DIVERGENCE
!------------------------------------------------------------------

    IF (META .EQ. 0 .OR. METADIFF .EQ. 1) THEN
      FILENAME='fort.13'
      CALL READLATLON(FILENAME,DIV,MAXL,MAXB,MLEVEL,(/155/))
    END IF

!------------------------------------------------------------------
!
!  Calculation of etapoint --> total time derivative of
!  ECMWF vertical coordinate eta multiplied by the derivative
!  of pressure with respect to eta:
!  \[\frac{\mathrm{d}\eta}{\mathrm{d}t}\frac{\partial p}{\partial \eta}\]
!------------------------------------------------------------------

!* Initialisieren  Legendretransformation auf das LaT/LON Gitter
!! Without Gaussian grid calculation Legendre Polynomials are calculated
!! only for one latitude to save space

    DO J=1,MAXB
      CALL PLGNFA(MNAUF,BREITE(J),Z(0,1))
      CALL PHGCUT(LNPS,PS(:,J,1),WSAVE,IFAX,Z,MNAUF,MNAUF,MAUF,MANF,MAXL,1,1)
      IF (META .EQ. 0 .OR. METADIFF .EQ. 1 ) THEN
        CALL PHGRACUT(LNPS,DPSDL(:,J),DPSDM(:,J),WSAVE,IFAX,Z,H,MAUF, &
          MNAUF,MAXL,1,MANF,1)
      END IF
    END DO

    PS=EXP(PS)

! For debugging only
    CALL STATIS(MAXL,MAXB,1,PS(:,:,1),RMS,MW,SIG)
    WRITE(*,'(A,T20,3F12.4)') 'STATISTICS: ',RMS,MW,SIG

    IF (MOMEGADIFF .ne. 0) THEN
      CALL OMEGA(PS,DPSDL,DPSDM,DIV,UV(:,:,1),UV(:,:,MLEVEL+1), &
        BREITE,OM,MLAT,AK,BK,MAXL*MAXB,MAXB,MLEVEL)
    END IF

    IF (META .EQ. 0 .OR. METADIFF .ne. 0) THEN
      DPSDT=PS
      CALL CONTGL(DPSDT,DPSDL,DPSDM,DIV,UV(:,:,1),UV(:,:,MLEVEL+1), &
        BREITE,ETA,MLAT,AK,BK,MAXL*MAXB,MAXB,MLEVEL)
    END IF

  END IF ! MGAUSS

! CREATE FILE VERTICAL.EC NEEDED BY POP MODEL
! 2020-06-25 Commented out by PS - not needed anymore

!  OPEN(21,FILE='VERTICAL.EC')
!  WRITE(21,'(A)')
!  WRITE(21,'(A)') 'VERTICAL DISCRETIZATION OF POP MODEL'
!  WRITE(21,'(A)')
!  write(21,'(i3,a)') MLEVEL,'   number of layers'
!  WRITE(21,'(A)')
!  WRITE(21,'(A)') '* A(NLEV+1)'
!  WRITE(21,'(A)')
!  DO 205 I=1,MLEVEL+1
!205 WRITE(21,'(F18.12)') AK(I)
!  WRITE(21,'(A)')
!  WRITE(21,'(A)') '* B(NLEV+1)'
!  WRITE(21,'(A)')
!  DO 210 I=1,MLEVEL+1
!210 WRITE(21,'(F18.12)') BK(I)
!  CLOSE(21)

!------------------------------------------------------------------
! READING OF OMEGA
!------------------------------------------------------------------

  IF (MOMEGA .NE. 0 ) THEN

    ALLOCATE (OMR(MAXL, MAXB, MLEVEL))

    FILENAME='fort.19'
    CALL READLATLON(FILENAME,OMR,MAXL,MAXB,MLEVEL,(/135/))

    IF (MOMEGADIFF .NE. 0) THEN

      DO K=1,MLEVEL
        CALL STATIS(MAXL,MAXB,1,ETA(:,:,K),RMS,MW,SIG)
        WRITE(*,'(A12,I3,3F12.4)') '       ETA: ',K,RMS,MW,SIG
        CALL STATIS(MAXL,MAXB,1,OMR(:,:,K),RMS,MW,SIG)
        WRITE(*,'(A12,I3,3F12.4)') '     OMEGA: ',K,RMS,MW,SIG
        CALL STATIS(MAXL,MAXB,1,OM(:,:,K)-OMR(:,:,K),RMS,MW,SIG)
        WRITE(*,'(A12,I3,3F12.4)') 'OMEGA DIFF: ',K,RMS,MW,SIG
      END DO

    END IF
  END IF

!------------------------------------------------------------------
! READING OF ETA
!------------------------------------------------------------------

  IF (META .NE. 0 ) THEN

    ALLOCATE (ETAR(MAXL, MAXB, MLEVEL))

    P00=101325.
    FILENAME='fort.21'
    CALL READLATLON(FILENAME,ETAR,MAXL,MAXB,MLEVEL,(/77/))

    IF(MDPDETA .EQ. 1) THEN
      DO K=1,MLEVEL
        DAK=AK(K+1)-AK(K)
        DBK=BK(K+1)-BK(K)
        DO J=1,MAXB
          DO I=1,MAXL
            ETAR(I,J,K)=2*ETAR(I,J,K)*PS(I,J,1)*(DAK/PS(I,J,1)+DBK)/ &
              (DAK/P00+DBK)
            IF (K .GT. 1) ETAR(I,J,K)=ETAR(I,J,K)-ETAR(I,J,K-1)
          END DO
        END DO
      END DO
    END IF

    IF (METADIFF .NE. 0 ) THEN

      DO K=1,MLEVEL
        CALL STATIS(MAXL,MAXB,1,ETA(:,:,K),RMS,MW,SIG)
        WRITE(*,'(A12,I3,3F12.4)') '       ETA: ',K,RMS,MW,SIG
        CALL STATIS(MAXL,MAXB,1,ETAR(:,:,K),RMS,MW,SIG)
        WRITE(*,'(A12,I3,3F12.4)') '     ETAR: ',K,RMS,MW,SIG
        CALL STATIS(MAXL,MAXB,1,ETA(:,:,K)-ETAR(:,:,K),RMS,MW,SIG)
        WRITE(*,'(A12,I3,3F12.4)') 'ETA DIFF: ',K,RMS,MW,SIG
      END DO
      DO K=1,MLEVEL
        WRITE(*,'(I3,2F12.4)') K,ETA(1,MAXB/2,K),ETAR(1,MAXB/2,K)
      END DO
    ELSE
      ETA=ETAR
    END IF
  END IF

  ALLOCATE (T(MAXL, MAXB, MLEVEL))
  ALLOCATE (QA(MAXL, MAXB, MLEVEL))

!------------------------------------------------------------------
!! READING OF T
!------------------------------------------------------------------

! OPENING OF UNBLOCKED GRIB FILE

  FILENAME='fort.11'
  CALL READLATLON(FILENAME,T,MAXL,MAXB,MLEVEL,(/130/))

!------------------------------------------------------------------
!! READING OF SPECIFIC HUMIDITY
!------------------------------------------------------------------

  FILENAME='fort.17'
  CALL READLATLON(FILENAME,QA,MAXL,MAXB,MLEVEL,(/133/))

!------------------------------------------------------------------
!                     TEST READING OF UV from MARS (debug only)
!------------------------------------------------------------------
!      FILENAME='fort.22'
!      CALL READLATLON(FILENAME,UV2,MAXL,MAXB,2*MLEVEL,2,(/131,132/))

!------------------------------------------------------------------
!! WRITE MODEL LEVEL DATA TO fort.15
!------------------------------------------------------------------

!!     Calculation of etadot in CONTGL needed scaled winds (ucosphi,vcosphi)
!!     Now we are transforming back to the usual winds.

  DO K=1,MLEVEL
    DO J=2,MAXB-1
      COSB=SQRT(1.0-(BREITE(J))*(BREITE(J)))
      UV(:,J,K)=UV(:,J,K)/COSB
      UV(:,J,MLEVEL+K)=UV(:,J,MLEVEL+K)/COSB
    END DO

! special treatment for poles, if necessary.
    DO J=1,MAXB,MAXB-1
      COSB=SQRT(1.0-(BREITE(J))*(BREITE(J)))
      IF (1.0-BREITE(J)*BREITE(J) .GT. 0 .OR. MGAUSS .NE. 1) THEN
        IF (RLA0 .EQ. -90.0 .AND. J .EQ. MAXB .OR. &
            RLA1 .EQ.  90.0 .AND. J .EQ. 1) THEN
          UV(:,J,K)=UV(:,J,K)*1.D6
          UV(:,J,MLEVEL+K)=UV(:,J,MLEVEL+K)*1.D6
        ELSE
          UV(:,J,K)=UV(:,J,K)/COSB
          UV(:,J,MLEVEL+K)=UV(:,J,MLEVEL+K)/COSB
        END IF
      ELSE
        HILFUV(5:MAXL,:)=0.
        HILFUV(1:2,:)=0.
        IF (J.EQ.MAXB) THEN
! Suedpol
          HILFUV(3:4,1)=CUA(:,4,K)
          HILFUV(3:4,2)=CVA(:,4,K)
        ELSE
! Nordpol
          HILFUV(3:4,1)=CUA(:,2,K)
          HILFUV(3:4,2)=CVA(:,2,K)
        END IF
        CALL RFOURTR(HILFUV(:,1),WSAVE,IFAX,MAXL/2-1,MAXL,-1)
        DO I=0,MAXL-1
          IF (MANF+I .LE. MAXL) THEN
            UV(I+1,J,K)=HILFUV(MANF+I,1)
          ELSE
            UV(I+1,J,K)=HILFUV(MANF-MAXL+I,1)
          END IF
        END DO
        CALL RFOURTR(HILFUV(:,2),WSAVE,IFAX,MAXL/2-1,MAXL,-1)
        DO I=0,MAXL-1
          IF (MANF+I .LE. MAXL) THEN
            UV(I+1,J,MLEVEL+K)=HILFUV(MANF+I,2)
          ELSE
            UV(I+1,J,MLEVEL+K)=HILFUV(MANF-MAXL+I,2)
          END IF
        END DO
      end if
    END DO
  END DO

! open output file
  call grib_open_file(LUNIT,'fort.15','w')

! we use temperature on lat/lon on model levels as template for model level data
  LUNIT2=0
  CALL GRIB_OPEN_FILE(LUNIT2,'fort.11','R')
  CALL GRIB_NEW_FROM_FILE(LUNIT2,IGRIB(1), IRET)
  CALL GRIB_CLOSE_FILE(LUNIT2)

  CALL WRITELATLON &
    (LUNIT,IGRIB(1),OGRIB,UV(:,:,1),MAXL,MAXB,MLEVEL,MLEVELIST,1,(/131/))

  CALL WRITELATLON &
    (LUNIT,IGRIB(1),OGRIB,UV(:,:,MLEVEL+1),MAXL,MAXB,MLEVEL,MLEVELIST,1,(/132/))

  IF (MDPDETA .ne. 1 .AND. MGAUSS .EQ. 0 .and. META .eq. 1) THEN
    CALL WRITELATLON &
      (LUNIT,IGRIB(1),OGRIB,ETA,MAXL,MAXB,MLEVEL,MLEVELIST,1,(/77/))
  ELSE
    CALL WRITELATLON &
      (LUNIT,IGRIB(1),OGRIB,ETA,MAXL,MAXB,MLEVEL,MLEVELIST,1,(/METAPAR/))
  END IF

  CALL WRITELATLON(LUNIT,IGRIB(1),OGRIB,T,MAXL,MAXB,MLEVEL,MLEVELIST,1,(/130/))

  CALL WRITELATLON(LUNIT,IGRIB(1),OGRIB,PS,MAXL,MAXB,1,'1',1,(/134/))

  CALL GRIB_SET(IGRIB(1),"levelType","ml")
  CALL GRIB_SET(IGRIB(1),"typeOfLevel","hybrid")
  CALL WRITELATLON(LUNIT,IGRIB(1),OGRIB,QA,MAXL,MAXB,MLEVEL,MLEVELIST,1,(/133/))

  IF (MOMEGA .EQ. 1) THEN
    CALL GRIB_OPEN_FILE(LUNIT2,'fort.25','w')
    CALL WRITELATLON  &
      (LUNIT2,IGRIB(1),OGRIB,OMR,MAXL,MAXB,MLEVEL,MLEVELIST,1,(/135/))

    IF (MOMEGADIFF .EQ. 1) THEN
      CALL WRITELATLON(LUNIT2,IGRIB(1),OGRIB,DPSDT,MAXL,MAXB,1,'1',1,(/158/))
      OM=OM-OMR
      CALL WRITELATLON &
        (LUNIT2,IGRIB(1),OGRIB,OM,MAXL,MAXB,MLEVEL,MLEVELIST,1,(/001/))
      CALL GRIB_CLOSE_FILE(LUNIT2)
    END IF
  END IF

  IF (META .EQ. 1 .AND. METADIFF .EQ. 1) THEN
    CALL GRIB_OPEN_FILE(LUNIT2,'fort.26','w')
    CALL WRITELATLON &
      (LUNIT2,IGRIB(1),OGRIB,ETAR,MAXL,MAXB,MLEVEL,MLEVELIST,1,(/135/))
!        IF (MOMEGADIFF .EQ. 1) THEN
    CALL WRITELATLON(LUNIT2,IGRIB(1),OGRIB,DPSDT,MAXL,MAXB,1,'1',1,(/158/))
    OM=ETA-ETAR
    CALL WRITELATLON &
      (LUNIT2,IGRIB(1),OGRIB,OM,MAXL,MAXB,MLEVEL,MLEVELIST,1,(/001/))
    CALL GRIB_CLOSE_FILE(LUNIT2)
!        END IF
  END IF

  CALL GRIB_CLOSE_FILE(LUNIT)

2000 STOP 'SUCCESSFULLY FINISHED calc_etadot: CONGRATULATIONS'
3000 STOP 'ROUTINE calc_etadot: ERROR'
9999 stop 'ROUTINE calc_etadot: ERROR'

END

!------------------------------------------------------------------
INTEGER FUNCTION IA (FIELD1,NI,NJ,NK,G)

!------------------------------------------------------------------
!! Calculate something that is roughly log10( maxval(field1)/g ) [PS]
!------------------------------------------------------------------

  IMPLICIT NONE

  INTEGER :: I,J,K
  INTEGER, INTENT(IN) :: NI,NJ,NK
  REAL, INTENT(IN) :: FIELD1(NI,NJ,NK)
  REAL, INTENT(IN) :: G
  REAL  :: RMIN,RMAX,XMAX,A,A1,A2

  RMAX=FIELD1(1,1,1)
  RMIN=FIELD1(1,1,1)

  DO 100 K=1,NK
    DO 100 J=1,NJ
      DO 100 I=1,NI
        IF (FIELD1(I,J,K) .GT. RMAX) RMAX=FIELD1(I,J,K)
        IF (FIELD1(I,J,K) .LT. RMIN) RMIN=FIELD1(I,J,K)
100 CONTINUE

  IF (ABS(RMIN) .GT. RMAX .OR. ABS(RMIN) .EQ. RMAX) THEN
    XMAX=ABS(RMIN)
  ELSE
    XMAX=RMAX
  END IF

  IF (XMAX .EQ. 0) THEN
    IA = 0
    RETURN
  END IF

  A1=LOG10( (G/10.d0)/XMAX )
  A2=LOG10( G/XMAX )
  IF (A1 .gt. A2) THEN
    A=A2
  ELSE
    A=A1
  END IF

  IF (A .GT. 0) IA=INT(A)
  IF (A .LT. 0) IA=INT(A-1.0)

  RETURN

END

SUBROUTINE STATIS (NI,NJ,NK,PHI,RMS,MW,SIG)

!------------------------------------------------------------------
!! calculate mean, rms, stdev
!------------------------------------------------------------------

  IMPLICIT REAL (A-H,O-Z)

  REAL PHI(NI,NJ,NK),SIG,MW,RMS,P

  N=NI*NJ*NK

  RMS=0.
  MW=0.
! 10.86 sinstead of 11.04 sec
      DO 10 K=1,NK
    DO 10 J=1,NJ
  DO 10 I=1,NI
        P=PHI(I,J,K)
        RMS=RMS+P*P
        MW=MW+P
10 CONTINUE

  RMS=SQRT(RMS/N)
  MW=MW/N

  IF (RMS*RMS-MW*MW .LT. 0.) THEN
    SIG=0.0
  ELSE
    SIG=SQRT(RMS*RMS-MW*MW)
  END IF

  RETURN

END


************************************************************************
*
*     Subroutine LADLOAD2                   Called by: LADLOAD
*
*     estimate loads using the least absolute deviation (LAD) method;
*     bias correction is done by the method of Duan (1983).
*
************************************************************************
      SUBROUTINE LADLOAD2(NPAR,NUMOBSE,XLEST,BICOR,LOAD,PARAM,PLOAD,
     &                    NOBSE)
*
*     subroutine arguments
*
      INTEGER*4 NPAR,NUMOBSE,NOBSE
      DOUBLE PRECISION BICOR,LOAD
      DOUBLE PRECISION PARAM(*),PLOAD(*)
      DOUBLE PRECISION XLEST(NOBSE,*)
*
*     local vars
*
      INTEGER*4 I,K
      DOUBLE PRECISION LTE
*
*     estimate loads
*
      LOAD = 0.D0
      DO 20 I=1,NUMOBSE
         LTE = 0.D0
         DO 10 K=1,NPAR
            LTE = LTE + PARAM(K)*XLEST(I,K)
 10      CONTINUE
         PLOAD(I) = DEXP(LTE)*BICOR
         LOAD = LOAD+PLOAD(I)
 20   CONTINUE
      LOAD = LOAD/DBLE(NUMOBSE)

      RETURN
      END