!*************************************************************************
!* Dual Number Automatic Differentiation (DNAD) of Fortran Codes
!*----------------------------------------------------------------
!* COPYRIGHT (c) Wenbin Yu, All rights reserved, you are free to copy,
!* modify or translate this code to other languages such as c/c++. If
!* you find a bug please let me know through wenbinyu.heaven@gmail.com. If
!* you added new functions and want to share with others, please let me know too.
!* You are welcome to share your successful stories with us through
!* http://groups.google.com/group/hifi-comp.
!******************************************************************************
!* Simple Instruction:
!*---------------------
!* This is the procedure file: define the procedures (functions/subroutines)
!* needed for overloading intrinsic functions and operators. If a function
!* or operation is not defined (unlikely), you need to create a corresponding
!* interface in header file (DNADHeaders.f90) and a corresponding
!* function/subroutine in DNAD.f90.
!* If you are uncertain whether I did things in the correct way or not, you can
!* create a new module with the same definition of the type DUAL_NUM, but delete
!* all the interfaces and procedures first. Then compile it with your analysis
!* codes after you changed all the definitions of real numbers to be dual numbers.
!* The compiler will complain about some operations and functions are not defined.
!* Then you do it one by one by looking at my original module, copying the needed
!* interfaces/procedures into your module. This way, you can also get a leaner
!* model and use those only needed for your analysis code.
!*********************************************************************************
!* Acknowledgements
!*-------------------
!* The development of DNAD is supported, in part, by the Chief Scientist
!* Innovative Research Fund at AFRL/RB WPAFB, and by Department of Army
!* SBIR (Topic A08-022) through Advanced Dynamics Inc. The views and
!* conclusions contained herein are those of the authors and should not be
!* interpreted as necessarily representing the official policies or endorsement,
!* either expressed or implied, of the funding agency.
!**********************************************************************************
!* Citation
!*-------------------
!* Your citation of the following two papers are appreciated:
!* Yu, W. and Blair, M.: "DNAD, a Simple Tool for Automatic Differentiation of
!* Fortran Codes Using Dual Numbers," Computer Physics Communications, vol. 184,
!* 2013, pp. 1446-1452.
!*
!* Spall, R. and Yu, W.: "Imbedded Dual-Number Automatic Differentiation for CFD
!* Sensitivity Analysis," Journal of Fluids Engineering, vol. 135, 2013, 014501.
!**********************************************************************************
!* Basic idea
!*-------------------------------------
!* Carry out Automatic Differentiation using the arithmetic of dual numbers.
!* It is supposed to be more efficient and more accurate than complex-step
!* approximation. What one needs to do is to create a new data type according
!* to the rules of dual numbers, which is equivalent to create a quasi-complex
!* numbers. And overload all the intrinsic operators and functions for
!* such a type.
!* For simplicity and memoric convenience, we call a dual number as a dual (D),
!* a double precision real number as a real (R) and a single precision real
!* number as a single (S), and an integer number as an integer (I). We also
!* use M to denote a 2D array, V to denote a vector, M3 to denote a 3D arry.
!* By defining functions/subroutines to the ELEMENTAL, the inputs/outputs
!* can be automatically overloaded for vectors and matrices of the same shape
!**********************************************************************************
!* To AD a Fortran code use DNAD
!* Step 0: compile DNAD.f90 to be DNAD.o
!* Step 1: Replace all the definitions of real numbers with dual numbers
!*		For example
!*  			replace REAL(8) :: x
!*   			with  TYPE(DUAL_NUM) :: x
!*  			replace REAL(8), PARAMETER:: ONE=1.0D0
!*   			with TYPE(DUAL_NUM),PARAMETER::ONE=DUAL_NUM(1.0D0,0.D0)
!* Step 2: Insert USE Dual_Num_Auto_Diff right after Module/Function/Subroutine/Program
!*         statements used TYPE(DUAL_NUM)
!* Step 3: Change IO commands correspondingly if the code does not use free formatting
!*         read and write (can be automated by written some general-purpose utility subroutines)
!* Step 4: Recompile the source along with DNAD.o
!* The whole process can be automated, and even manually it only takes just a few minutes
!* for most real analysis codes, although step 3 is code dependent.
!*****************************************************************************************
!* Example
!* The analysis version of the code computing the area of a circle with input radius
!* PROGRAM CircleArea
!*	REAL(8),PARAMETER:: PI=3.141592653589793D0
!*	REAL(8):: radius, area
!*	READ(*,*) radius
!*	Area=PI*radius**2
!*	WRITE(*,*) "AREA=", Area
!* END PROGRAM CircleArea
!*Input: 5
!*Output: AREA=78.5398163397448
!*---------------------------------------------------------------------------------------
!* The AD version of the code computing the area of a circle and sensitivity with input radius
!*PROGRAM CircleArea
!*	USE DNAD
!*	TYPE (DUAL_NUM),PARAMETER:: PI=DUAL_NUM(3.141592653589793D0,0.D0)
!*	TYPE (DUAL_NUM):: radius,area
!*	READ(*,*) radius
!*	Area=PI*radius**2
!*	WRITE(*,*) "AREA=",Area
!*END PROGRAM CircleArea
!* Input 5, 1
!* Output: AREA=78.5398163397448, 31.4159265358979
!*--------------------------------------------------------
!*****************************************************************************************
!* Possible Mistakes to Avoid
!* 11/23/2011: DNAD should always compute the same functional value. However, in very rare situations,
!* sensitivities are not computed as expected. One such case has been identified with
!* dgemv in the blas package. The main reason is that dgemv skip some calculations due to
!* the fact of multiplying zero. However, sometimes, the functional value is zero, but
!* the sensitivity is not zero. In DNAD the comparision is done only between functional values
!* hence is sensitivity calculation is also avoid altogether. For example, the following piece of code
!*                IF( X( JX ).NE.ZERO )THEN
!*                  TEMP = ALPHA*X( JX )
!*                  DO 50, I = 1, M
!*                     Y( I ) = Y( I ) + TEMP*A( I, J )
!*   50             CONTINUE
!*              END IF
!* the solution is to either to rewrite dgemv or assign epsilon(0.0d0) to x(jx) if the functional value
!* while the corresponding derivatives are not zero.
!************************************************************************************************************

MODULE Dual_Num_Auto_Diff

IMPLICIT NONE

INTEGER(2), PUBLIC,PARAMETER:: NDV_AD=6 ! number of design variables

PRIVATE

INTEGER, PARAMETER:: SNG_AD=SELECTED_REAL_KIND(6)  ! single precision
INTEGER, PARAMETER:: DBL_AD=SELECTED_REAL_KIND(15) ! double precision
REAL(DBL_AD)      ::negative_one=-1.0d0

TYPE,PUBLIC:: DUAL_NUM
 	                              ! make this private will create difficulty to use the original write/read commands,
                                  ! hence x_ad_ and xp_ad_ are variables which can be accessed using D%x_ad_ and
    					          ! D%xp_ad_ in other units using this module in which D is defined as TYPE DUAL_NUM.
	REAL(DBL_AD)::x_ad_           ! functional value
	REAL(DBL_AD)::xp_ad_(NDV_AD)  ! derivative

END TYPE DUAL_NUM

INCLUDE 'DNADHeaders.h'

CONTAINS

!*********Begin: functions/subroutines for overloading operators

!******* Begin: (=)
!---------------------
	!** dual=integer: 	! <u,up>=<a,0.D0>
	ELEMENTAL SUBROUTINE ASSIGN_DI(u,n)
         TYPE (DUAL_NUM), INTENT(OUT)::u
         INTEGER, INTENT(IN)::n

 !         u=DUAL_NUM(n,0.d0)    ! It is shown that this approach is much slower than the new approach
         u%x_ad_= REAL(n,DBL_AD) ! REAL(n,DBL_AD) is faster than let the code do the conversion.
         u%xp_ad_=0.0D0

	END SUBROUTINE ASSIGN_DI

	!** dual=real: <u,up>=<a,0.D0>
	ELEMENTAL SUBROUTINE ASSIGN_DR(u,n)
         TYPE (DUAL_NUM), INTENT(OUT)::u
         REAL(DBL_AD), INTENT(IN)::n

          u%x_ad_=n
          u%xp_ad_=0.0D0

	END SUBROUTINE ASSIGN_DR

	!** dual=single
	! <u,up>=<n,0.D0>
	ELEMENTAL SUBROUTINE ASSIGN_DS(u,n)
         TYPE (DUAL_NUM), INTENT(OUT)::u
         REAL(SNG_AD), INTENT(IN)::n

	     u%x_ad_=REAL(n,DBL_AD)
         u%xp_ad_=0.0D0

	END SUBROUTINE ASSIGN_DS

	!** integer=dual
	! n=u%x_ad_
	ELEMENTAL SUBROUTINE ASSIGN_ID(n,u)
         TYPE (DUAL_NUM), INTENT(IN)::u
         INTEGER, INTENT(OUT)::n

         n=u%x_ad_

	END SUBROUTINE ASSIGN_ID

!******* End: (=)
!---------------------

!******* Begin: (+)
!---------------------

	!dual=+<v,vp>
	!-----------------------------------------
    ELEMENTAL FUNCTION ADD_D(u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 TYPE (DUAL_NUM)::res

         res=u ! It is faster than assigning component wise

	END FUNCTION ADD_D

	! <u,up>+<v,vp>=<u+v,up+vp>
	!-----------------------------------------
    ELEMENTAL FUNCTION ADD_DD(u,v) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u,v
		 TYPE (DUAL_NUM)::res

         res%x_ad_  = u%x_ad_+v%x_ad_
         res%xp_ad_ = u%xp_ad_+v%xp_ad_

	END FUNCTION ADD_DD

    ! dual+integer
	! <v,vp>+<n,0>=<n+v,vp>
	!-----------------------------------------
	ELEMENTAL FUNCTION ADD_DI(v,n) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::v
		 INTEGER,INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

         res%x_ad_  = REAL(n,DBL_AD)+v%x_ad_
         res%xp_ad_ = v%xp_ad_

	END FUNCTION ADD_DI

	! dual +real
	! <v,vp>+<n,0>=<n+v,vp>
	!-----------------------------------------
	ELEMENTAL FUNCTION ADD_DR(v,n) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::v
		 REAL(DBL_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

         res%x_ad_  = n+v%x_ad_
         res%xp_ad_ = v%xp_ad_

	END FUNCTION ADD_DR

	!-----------------------------------------
    ! dual+single
	! <v,vp>+<n,0>=<n+v,vp>
	!-----------------------------------------
	ELEMENTAL FUNCTION ADD_DS(v,n) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::v
		 REAL(SNG_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

         res%x_ad_  = REAL(n,DBL_AD)+v%x_ad_
         res%xp_ad_ = v%xp_ad_

	END FUNCTION ADD_DS
	!-----------------------------------------

    !-----------------------------------------
	!an integer+ dual number
    ! <n,0>+<v,vp>=<n+v,vp>
	!-----------------------------------------
    ELEMENTAL FUNCTION ADD_ID(n,v) RESULT(res)
         INTEGER,INTENT(IN)::n
		 TYPE (DUAL_NUM), INTENT(IN)::v
		 TYPE (DUAL_NUM)::res

         res%x_ad_  = REAL(n,DBL_AD)+v%x_ad_
         res%xp_ad_ = v%xp_ad_

	END FUNCTION ADD_ID

    !-----------------------------------------
	! real + dual
	! <n,0>+<v,vp>=<n+v,vp>
	!-----------------------------------------
	ELEMENTAL FUNCTION ADD_RD(n,v) RESULT(res)
         REAL(DBL_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM), INTENT(IN)::v
		 TYPE (DUAL_NUM)::res

         res%x_ad_  = n+v%x_ad_
         res%xp_ad_ = v%xp_ad_

	END FUNCTION ADD_RD

 	! single + dual
	! <n,0>+<v,vp>=<n+v,vp>
	!-----------------------------------------
	ELEMENTAL FUNCTION ADD_SD(n,v) RESULT(res)
         REAL(SNG_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM), INTENT(IN)::v
		 TYPE (DUAL_NUM)::res

         res%x_ad_  = REAL(n,DBL_AD)+v%x_ad_
         res%xp_ad_ = v%xp_ad_

	END FUNCTION ADD_SD

!******* End: (+)
!---------------------

!******* Begin: (-)
!---------------------

	!-----------------------------------------
	! negate a dual number
	!-------------------------------------------------
    ELEMENTAL FUNCTION MINUS_D(u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 TYPE (DUAL_NUM)::res

	     res%x_ad_ = -u%x_ad_
         res%xp_ad_= -u%xp_ad_

	END FUNCTION MINUS_D

	!-----------------------------------------
	! <u,up>-<v,vp>=<u-v,up-vp>
	!-------------------------------------------------
    ELEMENTAL FUNCTION MINUS_DD(u,v) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u,v
         TYPE (DUAL_NUM)::res

	     res%x_ad_ = u%x_ad_-v%x_ad_
         res%xp_ad_= u%xp_ad_-v%xp_ad_

	END FUNCTION MINUS_DD

	!-----------------------------------------
	! dual number - integer
	! <u,up>-<n,0>=<u-n,up>
	!-------------------------------------------------
	ELEMENTAL FUNCTION MINUS_DI(u,n) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 INTEGER,INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

	     res%x_ad_ = u%x_ad_-REAL(n,DBL_AD)
         res%xp_ad_= u%xp_ad_

	END FUNCTION MINUS_DI

	!-----------------------------------------
	! dual number - real
	! <u,up>-<n,0>=<u-n,up>
	!-------------------------------------------------
	ELEMENTAL FUNCTION MINUS_DR(u,n) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(DBL_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

	     res%x_ad_ = u%x_ad_-n
         res%xp_ad_= u%xp_ad_

	END FUNCTION MINUS_DR

    !-----------------------------------------
	! dual number - single
	! <u,up>-<n,0>=<u-n,up>
	!-------------------------------------------------
	ELEMENTAL FUNCTION MINUS_DS(u,n) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(SNG_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

	     res%x_ad_ = u%x_ad_-REAL(n,DBL_AD)
         res%xp_ad_= u%xp_ad_

	END FUNCTION MINUS_DS

	!-----------------------------------------
	! integer-dual number
	!-------------------------------------------------
	ELEMENTAL FUNCTION MINUS_ID(n,u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 INTEGER,INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

	     res%x_ad_ = REAL(n,DBL_AD)-u%x_ad_
         res%xp_ad_= -u%xp_ad_

	END FUNCTION MINUS_ID

	!-----------------------------------------
	! real-dual number
	!-------------------------------------------------
	ELEMENTAL FUNCTION MINUS_RD(n,u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(DBL_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

	     res%x_ad_ = n-u%x_ad_
         res%xp_ad_= -u%xp_ad_

	END FUNCTION MINUS_RD

    !-----------------------------------------
	! single-dual number
	! <n,0>-<u,up>=<n-u,-up>
	!-------------------------------------------------
	ELEMENTAL FUNCTION MINUS_SD(n,u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(SNG_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

	     res%x_ad_ =REAL(n,DBL_AD) - u%x_ad_
         res%xp_ad_=- u%xp_ad_

	END FUNCTION MINUS_SD

!******* END: (-)
!---------------------

!******* BEGIN: (*)
!---------------------

	!-----------------------------------------
	! <u,up>*<v,vp>=<u*v,up*v+u*vp>
	!----------------------------------------
	ELEMENTAL FUNCTION MULT_DD(u,v) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u,v
		 TYPE (DUAL_NUM)::res

		 res%x_ad_ = u%x_ad_*v%x_ad_
         res%xp_ad_= u%xp_ad_*v%x_ad_ + u%x_ad_*v%xp_ad_

	END FUNCTION MULT_DD

	!-----------------------------------------
	!  dual*integer
	! <u,up>*<n,0>=<u*n,up*n>
	!----------------------------------------
	ELEMENTAL FUNCTION MULT_DI(u,n) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
         INTEGER,INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

         res%x_ad_ = REAL(n,DBL_AD)*u%x_ad_
         res%xp_ad_= REAL(n,DBL_AD)*u%xp_ad_

	END FUNCTION MULT_DI

    !-----------------------------------------
	!  dual*real
	! <u,up>*<n,0>=<u*n,up*n>
	!----------------------------------------
	ELEMENTAL FUNCTION MULT_DR(u,n) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
         REAL(DBL_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

         res%x_ad_ = n*u%x_ad_
         res%xp_ad_= n*u%xp_ad_

	END FUNCTION MULT_DR

	!-----------------------------------------
	!  dual*single
	! <u,up>*<n,0>=<u*n,up*n>
	!----------------------------------------
	ELEMENTAL FUNCTION MULT_DS(u,n) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
         REAL(SNG_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM)::res

         res%x_ad_ = REAL(n,DBL_AD)*u%x_ad_
         res%xp_ad_= REAL(n,DBL_AD)*u%xp_ad_

	END FUNCTION MULT_DS

	!-----------------------------------------
	! integer*dual
	! <n,0>*<v,vp>=<n*v,n*vp>
	!----------------------------------------
	ELEMENTAL FUNCTION MULT_ID(n,v) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::v
         INTEGER,INTENT(IN)::n
		  TYPE (DUAL_NUM)::res

         res%x_ad_ = REAL(n,DBL_AD)*v%x_ad_
         res%xp_ad_= REAL(n,DBL_AD)*v%xp_ad_

	END FUNCTION MULT_ID

	!-----------------------------------------
	! real* dual
	! <n,0>*<u,up>=<u*n,up*n>
	!----------------------------------------
    ELEMENTAL FUNCTION MULT_RD(n,u) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
		 TYPE (DUAL_NUM)::res
         REAL(DBL_AD),INTENT(IN)::n

	   	 res%x_ad_ = n*u%x_ad_
		 res%xp_ad_= n*u%xp_ad_

	END FUNCTION MULT_RD

	!-----------------------------------------
	! MULTIPLY a dual number with REAL number
	! <n,0>*<u,up>=<u*n,up*n>
	!----------------------------------------
    ELEMENTAL FUNCTION MULT_SD(n,u) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
		 TYPE (DUAL_NUM)::res
         REAL(SNG_AD),INTENT(IN)::n

	   	 res%x_ad_ = REAL(n,DBL_AD)*u%x_ad_
		 res%xp_ad_= REAL(n,DBL_AD)*u%xp_ad_

	END FUNCTION MULT_SD

!******* END: (*)
!---------------------

!******* BEGIN: (/)
!---------------------

    !-----------------------------------------
	! <u,up>/<v,vp>=<u/v,(up-u vp/v)/v>
	!----------------------------------------
    ELEMENTAL FUNCTION DIV_DD(u,v) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u,v
		 REAL(DBL_AD)::tmp
		 TYPE (DUAL_NUM)::res
         INTEGER:: i

		 tmp=1.D0/v%x_ad_
         res%x_ad_ = u%x_ad_*tmp
		 res%xp_ad_ =(u%xp_ad_- res%x_ad_*v%xp_ad_)*tmp

	END FUNCTION DIV_DD

    !-----------------------------------------
	! <u,up>/<n,0>=<u/n,up/n>
	!----------------------------------------
	ELEMENTAL FUNCTION DIV_DI(u,n) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
		 INTEGER,INTENT(IN)::n
         REAL(DBL_AD)::tmp
    	 TYPE (DUAL_NUM)::res

		 tmp=1.D0/REAL(n,DBL_AD)
         res%x_ad_ = u%x_ad_*tmp
		 res%xp_ad_ =u%xp_ad_*tmp

	END FUNCTION DIV_DI

    !-----------------------------------------
	! DIVIDE dual number with respect to real numbers
	! <u,up>/<n,0>=<u/n,up/v>
	!----------------------------------------
	ELEMENTAL FUNCTION DIV_DR(u,n) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(DBL_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM):: res
         REAL(DBL_AD)::tmp

		 tmp=1.0D0/n
         res%x_ad_ = u%x_ad_*tmp
		 res%xp_ad_ =u%xp_ad_*tmp

	END FUNCTION DIV_DR

    !-----------------------------------------
	! DIVIDE dual number with respect to single
	! <u,up>/<n,0>=<u/n,up/v>
	!----------------------------------------
	ELEMENTAL FUNCTION DIV_DS(u,n) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(SNG_AD),INTENT(IN)::n
		 TYPE (DUAL_NUM):: res
         REAL(DBL_AD)::tmp

		 tmp=1.0D0/REAL(n,DBL_AD)
         res%x_ad_ = u%x_ad_*tmp
		 res%xp_ad_ =u%xp_ad_*tmp

	END FUNCTION DIV_DS

	!-----------------------------------------
	! integer/<v,vp>
	! <n,0>/<v,vp>=<n/v,-n vp/v/v>=n*<1,-vp/v>/v
	!----------------------------------------
	ELEMENTAL FUNCTION DIV_ID(n,v) RESULT(res)
	     INTEGER,INTENT(IN)::n
	     TYPE (DUAL_NUM), INTENT(IN)::v
		 REAL(DBL_AD)::tmp,tmp2
		 TYPE (DUAL_NUM)::res

		 tmp=1.D0/v%x_ad_
         res%x_ad_=REAL(n,DBL_AD)*tmp
		 res%xp_ad_=-res%x_ad_*tmp*v%xp_ad_

	END FUNCTION DIV_ID

    !-----------------------------------------
	! real/<v,vp>
	! <n,0>/<v,vp>=<n/v,-n vp/v/v>=n*<1,-vp/v>/v
	!----------------------------------------
	ELEMENTAL FUNCTION DIV_RD(n,v) RESULT(res)
	     REAL(DBL_AD),INTENT(IN)::n
	     TYPE (DUAL_NUM), INTENT(IN)::v
		 REAL(DBL_AD)::tmp,tmp2
		 TYPE (DUAL_NUM)::res

		 tmp=1.D0/v%x_ad_
         res%x_ad_=n*tmp
		 res%xp_ad_=-res%x_ad_*tmp*v%xp_ad_

	END FUNCTION DIV_RD

    !-----------------------------------------
	! single/<v,vp>
	! <n,0>/<v,vp>=<n/v,-n vp/v/v>=n*<1,-vp/v>/v
	!----------------------------------------
	ELEMENTAL FUNCTION DIV_SD(n,v) RESULT(res)
	     REAL(SNG_AD),INTENT(IN)::n
	     TYPE (DUAL_NUM), INTENT(IN)::v
		 REAL(DBL_AD)::tmp,tmp2
		 TYPE (DUAL_NUM)::res

		 tmp=1.D0/v%x_ad_
         res%x_ad_=REAL(n,DBL_AD)*tmp
		 res%xp_ad_=-res%x_ad_*tmp*v%xp_ad_

	END FUNCTION DIV_SD

!******* END: (/)
!---------------------

!******* BEGIN: (**)
!---------------------

	!-----------------------------------------
	! POWER dual numbers
	! <u,up>^k=<u^k,k u^{k-1} up>
	!----------------------------------------
    ELEMENTAL FUNCTION POW_I(u,k) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 INTEGER,INTENT(IN)::k
		 REAL(DBL_AD)::tmp
		 TYPE (DUAL_NUM)::res

		 tmp=u%x_ad_**(k-1)
         res%x_ad_ = u%x_ad_*tmp
         res%xp_ad_=REAL(k,DBL_AD)*tmp*u%xp_ad_

	END FUNCTION POW_I

    !-----------------------------------------
	! POWER dual numbers
	! <u,up>^k=<u^k,k u^{k-1} up>
	!----------------------------------------
    ELEMENTAL FUNCTION POW_R(u,k) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(DBL_AD),INTENT(IN)::k
		 REAL(DBL_AD)::tmp
		 TYPE (DUAL_NUM)::res

		 tmp=u%x_ad_**(k-1)
         res%x_ad_ = u%x_ad_*tmp
         res%xp_ad_=k*tmp*u%xp_ad_

	END FUNCTION POW_R

    !-----------------------------------------
	! POWER dual numbers
	! <u,up>^k=<u^k,k u^{k-1} up>
	!----------------------------------------
    ELEMENTAL FUNCTION POW_S(u,k) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(SNG_AD),INTENT(IN)::k
		 REAL(DBL_AD)::tmp
		 TYPE (DUAL_NUM)::res

		 tmp=u%x_ad_**(k-1)
         res%x_ad_ = u%x_ad_*tmp
         res%xp_ad_=k*tmp*u%xp_ad_

	END FUNCTION POW_S

	!-----------------------------------------
	! POWER dual numbers to a dual power
	! <u,up>^(v,vp)=<u^v,u^v (v/u*up+Log(u)*vp>
	!----------------------------------------
    ELEMENTAL FUNCTION POW_D(u,v) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 TYPE (DUAL_NUM), INTENT(IN)::v
		 REAL(DBL_AD)::uf,vf
		 TYPE (DUAL_NUM)::res
		 uf=u%x_ad_
		 vf=v%x_ad_

		 res%x_ad_ =uf**vf
		 res%xp_ad_=res%x_ad_*(vf/uf*u%xp_ad_+LOG(uf)*v%xp_ad_)

	END FUNCTION POW_D
!******* END: (**)
!---------------------

!******* BEGIN: (==)
!---------------------
    !-----------------------------------------
	! compare two dual numbers, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION EQ_DD(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs,rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ == rhs%x_ad_)

	END FUNCTION EQ_DD

   ! compare a dual with an integer
   !-----------------------------------------
    ELEMENTAL FUNCTION EQ_DI(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     INTEGER,INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ == REAL(rhs,DBL_AD))

	END FUNCTION EQ_DI

    !-----------------------------------------
	! compare a dual number with a real number, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION EQ_DR(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(DBL_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ == rhs)

	END FUNCTION EQ_DR

   ! compare a dual with a single
   !-----------------------------------------
    ELEMENTAL FUNCTION EQ_DS(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(SNG_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ == REAL(rhs,DBL_AD))

	END FUNCTION EQ_DS

    !-----------------------------------------
	! compare an integer with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION EQ_ID(lhs, rhs) RESULT(res)
		 INTEGER,INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(lhs,DBL_AD)==rhs%x_ad_)

	END FUNCTION EQ_ID

    !-----------------------------------------
	! compare a real with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION EQ_RD(lhs, rhs) RESULT(res)
		 REAL(DBL_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (lhs==rhs%x_ad_)

    END FUNCTION EQ_RD

    !-----------------------------------------
	! compare a single with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION EQ_SD(lhs, rhs) RESULT(res)
		 REAL(SNG_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(lhs,DBL_AD)==rhs%x_ad_)

    END FUNCTION EQ_SD

!******* END: (==)
!---------------------

!******* BEGIN: (<=)
!---------------------
    !-----------------------------------------
	! compare two dual numbers, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION LE_DD(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs,rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ <= rhs%x_ad_)

	END FUNCTION LE_DD

   ! compare a dual with an integer
   !-----------------------------------------
	ELEMENTAL FUNCTION LE_DI(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     INTEGER,INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ <= REAL(rhs,DBL_AD))

	END FUNCTION LE_DI

    !-----------------------------------------
	! compare a dual number with a real number, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION LE_DR(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(DBL_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ <= rhs)

	END FUNCTION LE_DR

  ! compare a dual with a single
   !----------------------------------------
	ELEMENTAL FUNCTION LE_DS(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(SNG_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ <= REAL(rhs,DBL_AD))

	END FUNCTION LE_DS

    !-----------------------------------------
	! compare a dual number with an integer
	!----------------------------------------
    ELEMENTAL FUNCTION LE_ID(n, rhs) RESULT(res)
		 INTEGER,INTENT(IN)::n
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(n,DBL_AD)<=rhs%x_ad_)

	END FUNCTION LE_ID

!-----------------------------------------
	! compare a real with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION LE_RD(lhs, rhs) RESULT(res)
		 REAL(DBL_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (lhs<=rhs%x_ad_)

    END FUNCTION LE_RD

    !-----------------------------------------
	! compare a single with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION LE_SD(lhs, rhs) RESULT(res)
		 REAL(SNG_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(lhs,DBL_AD)<=rhs%x_ad_)

    END FUNCTION LE_SD

!******* END: (<=)
!---------------------

!******* BEGIN: (<)
!---------------------
    !-----------------------------------------
	! compare two dual numbers, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION LT_DD(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs,rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ < rhs%x_ad_)

	END FUNCTION LT_DD

   ! compare a dual with an integer
   !-----------------------------------------
    ELEMENTAL FUNCTION LT_DI(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     INTEGER,INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ < REAL(rhs,DBL_AD))

	END FUNCTION LT_DI

    !-----------------------------------------
	! compare a dual number with a real number, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION LT_DR(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(DBL_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ < rhs)

	END FUNCTION LT_DR

   ! compare a dual with a single
   !----------------------------------------
    ELEMENTAL FUNCTION LT_DS(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(SNG_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ < REAL(rhs,DBL_AD))

	END FUNCTION LT_DS

 !-----------------------------------------
	! compare a dual number with an integer
	!----------------------------------------
    ELEMENTAL FUNCTION LT_ID(n, rhs) RESULT(res)
		 INTEGER,INTENT(IN)::n
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(n,DBL_AD)<rhs%x_ad_)

	END FUNCTION LT_ID

    !-----------------------------------------
	! compare a real with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION LT_RD(lhs, rhs) RESULT(res)
		 REAL(DBL_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (lhs < rhs%x_ad_)

    END FUNCTION LT_RD

    !-----------------------------------------
	! compare a single with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION LT_SD(lhs, rhs) RESULT(res)
		 REAL(SNG_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(lhs,DBL_AD) < rhs%x_ad_)

    END FUNCTION LT_SD

!******* END: (<)
!---------------------

!******* BEGIN: (>=)
!---------------------
    !-----------------------------------------
	! compare two dual numbers, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION GE_DD(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs,rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ >= rhs%x_ad_)

	END FUNCTION GE_DD

   ! compare a dual with an integer
   !-----------------------------------------
    ELEMENTAL FUNCTION GE_DI(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     INTEGER,INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ >= REAL(rhs,DBL_AD))

	END FUNCTION GE_DI

    !-----------------------------------------
	! compare a dual number with a real number, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION GE_DR(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(DBL_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ >= rhs)

	END FUNCTION GE_DR

   ! compare a dual with a single
   !----------------------------------------
    ELEMENTAL FUNCTION GE_DS(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(SNG_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ >=REAL(rhs,DBL_AD))

	END FUNCTION GE_DS
 !-----------------------------------------
	! compare a dual number with an integer
	!----------------------------------------
    ELEMENTAL FUNCTION GE_ID(n, rhs) RESULT(res)
		 INTEGER,INTENT(IN)::n
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(n,DBL_AD)>=rhs%x_ad_)

	END FUNCTION GE_ID

!-----------------------------------------
	! compare a real with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION GE_RD(lhs, rhs) RESULT(res)
		 REAL(DBL_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (lhs>=rhs%x_ad_)

    END FUNCTION GE_RD

    !-----------------------------------------
	! compare a single with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION GE_SD(lhs, rhs) RESULT(res)
		 REAL(SNG_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(lhs,DBL_AD)>=rhs%x_ad_)

    END FUNCTION GE_SD

!******* END: (>=)
!---------------------

!******* BEGIN: (>)
!---------------------
    !-----------------------------------------
	! compare two dual numbers, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION GT_DD(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs,rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ > rhs%x_ad_)

	END FUNCTION GT_DD

   ! compare a dual with an integer
   !-----------------------------------------
    ELEMENTAL FUNCTION GT_DI(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     INTEGER,INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ > REAL(rhs,DBL_AD))

	END FUNCTION GT_DI

    !-----------------------------------------
	! compare a dual number with a real number, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION GT_DR(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(DBL_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ > rhs)

	END FUNCTION GT_DR

   ! compare a dual with a single
   !----------------------------------------
    ELEMENTAL FUNCTION GT_DS(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(SNG_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ >REAL(rhs,DBL_AD))

	END FUNCTION GT_DS

  !-----------------------------------------
	! compare a dual number with an integer
	!----------------------------------------
    ELEMENTAL FUNCTION GT_ID(n, rhs) RESULT(res)
		 INTEGER,INTENT(IN)::n
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(n,DBL_AD)>rhs%x_ad_)

	END FUNCTION GT_ID

!-----------------------------------------
	! compare a real with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION GT_RD(lhs, rhs) RESULT(res)
		 REAL(DBL_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (lhs>rhs%x_ad_)

    END FUNCTION GT_RD

    !-----------------------------------------
	! compare a single with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION GT_SD(lhs, rhs) RESULT(res)
		 REAL(SNG_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(lhs,DBL_AD)>rhs%x_ad_)

    END FUNCTION GT_SD

!******* END: (>)
!---------------------

!******* BEGIN: (/=)
!---------------------
    !-----------------------------------------
	! compare two dual numbers, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION NE_DD(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs,rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ /= rhs%x_ad_)

	END FUNCTION NE_DD

   ! compare a dual with an integer
   !-----------------------------------------
    ELEMENTAL FUNCTION NE_DI(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     INTEGER,INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ /= REAL(rhs,DBL_AD))

	END FUNCTION NE_DI

    !-----------------------------------------
	! compare a dual number with a real number, simply compare
	! the functional value.
	!----------------------------------------
    ELEMENTAL FUNCTION NE_DR(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(DBL_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ /= rhs)

	END FUNCTION NE_DR

   ! compare a dual with a single
   !----------------------------------------
    ELEMENTAL FUNCTION NE_DS(lhs, rhs) RESULT(res)
		 TYPE (DUAL_NUM), INTENT(IN):: lhs
	     REAL(SNG_AD),INTENT(IN)::rhs
		 LOGICAL::res

	     res = (lhs%x_ad_ /=REAL(rhs,DBL_AD))

	END FUNCTION NE_DS

 !-----------------------------------------
	! compare a dual number with an integer
	!----------------------------------------
    ELEMENTAL FUNCTION NE_ID(n, rhs) RESULT(res)
		 INTEGER,INTENT(IN)::n
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(n,DBL_AD)/=rhs%x_ad_)

	END FUNCTION NE_ID

!-----------------------------------------
	! compare a real with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION NE_RD(lhs, rhs) RESULT(res)
		 REAL(DBL_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (lhs/=rhs%x_ad_)

    END FUNCTION NE_RD

    !-----------------------------------------
	! compare a single with a dual
	!----------------------------------------
    ELEMENTAL FUNCTION NE_SD(lhs, rhs) RESULT(res)
		 REAL(SNG_AD),INTENT(IN)::lhs
		 TYPE (DUAL_NUM), INTENT(IN):: rhs
		 LOGICAL::res

	     res = (REAL(lhs,DBL_AD)/=rhs%x_ad_)

    END FUNCTION NE_SD

!******* END: (/=)
!---------------------

	!---------------------------------------------------
	! ABS of dual numbers
	! ABS<u,up>=<ABS(u),up SIGN(u)>
	!----------------------------------------------------
	ELEMENTAL FUNCTION ABS_D(u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
         TYPE (DUAL_NUM)::res

         IF(u%x_ad_>0) THEN
		    res%x_ad_ = u%x_ad_
			res%xp_ad_= u%xp_ad_
         ELSE IF (u%x_ad_<0) THEN
		    res%x_ad_ = -u%x_ad_
	        res%xp_ad_= -u%xp_ad_
		 ELSE
            res%x_ad_ = 0.0D0
	        res%xp_ad_= 0.0 !Set_NaN() ! Indicating an undefined derivative, however, for some codes it will cause problem.
		 ENDIF

	END FUNCTION ABS_D

	!-----------------------------------------
	! ACOS of dual numbers
	! ACOS<u,up>=<ACOS(u),-up/sqrt(1-(u%x_ad_)**2)>
	!----------------------------------------
	ELEMENTAL FUNCTION ACOS_D(u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
         TYPE (DUAL_NUM)::res
         REAL(DBL_AD)::tmp

         res%x_ad_ = ACOS(u%x_ad_)
		 IF(u%x_ad_==1.0D0.OR.u%x_ad_==-1.0D0) THEN
			res%xp_ad_=Set_NaN() ! Indicating an undefined derivative
		 ELSE
			tmp= -1.0d0/SQRT(1.0D0-(u%x_ad_)**2)
			res%xp_ad_= u%xp_ad_*tmp
         ENDIF
	END FUNCTION ACOS_D

    !-----------------------------------------
	! ASIN of dual numbers
	! ASIN<u,up>=<ASIN(u),up 1/SQRT(1-u^2)>
	!----------------------------------------
	ELEMENTAL FUNCTION ASIN_D(u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
         TYPE (DUAL_NUM)::res
         REAL (DBL_AD):: tmp

         res%x_ad_ = ASIN(u%x_ad_)
		 IF(u%x_ad_==1.0D0.OR.u%x_ad_==-1.0D0) THEN
			res%xp_ad_=Set_NaN() ! Indicating an undefined derivative
		 ELSE
			tmp= 1.0d0/SQRT(1.0D0-(u%x_ad_)**2)
			res%xp_ad_= u%xp_ad_*tmp
         ENDIF
	END FUNCTION ASIN_D

  	!-----------------------------------------
	! COS of dual numbers
	! COS<u,up>=<COS(u),-up*SIN(u)>
	!----------------------------------------
	ELEMENTAL FUNCTION COS_D(u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
         TYPE (DUAL_NUM)::res
		 REAL(DBL_AD):: tmp

         res%x_ad_ = COS(u%x_ad_)
		 tmp=-SIN(u%x_ad_)
         res%xp_ad_= u%xp_ad_*tmp

	END FUNCTION COS_D

    !-----------------------------------------
	! DOT PRODUCT two dual number vectors
	! <u,up>.<v,vp>=<u.v,u.vp+up.v>
	!----------------------------------------
	FUNCTION DOT_PRODUCT_DD(u,v) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u(:),v(:)
		 TYPE (DUAL_NUM)::res
         INTEGER:: i

         res%x_ad_ = DOT_PRODUCT(u%x_ad_,v%x_ad_)

		 DO i=1,NDV_AD
			res%xp_ad_(i) =DOT_PRODUCT(u%x_ad_,v%xp_ad_(i))+DOT_PRODUCT(u%xp_ad_(i),v%x_ad_)
	     ENDDO
	END FUNCTION DOT_PRODUCT_DD

    !-----------------------------------------
	! EXPONENTIAL OF dual numbers
	! EXP<u,up>=<EXP(u),up EXP(u)>
	!----------------------------------------
	ELEMENTAL FUNCTION EXP_D(u) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(DBL_AD)::tmp
		 TYPE (DUAL_NUM)::res

		 tmp=EXP(u%x_ad_)
		 res%x_ad_ = tmp
		 res%xp_ad_ =u%xp_ad_*tmp

	END FUNCTION EXP_D

    !-----------------------------------------
	! EXPONENTIAL OF dual numbers
	! EXP<u,up>=<EXP(u),up EXP(u)>
	!----------------------------------------
	ELEMENTAL FUNCTION INT_D(u) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(DBL_AD)::tmp
		 INTEGER::res

		 tmp=u%x_ad_
		 res = INT(tmp)

	END FUNCTION INT_D

    !-----------------------------------------
	! LOG OF dual numbers,defined for u%x>0 only
	! the error control should be done in the original code
	! in other words, if u%x<=0, it is not possible to obtain LOG.
	! LOG<u,up>=<LOG(u),up/u>
	!----------------------------------------
	ELEMENTAL FUNCTION LOG_D(u) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
		 TYPE (DUAL_NUM)::res
		 REAL(DBL_AD)::tmp

		 res%x_ad_ = LOG(u%x_ad_)
		 tmp=1.0d0/u%x_ad_
		 res%xp_ad_ =u%xp_ad_*tmp

	END FUNCTION LOG_D

!-----------------------------------------
	! LOG OF dual numbers,defined for u%x>0 only
	! the error control should be done in the original code
	! in other words, if u%x<=0, it is not possible to obtain LOG.
	! LOG<u,up>=<LOG(u),up/u>
	!----------------------------------------
	ELEMENTAL FUNCTION LOG10_D(u) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u
		 TYPE (DUAL_NUM)::res
		 REAL(DBL_AD)::tmp

		 res%x_ad_ = LOG10(u%x_ad_)
		 tmp=1.0d0/u%x_ad_/LOG(10.0D0)
		 res%xp_ad_ =u%xp_ad_*tmp

	END FUNCTION LOG10_D

    !-----------------------------------------
	! MULTIPLY two dual number matrices
	!
	! <u,up>.<v,vp>=<u.v,up.v+u.vp>
	!----------------------------------------
	FUNCTION MATMUL_DD(u,v) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u(:,:),v(:,:)
         TYPE (DUAL_NUM)::res(SIZE(u,1),SIZE(v,2))
		 INTEGER:: i

         res%x_ad_ = MATMUL(u%x_ad_,v%x_ad_)
		 DO i=1,NDV_AD
			res%xp_ad_(i)= MATMUL(u%xp_ad_(i),v%x_ad_) + MATMUL(u%x_ad_,v%xp_ad_(i))
         ENDDO
	END FUNCTION MATMUL_DD

    !-----------------------------------------
	! MULTIPLY a dual number matrix with a dual number
	! vector
	!
	! <u,up>.<v,vp>=<u.v,up.v+u.vp>
	!----------------------------------------
	FUNCTION MATMUL_DV(u,v) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u(:,:),v(:)
         TYPE (DUAL_NUM)::res(SIZE(u,1))
         INTEGER:: i

         res%x_ad_ = MATMUL(u%x_ad_,v%x_ad_)
		 DO i=1,NDV_AD
			res%xp_ad_(i)= MATMUL(u%xp_ad_(i),v%x_ad_) + MATMUL(u%x_ad_,v%xp_ad_(i))
         ENDDO
	END FUNCTION MATMUL_DV

    !-----------------------------------------
	! MULTIPLY a dual vector with a  dual matrix
	!
	! <u,up>.<v,vp>=<u.v,up.v+u.vp>
	!----------------------------------------
	FUNCTION MATMUL_VD(u,v) RESULT(res)
	     TYPE (DUAL_NUM), INTENT(IN)::u(:),v(:,:)
         TYPE (DUAL_NUM)::res(SIZE(v,2))
         INTEGER::i

         res%x_ad_= MATMUL(u%x_ad_,v%x_ad_)
		 DO i=1,NDV_AD
			res%xp_ad_(i)= MATMUL(u%xp_ad_(i),v%x_ad_) + MATMUL(u%x_ad_,v%xp_ad_(i))
         ENDDO
	END FUNCTION MATMUL_VD

    !-----------------------------------------
	! Obtain the max of 2 to 5 dual numbers
	!----------------------------------------
	ELEMENTAL FUNCTION MAX_DD(val1, val2, val3, val4,val5) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN)::val1, val2
		TYPE (DUAL_NUM), INTENT(IN),OPTIONAL:: val3, val4,val5
		TYPE (DUAL_NUM)::res

		IF (val1%x_ad_ > val2%x_ad_) THEN
			res = val1
		ELSE
			res = val2
		ENDIF
        IF(PRESENT(val3))THEN
		   IF(res%x_ad_<val3%x_ad_) res=val3
        ENDIF
        IF(PRESENT(val4))THEN
		   IF(res%x_ad_<val4%x_ad_) res=val4
        ENDIF
		IF(PRESENT(val5))THEN
		   IF(res%x_ad_<val5%x_ad_) res=val5
        ENDIF

    END FUNCTION MAX_DD

    !-----------------------------------------
	! Obtain the max of a dual number and an integer
	!----------------------------------------
	ELEMENTAL FUNCTION MAX_DI(u, n) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN)::u
		INTEGER,INTENT(IN)::n
		TYPE (DUAL_NUM)::res

		IF (u%x_ad_ > n) THEN
			res = u
		ELSE
			res = n
		ENDIF

    END FUNCTION MAX_DI

    !-----------------------------------------
	! Obtain the max of a dual number and a real number
	!----------------------------------------
	ELEMENTAL FUNCTION MAX_DR(u, n) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN)::u
		REAL(DBL_AD),INTENT(IN)::n
		TYPE (DUAL_NUM)::res

		IF (u%x_ad_ > n) THEN
			res = u
		ELSE
			res = n
		ENDIF

    END FUNCTION MAX_DR

 !-----------------------------------------
	! Obtain the max of a dual number and a single
	!----------------------------------------
	ELEMENTAL FUNCTION MAX_DS(u, n) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN)::u
		REAL(SNG_AD),INTENT(IN)::n
		TYPE (DUAL_NUM)::res

		IF (u%x_ad_ > n) THEN
			res = u
		ELSE
			res = n
		ENDIF

    END FUNCTION MAX_DS

    !---------------------------------------------------
	! Obtain the max of a real and a dual
	! note the real argument is renamed as r to avoid
	! the ambiguity due to positional association using
	! keywords when functions/subroutines are called
	!---------------------------------------------------
	 ELEMENTAL FUNCTION MAX_RD(r,u) RESULT(res)
		REAL(DBL_AD),INTENT(IN)::r
		TYPE (DUAL_NUM), INTENT(IN)::u
		TYPE (DUAL_NUM)::res

		IF (u%x_ad_ > r) THEN
			res = u
		ELSE
			res = r
		ENDIF

    END FUNCTION MAX_RD

    !-----------------------------------------
	! Obtain the max value of vector u
	!----------------------------------------
	FUNCTION MAXVAL_D(u) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN)::u(:)
		INTEGER::iloc(1)
		TYPE (DUAL_NUM)::res

        iloc=MAXLOC(u%x_ad_)
		res=u(iloc(1))

    END FUNCTION MAXVAL_D

    !-----------------------------------------
	! Obtain the min of 2 to 4 dual numbers
	!----------------------------------------
    ELEMENTAL FUNCTION MIN_DD(val1, val2, val3, val4) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN)::val1, val2
		TYPE (DUAL_NUM), INTENT(IN),OPTIONAL:: val3, val4
		TYPE (DUAL_NUM)::res

		IF (val1%x_ad_ < val2%x_ad_) THEN
			res = val1
		ELSE
			res = val2
		ENDIF
        IF(PRESENT(val3))THEN
		   IF(res%x_ad_>val3%x_ad_) res=val3
        ENDIF
        IF(PRESENT(val4))THEN
		   IF(res%x_ad_>val4%x_ad_) res=val4
        ENDIF

    END FUNCTION MIN_DD

!-----------------------------------------
	! Obtain the min of a dual number and a single
	!----------------------------------------
	ELEMENTAL FUNCTION MIN_DR(u, n) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN)::u
		REAL(DBL_AD),INTENT(IN)::n
		TYPE (DUAL_NUM)::res

		IF (u%x_ad_ < n) THEN
			res = u
		ELSE
			res = n
		ENDIF

    END FUNCTION MIN_DR

    !-----------------------------------------
	! Obtain the min of a dual number and a single
	!----------------------------------------
	ELEMENTAL FUNCTION MIN_DS(u, n) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN)::u
		REAL(SNG_AD),INTENT(IN)::n
		TYPE (DUAL_NUM)::res

		IF (u%x_ad_ < n) THEN
			res = u
		ELSE
			res = n
		ENDIF

    END FUNCTION MIN_DS

  !-----------------------------------------
	! Obtain the min value of vector u
	!----------------------------------------
	FUNCTION MINVAL_D(u) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN)::u(:)
		INTEGER::iloc(1)
		TYPE (DUAL_NUM)::res

        iloc=MINLOC(u%x_ad_)
		res=u(iloc(1))

    END FUNCTION MINVAL_D

    !------------------------------------------------------
    !Returns the nearest integer to u%x, ELEMENTAL
    !------------------------------------------------------
	ELEMENTAL FUNCTION NINT_D(u) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN):: u
		INTEGER::res

		res=NINT(u%x_ad_)

    END FUNCTION NINT_D

    !----------------------------------------------------------------
	! SIGN(a,b) with two dual numbers as inputs,
	! the result will be |a| if b%x>=0, -|a| if b%x<0,ELEMENTAL
    !----------------------------------------------------------------
	ELEMENTAL   FUNCTION SIGN_DD(val1, val2) RESULT(res)
		TYPE (DUAL_NUM), INTENT(IN) :: val1, val2
		TYPE (DUAL_NUM)::res

		IF (val2%x_ad_ < 0.D0) THEN
			res = -ABS(val1)
		ELSE
			res =  ABS(val1)
		ENDIF

     END FUNCTION SIGN_DD

    !----------------------------------------------------------------
	! SIGN(a,b) with one real and one dual number as inputs,
	! the result will be |a| if b%x>=0, -|a| if b%x<0,ELEMENTAL
    !----------------------------------------------------------------
	ELEMENTAL   FUNCTION SIGN_RD(val1, val2) RESULT(res)
		REAL(DBL_AD),INTENT(IN)::val1
		TYPE (DUAL_NUM), INTENT(IN) :: val2
		TYPE (DUAL_NUM)::res

		IF (val2%x_ad_ < 0.D0) THEN
			res = -ABS(val1)
		ELSE
			res = ABS(val1)
		ENDIF

     END FUNCTION SIGN_RD

    !-----------------------------------------
	! SIN of dual numbers
	! SIN<u,up>=<SIN(u),up COS(u)>
	!----------------------------------------
	ELEMENTAL FUNCTION SIN_D(u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
         TYPE (DUAL_NUM)::res
         REAL (DBL_AD):: tmp

         res%x_ad_ = SIN(u%x_ad_)
		 tmp=COS(u%x_ad_)
         res%xp_ad_= u%xp_ad_*tmp

	END FUNCTION SIN_D

    !-----------------------------------------
	! SQRT of dual numbers
	! SQRT<u,up>=<SQRT(u),up/2/sqrt(u) >
	!----------------------------------------
	ELEMENTAL FUNCTION SQRT_D(u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u
		 REAL(DBL_AD):: tmp
		 TYPE (DUAL_NUM)::res

		 tmp=SQRT(u%x_ad_)

         res%x_ad_ = tmp
		 IF(tmp==0.0d0) THEN
            res%xp_ad_=Set_NaN()
		 ELSE
			tmp= 0.5D0/tmp
			res%xp_ad_= u%xp_ad_*tmp
         ENDIF
	END FUNCTION SQRT_D

    !-----------------------------------------
	! SUM OF A DUAL ARRAY
    !----------------------------------------
	FUNCTION SUM_D(u) RESULT(res)
         TYPE (DUAL_NUM), INTENT(IN)::u(:)
		 TYPE (DUAL_NUM)::res
		 INTEGER:: i

         res%x_ad_ = SUM(u%x_ad_)
		 DO i=1,NDV_AD
			res%xp_ad_(i)= SUM(u%xp_ad_(i))
         ENDDO
	END FUNCTION SUM_D

ELEMENTAL FUNCTION Set_NaN() RESULT(res)
		 REAL(DBL_AD)::res

         res=SQRT(negative_one)

	END FUNCTION Set_NaN

END MODULE  Dual_Num_Auto_Diff


      SUBROUTINE SOLMDT(TSEC50,SUNVEC,IFLAG)
C
C     CALCULATE THE POSITION OF THE SUN IN MEAN OF DATE COORDINATES.
C
C
C     VARIABLE    TYPE    I/O         DESCRIPTION
C     --------    ----    ---         -----------
C
C     TSEC50       R*8     I     INPUT TIME IN SECONDS SINCE JAN 1 1950
C                                0.0 HOURS ET. MAY BE ANY VALUE + OR -.
C                                ACCURACY IS NOT HIGH ENOUGH TO WARRANT
C                                DOING AN ET-UT CORRECTION. TIME CAN BE
C                                UT IF IT IS MORE CONVENIENT.
C
C     SUNVEC(3)    R*8     O     VECTOR TO THE SUN FOR THAT TIME
C
C     IFLAG        I*4     I     EQ 1, SUNVEC IS A UNIT VECTOR
C                                NE 1, SUNVEC IS IN KM.
C
C***********************************************************************
C
C  BY C PETRUZZO. ABOUT 1/83. COMMENT AND MINOR CODE MODS 7/83.
C
C***********************************************************************
C
C
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION SUNVEC(3)
      DATA TWOPI/6.283185307179856D0/,SECDAY/86400.D0/
      REAL*8 DEGRAD/ 57.29577951308232D0 /
C
C  SEE EXPLANATORY SUPPLEMENT TO THE ASTRONOMICAL EPHEMERIS AND THE
C  AMERICAN EPHEMERIS AND NAUTICAL ALMANAC(1974,=1961+AMMENDMENTS),
C  PAGE 98. GSFC LIBRARY NUMBER IS QB8.U5, E96.
C
C  ACCURACY: THE RESULTS OF USING THIS ROUTINE WERE COMPARED AGAINST
C            THE 1983 ASTRONOMICAL ALMANAC TABLE VALUES FOR RIGHT
C            ASCENSION AND DECLINATION. COMPARISONS WERE DONE AT
C            0.0 HRS ON 1/1/83 AND AT 10 DAY INTERVALS THROUGHOUT 1983.
C            THE MAXIMUM ERROR FOUND WAS ABOUT 2 ARC MINUTES.
C
      INTEGER INIT/1/
C
C  INITIALIZE PARAMETERS TO VALUES AT JAN 0.5, 1900, E.T.
      IF(INIT.EQ.1) THEN
        INIT=0
        GAM0 = 281.220844D0/DEGRAD
        GAMD = .0000470684D0/DEGRAD
        G0 = 358.475833D0/DEGRAD
        GD = 0.985600267D0/DEGRAD
        EPS0 = 23.452294D0/DEGRAD
        EPSD = 0.35626D-06/DEGRAD
        END IF
C
C
C  CONVERT FROM SECONDS SINCE 1/1/50, 0.0 HRS E.T., TO DAYS SINCE
C  JAN 0.5, 1900, E.T.
      D = TSEC50/SECDAY + 18262.5D0
C
C  ECCENTRICITY OF EARTH'S ORBIT ABOUT THE SUN AT THE INPUT TIME.
      E = 0.1675104D-01 - 0.11444D-08*D
C  OBLIQUITY OF THE ECLIPTIC AT THE INPUT TIME.
      EPS = EPS0 - D*EPSD
C  ANGLE FROM EQUINOX TO PERIHELION AT THE INPUT TIME.
      GAM = GAM0 + D*GAMD
C  MEAN POSITION OF THE SUN, REFERRED TO PERIHELION, AT THE INPUT TIME.
      G = G0 + D*GD
C  LONGITUDE OF THE SUN AT THE INPUT TIME.
      AL = GAM + G + 2.D0*E*DSIN(G)
      AL = DMOD(AL,TWOPI)
C
C  CONVERT ANGLES TO UNIT VECTOR.
      SINAL = DSIN(AL)
      SUNVEC(1) = DCOS(AL)
      SUNVEC(2) = SINAL*DCOS(EPS)
      SUNVEC(3) = SINAL*DSIN(EPS)
C
C  IF WANTED, CONVERT UNIT VECTOR TO POSITION VECTOR.
      IF(IFLAG.NE.1) THEN
        R=149597871.D0/(1.D0+E*DCOS(G))
        SUNVEC(1)=R*SUNVEC(1)
        SUNVEC(2)=R*SUNVEC(2)
        SUNVEC(3)=R*SUNVEC(3)
        END IF
C
      RETURN
      END


*deck dihangle_face
      subroutine dihangle_face(points1,xic1,yic1,zic1,
     *                         points2,xic2,yic2,zic2,
     *                                           angle)
C
C
C #####################################################################
C
C     PURPOSE -
C
C        Finds the dihedral angle between two faces
C
C     INPUT ARGUMENTS -
C
C        points1                : The number of points on face 1.
C        (xic1(),yic1(),zic1()  : The coordinates of the face 1 points.
C        points3                : The number of points on face 2.
C        (xic2(),yic2(),zic2()  : The coordinates of the face 2 points.
C
C     OUTPUT ARGUMENTS -
C
C        angle : The dihedral angle between face 1 and face 2 in radians.
C
C     CHANGE HISTORY -
C
C $Log: dihangle_face.f,v $
C Revision 2.00  2007/11/05 19:45:52  spchu
C Import to CVS
C
CPVCS
CPVCS       Rev 1.0   Fri Aug 29 14:07:46 1997   dcg
CPVCS    Initial revision.
C
C ######################################################################
C
C
      implicit none
C
      include "local_element.h"
C
      real*8 angle
      integer points1, points2
      real*8 xic1(1000000), yic1(1000000), zic1(1000000)
      real*8 xic2(1000000), yic2(1000000), zic2(1000000)
C  coefficients of the normals to the faces
      real*8 a1,b1,c1,a2,b2,c2
C
      real*8 dot,norm1,norm2
      integer i
C
C ######################################################################
C
C
C  Compute the normals to the faces
C  Use the more robust method of projecting to each axis and using
C  all the points on the face to generate normal
      a1=0
      b1=0
      c1=0
      a2=0
      b2=0
      c2=0
      do i=1,points1-1
         a1 = a1 + (zic1(i) + zic1(i+1)) * (yic1(i) - yic1(i+1))
         b1 = b1 + (xic1(i) + xic1(i+1)) * (zic1(i) - zic1(i+1))
         c1 = c1 + (yic1(i) + yic1(i+1)) * (xic1(i) - xic1(i+1))
      enddo
      a1 = a1 + (zic1(points1) + zic1(1)) * (yic1(points1) - yic1(1))
      b1 = b1 + (xic1(points1) + xic1(1)) * (zic1(points1) - zic1(1))
      c1 = c1 + (yic1(points1) + yic1(1)) * (xic1(points1) - xic1(1))

      norm1 = sqrt(a1*a1 + b1*b1 + c1*c1)
      a1 = a1 / norm1
      b1 = b1 / norm1
      c1 = c1 / norm1

      do i=1,points2-1
         a2 = a2 + (zic2(i) + zic2(i+1)) * (yic2(i) - yic2(i+1))
         b2 = b2 + (xic2(i) + xic2(i+1)) * (zic2(i) - zic2(i+1))
         c2 = c2 + (yic2(i) + yic2(i+1)) * (xic2(i) - xic2(i+1))
      enddo
      a2 = a2 + (zic2(points2) + zic2(1)) * (yic2(points2) - yic2(1))
      b2 = b2 + (xic2(points2) + xic2(1)) * (zic2(points2) - zic2(1))
      c2 = c2 + (yic2(points2) + yic2(1)) * (xic2(points2) - xic2(1))

      norm2 = sqrt(a2*a2 + b2*b2 + c2*c2)
      a2 = a2 / norm2
      b2 = b2 / norm2
      c2 = c2 / norm2

      dot = a1*a2 + b1*b2 + c1*c2
C  Negate because want angle between faces, not normals.
      angle = acos(-dot)

      return
      end


PROGRAM CNPE2_HT_ALPS
 USE PE2D_TYPE
 USE PE2D_VAR
 USE PE2D_AUX
 USE PE2D_GROUND
 IMPLICIT NONE
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) "========== Parabolic Equation Package =========="
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "University of Bristol"
 WRITE(*,*) "Mech. Eng. Department"
 WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
 WRITE(*,*) ""
 WRITE(*,*) "Codor Khodr, July 2016"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "CNPE2_HT"
 WRITE(*,*) "Dimension  :  	2D"
 WRITE(*,*) "Atmosphere :	Homogeneous"
 WRITE(*,*) "Boundary   : 	Shift Map"
 WRITE(*,*) "Impedance  : 	Rigid"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Read data
 OPEN(UNIT=10,FILE="CNPE2_IN.dat")
 READ(10,*) L          !Domain range
 READ(10,*) F          !Frequency
 READ(10,*) ZS         !Source height
 READ(10,*) ZR         !Target height
 READ(10,*) ZX         !Impedance real part
 READ(10,*) ZY         !Impedance imaginary part
 READ(10,*) ANGLE      !Terrain maximum angle
 READ(10,*) DC         !Atmosphere profile coefficient
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Get real topography
 PATH_TOPO = "../../GROUND/SnT_2017/ALPS/"
 FILE_TOPO = "alps_2d_sampled.dat"
 TOPO      = TRIM(PATH_TOPO) // TRIM(FILE_TOPO)
 CALL READ_ARRAY(TRIM(TOPO),GMT_DATA,NLINES,NCOLS)
 ALLOCATE(X(NLINES),TERR(NLINES),TERR1(NLINES),TERR2(NLINES))
 X         = GMT_DATA(:,1)
 TERR      = GMT_DATA(:,2)
 TERR1     = GMT_DATA(:,3)
 TERR2     = GMT_DATA(:,4)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
!Discretization of the Atmosphere domain
 C0     = 343.0_DP
 LMBDA0 = C0/F
 K0     = 2.0_DP*PI*F/C0
 DZ     = LMBDA0/10
 DR     = GMT_DATA(3,1)-GMT_DATA(2,1)
 H      = 150*LMBDA0
 HA     = 30*LMBDA0
 N      = FLOOR(H/DZ)
 N1     = FLOOR(Z1/DZ)
 N2     = FLOOR(Z2/DZ)
 M      = NLINES
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Size of the system : ", N
 WRITE(*,*) "Number of steps : ", M
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 NS     = MAX(1,FLOOR(ZS/DZ))
 NR     = MAX(1,FLOOR(ZR/DZ))
 NA     = FLOOR(HA/DZ)
 A      = IM/(2.0_DP*K0*DZ**2)
 KU     = 1
 KL     = 1
 NDIAG  = KU+KL+1
 WIDE_I = 0
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Absorbing coefficient
 AS = 4.897_DP*(10**(-9))*(F**3) - &
      7.119_DP*(10**(-6))*(F**2) + &
      3.109_DP*(10**(-3))*F + &
      0.113
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Atmosphere density and wave velocity
 ALLOCATE(C(N),K(N),DK2(N),ALT(N))
 DC = 2.5_DP
 Z0 = 0.5_DP
 DO NZ = 1,N
  ALT(NZ) = NZ*DZ
  C(NZ)   = C0+DC*LOG(1+ALT(NZ)/Z0)
  K(NZ)   = 2.0_DP*PI*F/C(NZ)
  IF (NZ.GT.(N-NA)) THEN
   K(NZ)  = K(NZ)+AS*IM*(NZ-N+NA)**2/NA**2
  END IF
  DK2(NZ) = K(NZ)**2-K0**2
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Terrain Boundary condition
 ALLOCATE(LIN(0:M),SLOPX(M),NN(M))
 DO MX = 0,M
  LIN(MX)   = LIN(MX-1)+(1+TERR1(MX))*DR
  SLOPX(MX) = ATAN(TERR1(MX))
  NN(MX)    = TERR(MX)/DZ
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Starting field
 ALLOCATE(PHI(N,M+1),PC(N,M),QC(N,M),P(N,M),Q(N,M))
 A0 = 1.3717_DP
 A2 = -0.3701_DP
 B  = 3.0_DP
 DO NZ = 1,N
  PHI(NZ,1) = SQRT(IM*K0)* &
              ((A0+A2*K0**2*(NZ*DZ-ZS)**2)*EXP(-K0**2*(NZ*DZ-ZS)**2/B) + &
               (A0+A2*K0**2*(NZ*DZ+ZS)**2)*EXP(-K0**2*(NZ*DZ+ZS)**2/B))
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Boundary condition - Finite Difference
 ALLOCATE(T(N,N),D(N,N),E(N,N),I(N,N))
 TAU1    =  4.0_DP/(3.0_DP-2.0_DP*IM*K0*DZ)
 TAU2    = -1.0_DP/(3.0_DP-2.0_DP*IM*K0*DZ)
 SIGMA1  =  4.0_DP/3.0_DP
 SIGMA2  = -1.0_DP/3.0_DP
 !Matrix Initialization (Dense Matrices) - T, D and E
 T(:,:)  = 0.0_DP
 DO NZ = 2,N-1
  T(NZ,NZ-1) =  1.0_DP
  T(NZ,NZ)   = -2.0_DP
  T(NZ,NZ+1) =  1.0_DP
 END DO
 T(1,1)   = -2.0_DP+SIGMA1
 T(1,2)   =  1.0_DP+SIGMA2
 T(N,N-1) =  1.0_DP+TAU2
 T(N,N)   = -2.0_DP+TAU1
 E        = DDIAG(CMPLX(ALT,0.0_DP,KIND=DPC),N)
 D        = (IM/(2.0_DP*K0))*DDIAG(DK2,N)
 I        = EYE(N)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !System - M1 and M2
 ALLOCATE(M1(N,N),M2(N,N),MB2(NDIAG,N),MB1(NDIAG,N))
 C1 = CMPLX(1.0_DP,0.0_DP,KIND=DP)
 C2 = CMPLX(0.0_DP,0.0_DP,KIND=DP)
 SELECT CASE (WIDE_I)
  CASE(0)
   BETA1 = DR/2.0_DP
   BETA2 = -DR/2.0_DP
  CASE(1)
   BETA1 = 1.0_DP/(2.0_DP*IM*K0)+DR/2.0_DP
   BETA2 = 1.0_DP/(2.0_DP*IM*K0)-DR/2.0_DP
  CASE DEFAULT
   STOP "[MAIN] : Enter valid wide-angle case"
 END SELECT
 WRITE(*,*) "Wide-angle order : ", WIDE
 M1  = I+A*BETA1*T+BETA1*D
 M2  = I+A*BETA2*T+BETA2*D
 MB1 = D2B(M1,N,KL,KU)
 MB2 = D2B(M2,N,KL,KU)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Forward-marching procedure
 ALLOCATE(MB1T(NDIAG,N),MB2T(KL+NDIAG,N),IPIV(N),TEMP(N,1))
 CALL CPU_TIME(TI)
 DO MX = 2,M+1
  WRITE(*,*) "Step :", MX-1, "out of", M
  !Matrix updating
  MB1T                  = MB1
  MB1T(KU+1,:)          = MB1(KU+1,:)-BETA1*IM*K0*TERR2(MX-1)*ALT
  MB2T(KL+1:KL+NDIAG,:) = MB2
  MB2T(KL+KU+1,:)       = MB2(KU+1,:)-BETA2*IM*K0*TERR2(MX-1)*ALT
  !Right hand side multiplication
  CALL ZGBMV('N',N,N,KL,KU,C1,MB1T,KL+KU+1,PHI(1:N,MX-1),1,C2,TEMP(:,1),1)   !Band matrix form
  WRITE(*,*) ".... Right-hand side multiplied"
  !System solving
  CALL ZGBSV(N,KL,KU,1,MB2T,2*KL+KU+1,IPIV,TEMP,N,INFO)                      !Band matrix form
  IF (INFO.NE.0) THEN
   STOP "ERROR : Matrix is singular"
  END IF
  WRITE(*,*) ".... System solved"
  !Complex and real pressure
  PHI(1:N,MX)  = TEMP(:,1)
  PC(1:N,MX-1) = EXP(IM*K0*(MX-1)*DR)*PHI(1:N,MX)/SQRT((MX-1)*DR)
  P(1:N,MX-1)  = REALPART(PC(1:N,MX-1))
  WRITE(*,*)
 END DO
 CALL CPU_TIME(TF)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !A posteriori phase correction
 DO MX = 1,M
  QC(1:N,MX) = (PHI(1:N,MX)+MX*A*(PHI(1:N,MX+1)-2.0_DP*PHI(1:N,MX)+PHI(1:N,MX-1)))/SQRT(MX*DR)
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Transmission loss conversion
 ALLOCATE(LP(N,M),LQ(N,M),LPG(M),LPG1(M),LPG2(M),LQG(M))
 P0 = ABS(PC(NS,1))                   !Reference pressure (real)
 Q0 = ABS(QC(NS,1))                   !Reference corrected pressure (real)
 DO MX = 1,M
  DO NZ = 1,N
   LP(NZ,MX) = 10.0_DP*LOG10(ABS(PC(NZ,MX))**2/(P0**2))
   LQ(NZ,MX) = 10.0_DP*LOG10(ABS(QC(NZ,MX))**2/(Q0**2))
   IF (LP(NZ,MX).LE.-120) THEN
    LP(NZ,MX) = -120
    LQ(NZ,MX) = -120
   END IF
  END DO
  LPG1(MX) = LP(N1,MX)
  LPG2(MX) = LP(N2,MX)
 END DO
 LP0 = LP(NS,1)
 LQ0 = LQ(NS,1)
 LPG = LP(1,1:M)
 LQG = LQ(1,1:M)
 LPR = LP(NR,M)
 LQR = LQ(NR,M)
 PR  = SQRT(2.0_DP)*P0*10**(LPR/20)
 QR  = SQRT(2.0_DP)*Q0*10**(LPR/20)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Output
 OUT_EXT = "ALPS"
 OUT_LPg = "LPg_"  // TRIM(OUT_EXT) // ".dat"
 OUT_LP  = "LP_"   // TRIM(OUT_EXT) // ".dat"
 OPEN(UNIT=10,FILE=TRIM(OUT_LPg))
 OPEN(UNIT=20,FILE=TRIM(OUT_LP))
 DO MX = 1,M
  WRITE(10,100) X(MX), TERR(MX), LPG(MX), LPG1(MX), LPG2(MX)
  DO NZ = 1,N
   WRITE(20,100) X(MX), NZ*DZ+TERR(MX), LP(NZ+NN(MX),MX)
  END DO
  WRITE(20,*)
 END DO
 100 FORMAT(5(3X,F12.3))
 !101 FORMAT(2(3X,F12.3),3X,F12.3,SP,F12.3,SS,"i")
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 DEALLOCATE(PHI,PC,QC,P,Q,LP,LQ)
 WRITE(*,*) "================================================"
 WRITE(*,*) "Input file  : ", TOPO
 WRITE(*,*) "================================================"
 WRITE(*,*) "Output file : ", TRIM(OUT_LP)
 WRITE(*,*) "              ", TRIM(OUT_LPg)
 WRITE(*,*) "================================================"
 WRITE(*,*)
 WRITE(*,*) "System size (N x M) :", N, M
 WRITE(*,*) "Step size :", DR
 WRITE(*,*) "Main CPU time (s) :", TF-TI
 WRITE(*,*) "Real pressure at the source - P0 (Pa) :", P0
 WRITE(*,*) "Real pressure at the target - PR (Pa) :", PR
 WRITE(*,*) "SPL/TL at the source - LP0 (dB) :", LP0
 WRITE(*,*) "SPL/TL at the target - LPR (dB) :", LPR
 WRITE(*,*)
 !-----------------------------------------------------------
 !----------------------------------------------------------
END PROGRAM CNPE2_HT_ALPS


! MIT License
!
! Copyright (c) 2016 Anders Steen Christensen
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

subroutine fmanhattan_distance(A, B, D)

    implicit none

    double precision, dimension(:,:), intent(in) :: A
    double precision, dimension(:,:), intent(in) :: B
    double precision, dimension(:,:), intent(inout) :: D

    integer :: na, nb
    integer :: i, j

    na = size(A, dim=2)
    nb = size(B, dim=2)

!$OMP PARALLEL DO
    do i = 1, nb
        do j = 1, na
            D(j,i) = sum(abs(a(:,j) - b(:,i)))
        enddo
    enddo
!$OMP END PARALLEL DO

end subroutine fmanhattan_distance

subroutine fl2_distance(A, B, D)

    implicit none

    double precision, dimension(:,:), intent(in) :: A
    double precision, dimension(:,:), intent(in) :: B
    double precision, dimension(:,:), intent(inout) :: D

    integer :: na, nb, nv
    integer :: i, j

    double precision, allocatable, dimension(:) :: temp

    nv = size(A, dim=1)

    na = size(A, dim=2)
    nb = size(B, dim=2)

    allocate(temp(nv))

!$OMP PARALLEL DO PRIVATE(temp)
    do i = 1, nb
        do j = 1, na
            temp(:) = A(:,j) - B(:,i)
            D(j,i) = sqrt(sum(temp*temp))
        enddo
    enddo
!$OMP END PARALLEL DO

    deallocate(temp)

end subroutine fl2_distance

subroutine fp_distance_double(A, B, D, p)

    implicit none

    double precision, dimension(:,:), intent(in) :: A
    double precision, dimension(:,:), intent(in) :: B
    double precision, dimension(:,:), intent(inout) :: D
    double precision, intent(in) :: p

    integer :: na, nb, nv
    integer :: i, j, k

    double precision, allocatable, dimension(:) :: temp
    double precision :: inv_p

    nv = size(A, dim=1)

    na = size(A, dim=2)
    nb = size(B, dim=2)

    inv_p = 1.0d0 / p

    allocate(temp(nv))

!$OMP PARALLEL DO PRIVATE(temp)
    do i = 1, nb
        do j = 1, na
            temp(:) = abs(A(:,j) - B(:,i))
            D(j,i) = (sum(temp**p))**inv_p
        enddo
    enddo
!$OMP END PARALLEL DO

    deallocate(temp)

end subroutine fp_distance_double

subroutine fp_distance_integer(A, B, D, p)

    implicit none

    double precision, dimension(:,:), intent(in) :: A
    double precision, dimension(:,:), intent(in) :: B
    double precision, dimension(:,:), intent(inout) :: D
    integer, intent(in) :: p

    integer :: na, nb, nv
    integer :: i, j

    double precision, allocatable, dimension(:) :: temp
    double precision :: inv_p

    nv = size(A, dim=1)

    na = size(A, dim=2)
    nb = size(B, dim=2)

    inv_p = 1.0d0 / dble(p)

    allocate(temp(nv))

!$OMP PARALLEL DO PRIVATE(temp)
    do i = 1, nb
        do j = 1, na
            temp(:) = A(:,j) - B(:,i)
            D(j,i) = (sum(temp**p))**inv_p
        enddo
    enddo
!$OMP END PARALLEL DO

    deallocate(temp)

end subroutine fp_distance_integer


! { dg-do compile }
! { dg-options "-Ofast" }

      subroutine foo(U,V,R,N,A)
      integer N
      real*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3)
      integer I3, I2, I1
C
      do I3=2,N-1
       do I2=2,N-1
        do I1=2,N-1
         R(I1,I2,I3)=V(I1,I2,I3)
     *      -A(0)*( U(I1,  I2,  I3  ) )
     *      -A(1)*( U(I1-1,I2,  I3  ) + U(I1+1,I2,  I3  )
     *                 +  U(I1,  I2-1,I3  ) + U(I1,  I2+1,I3  )
     *                 +  U(I1,  I2,  I3-1) + U(I1,  I2,  I3+1) )
     *      -A(2)*( U(I1-1,I2-1,I3  ) + U(I1+1,I2-1,I3  )
     *                 +  U(I1-1,I2+1,I3  ) + U(I1+1,I2+1,I3  )
     *                 +  U(I1,  I2-1,I3-1) + U(I1,  I2+1,I3-1)
     *                 +  U(I1,  I2-1,I3+1) + U(I1,  I2+1,I3+1)
     *                 +  U(I1-1,I2,  I3-1) + U(I1-1,I2,  I3+1)
     *                 +  U(I1+1,I2,  I3-1) + U(I1+1,I2,  I3+1) )
     *      -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1)
     *                 +  U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1)
     *                 +  U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1)
     *                 +  U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) )
        enddo
       enddo
      enddo
      return
      end


submodule (calculus) integral

implicit none (type, external)

contains

module procedure integral3D1_curv
!  integral3D1_curv(f,x,lbnd,ubnd)
!PURPOSEFULLY KEPT WARNING TO MAINTIN CONGRUITY WITH OTHER CALCULUS FUNCTIONS
!/home/zettergm/zettergmdata/GEMINI/numerical/calculus/calculus.f90:512:0:
!warning: unused parameter ‘ubnd’ [-Wunused-parameter]
!   function integral3D1_curv(f,x,lbnd,ubnd)

!------------------------------------------------------------
!-------COMPUTE AN INTEGRAL OF A 3D ARRAY ALONG THE 1-DIM.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE
!-------
!-------NOTE, AS BEFORE THAT THE GRID MAY BE INDEXED DIFFERENTLY
!-------THAT THE FUNCTION BEING INTEGRATED
!------------------------------------------------------------
integer :: ix1,lx1

lx1=size(f,1)

integral3D1_curv(1,:,:)=0._wp
do ix1=2,lx1
  integral3D1_curv(ix1,:,:)=integral3D1_curv(ix1-1,:,:)+0.5_wp*(f(ix1,:,:)+f(ix1-1,:,:))*x%dx1(lbnd+ix1-1)
end do
end procedure integral3D1_curv

module procedure integral3D1_curv_alt

!PURPOSEFULLY KEPT WARNING TO MAINTIN CONGRUITY WITH OTHER CALCULUS FUNCTIONS
!/home/zettergm/zettergmdata/GEMINI/numerical/calculus/calculus.f90:539:0:
!warning: unused parameter ‘ubnd’ [-Wunused-parameter]
!   function integral3D1_curv_alt(f,x,lbnd,ubnd)

!------------------------------------------------------------
!-------COMPUTE AN INTEGRAL OF A 3D ARRAY ALONG THE 1-DIM.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE
!-------
!-------NOTE, AS BEFORE THAT THE GRID MAY BE INDEXED DIFFERENTLY
!-------THAN THE FUNCTION BEING INTEGRATED.  ALSO THIS ALT VERSION
!-------INTEGRATES FROM SET OPINT TO THE MAX VALUE ON THE GRID,
!-------RATHER THAN FROM THE MIN VALUE TO A FIXED POINT.
!------------------------------------------------------------
integer :: ix1,lx1

lx1=size(f,1)

integral3D1_curv_alt(lx1,:,:)=0._wp
do ix1=lx1-1,1,-1
  !! start from the logical top and sum  downward (keep dx positive since the intent is to integrate from fixed point to top)
  integral3D1_curv_alt(ix1,:,:)=integral3D1_curv_alt(ix1+1,:,:)+0.5_wp*(f(ix1,:,:)+f(ix1+1,:,:))*x%dx1(lbnd+ix1-1+1)
  !! +1 since we are starting from top
end do
end procedure integral3D1_curv_alt

module procedure integral2D1_curv

!PURPOSEFULLY KEPT WARNING TO MAINTIN CONGRUITY WITH OTHER CALCULUS FUNCTIONS
!/home/zettergm/zettergmdata/GEMINI/numerical/calculus/calculus.f90:568:0:
!warning: unused parameter ‘ubnd’ [-Wunused-parameter]
!   function integral2D1_curv(f,x,lbnd,ubnd)

!------------------------------------------------------------
!-------COMPUTE AN INTEGRAL OF A 2D ARRAY ALONG THE 1-DIM.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE
!------------------------------------------------------------
integer :: ix1,lx1

lx1=size(f,1)

integral2D1_curv(1,:)=0._wp
do ix1=2,lx1
  integral2D1_curv(ix1,:)=integral2D1_curv(ix1-1,:)+0.5_wp*(f(ix1,:)+f(ix1-1,:))*x%dx1(lbnd+ix1-1)
end do
end procedure integral2D1_curv

module procedure integral2D1_curv_alt

!PURPOSEFULLY KEPT WARNING TO MAINTIN CONGRUITY WITH OTHER CALCULUS FUNCTIONS
!/home/zettergm/zettergmdata/GEMINI/numerical/calculus/calculus.f90:592:0:
!warning: unused parameter ‘ubnd’ [-Wunused-parameter]
!   function integral2D1_curv_alt(f,x,lbnd,ubnd)

!------------------------------------------------------------
!-------COMPUTE AN INTEGRAL OF A 2D ARRAY ALONG THE 1-DIM.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE.
!-------
!-------THIS VERSION INTEGRATES WRT X2
!------------------------------------------------------------
integer :: ix2,lx2

lx2=size(f,1)

integral2D1_curv_alt(1,:)=0._wp
do ix2=2,lx2
  integral2D1_curv_alt(ix2,:)=integral2D1_curv_alt(ix2-1,:)+0.5_wp*(f(ix2,:)+f(ix2-1,:))*x%dx2(lbnd+ix2-1)
end do
end procedure integral2D1_curv_alt

module procedure integral2D2_curv

!PURPOSEFULLY KEPT WARNING TO MAINTIN CONGRUITY WITH OTHER CALCULUS FUNCTIONS
!/home/zettergm/zettergmdata/GEMINI/numerical/calculus/calculus.f90:618:0:
!warning: unused parameter ‘ubnd’ [-Wunused-parameter]
!   function integral2D2_curv(f,x,lbnd,ubnd)

!------------------------------------------------------------
!-------COMPUTE AN INTEGRAL OF A 2D ARRAY ALONG THE 2-DIM.
!-------WITH RESPECT TO X2.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE
!-------
!-------IT IS ASSUMED THAT THE INTEGRATION IS ALWAYS OVER THE
!-------ENTIRE GRID (X2ALL).
!------------------------------------------------------------

integer :: ix2,lx2

lx2=size(f,2)

integral2D2_curv(:,1)=0._wp
do ix2=2,lx2
  integral2D2_curv(:,ix2)=integral2D2_curv(:,ix2-1)+0.5_wp*(f(:,ix2)+f(:,ix2-1))*x%dx2all(lbnd+ix2-1)
end do
end procedure integral2D2_curv

module procedure integral2D2_curv_alt

!PURPOSEFULLY KEPT WARNING TO MAINTIN CONGRUITY WITH OTHER CALCULUS FUNCTIONS
!/home/zettergm/zettergmdata/GEMINI/numerical/calculus/calculus.f90:642:0:
!warning: unused parameter ‘ubnd’ [-Wunused-parameter]
!   function integral2D2_curv_alt(f,x,lbnd,ubnd)

!------------------------------------------------------------
!-------COMPUTE AN INTEGRAL OF A 2D ARRAY ALONG THE 2-DIM,
!-------WITH RESPECT TO X3.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE.
!-------
!-------IT IS ASSUMED THAT THE INTEGRATION IS ALWAYS OVER THE
!-------ENTIRE GRID (X3ALL).
!------------------------------------------------------------
integer :: ix3,lx3

lx3=size(f,2)

integral2D2_curv_alt(:,1)=0._wp
do ix3=2,lx3
  integral2D2_curv_alt(:,ix3)=integral2D2_curv_alt(:,ix3-1)+0.5_wp*(f(:,ix3)+f(:,ix3-1))*x%dx3all(lbnd+ix3-1)
end do
end procedure integral2D2_curv_alt

end submodule integral


program main
  use matrix_module
  implicit none

  type(matrix) :: mat
  integer :: n

  ! compute determinants of random matrices
  do n = 1,5
     ! generate random  matrix
     mat = random_matrix(n,n)

     ! print determinant of matrix
     print "('n: ', i0, ', det: ', f0.5)", n, det(mat)

     ! destruct matrix
     call mat%destruct()
  end do

end program main


program    bits_rosetta
implicit none

 call bitwise(14,3)

 contains

subroutine bitwise(a,b)
implicit none
 integer, intent(in):: a,b
 character(len=*), parameter :: fmt1 = '(2(a,i10))'
 character(len=*),parameter :: fmt2 = '(3(a,b32.32),i20)'

write(*,fmt1) 'input a=',a,' b=',b
write(*,fmt2) 'and : ', a,' &  ',b,' = ',iand(a, b),iand(a, b)
write(*,fmt2) 'or  : ', a,' |  ',b,' = ',ior(a, b),ior(a, b)
write(*,fmt2) 'xor : ', a,' ^  ',b,' = ',ieor(a, b),ieor(a, b)
write(*,fmt2) 'lsh : ', a,' << ',b,' = ',ishft(a, abs(b)),ishft(a, abs(b))
write(*,fmt2) 'rsh : ', a,' >> ',b,' = ',ishft(a, -abs(b)),ishft(a, -abs(b))
write(*,fmt2) 'not : ', a,' ~  ',b,' = ',not(a),not(a)
write(*,fmt2) 'rot : ', a,' r  ',b,' = ',ishftc(a,-abs(b)),ishftc(a,-abs(b))

end subroutine bitwise

end program bits_rosetta