!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of forward_wrapper in reverse (adjoint) mode (with options noISIZE i8):
!   gradient     of useful results: *d *e *f *concold *g *temp
!                *w *headold *x *head *dbc_data *bcperiod *tempold
!                *propunit *tsal *presold *conc *pres *a *b *c
!   with respect to varying inputs: *d *e *f *concold *g *temp
!                *w *headold *x *head *dbc_data *bcperiod *tempold
!                *propunit *tsal *presold *conc *pres *a *b *c
!   Plus diff mem management of: d:in e:in f:in concold:in g:in
!                temp:in w:in headold:in x:in head:in dbc_data:in
!                bcperiod:in tempold:in propunit:in tsal:in presold:in
!                conc:in pres:in simtime:in a:in b:in c:in
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! 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.
!>    @brief wrapper for the forward simulation call
!>    @param[in] iseed 0: FW simulation, 1 .. <mpara>: AD seeding index
!>    @param[in] iter time iteration counter
!>    @param[in] ismpl local sample index
!>    @details
!> seperates the equation system solving from the\n
!> specific nonlinear solver (Picard based)\n
SUBROUTINE FORWARD_WRAPPER_AD(iter, iseed, ismpl)
  use arrays

  USE ARRAYS_AD

  USE MOD_GENRL
  USE MOD_GENRLC
  use mod_time

  USE MOD_TIME_AD

  IMPLICIT NONE
  INTEGER :: ismpl
  INTEGER :: iter, iseed
  INTEGER :: branch
  IF (lread_joutt) THEN
    WRITE(project_sfx(ismpl), '(1A,1I7.7)') '_all', iter
!         read data of each time step
!          CALL read_outt_hdf(ismpl)
  ELSE
! ######### Forward Iteration ######
    CALL PUSHINTEGER8(iter_nlold)
    IF (ALLOCATED(c)) THEN
      CALL PUSHREAL8ARRAY(c, SIZE(c, 1)*SIZE(c, 2)*SIZE(c, 3)*SIZE(c, 4)&
&                  )
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(b)) THEN
      CALL PUSHREAL8ARRAY(b, SIZE(b, 1)*SIZE(b, 2)*SIZE(b, 3)*SIZE(b, 4)&
&                  )
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(a)) THEN
      CALL PUSHREAL8ARRAY(a, SIZE(a, 1)*SIZE(a, 2)*SIZE(a, 3)*SIZE(a, 4)&
&                  )
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(simtime)) THEN
      CALL PUSHREAL8ARRAY(simtime, SIZE(simtime, 1))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(pres)) THEN
      CALL PUSHREAL8ARRAY(pres, SIZE(pres, 1)*SIZE(pres, 2)*SIZE(pres, 3&
&                   )*SIZE(pres, 4))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(conc)) THEN
      CALL PUSHREAL8ARRAY(conc, SIZE(conc, 1)*SIZE(conc, 2)*SIZE(conc, 3&
&                   )*SIZE(conc, 4)*SIZE(conc, 5))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(presold)) THEN
      CALL PUSHREAL8ARRAY(presold, SIZE(presold, 1)*SIZE(presold, 2)*&
&                   SIZE(presold, 3))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(tsal)) THEN
      CALL PUSHREAL8ARRAY(tsal, SIZE(tsal, 1)*SIZE(tsal, 2)*SIZE(tsal, 3&
&                   )*SIZE(tsal, 4))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(delt_count)) THEN
      CALL PUSHINTEGER8ARRAY(delt_count, SIZE(delt_count, 1))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(flag_delt)) THEN
      CALL PUSHINTEGER8ARRAY(flag_delt, SIZE(flag_delt, 1))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(flag_1st_timestep)) THEN
      CALL PUSHINTEGER8ARRAY(flag_1st_timestep, SIZE(flag_1st_timestep, &
&                      1))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(tempold)) THEN
      CALL PUSHREAL8ARRAY(tempold, SIZE(tempold, 1)*SIZE(tempold, 2)*&
&                   SIZE(tempold, 3))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(omp_iglobal)) THEN
      CALL PUSHINTEGER8ARRAY(omp_iglobal, SIZE(omp_iglobal, 1)*SIZE(&
&                      omp_iglobal, 2)*SIZE(omp_iglobal, 3))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(dbc_data)) THEN
      CALL PUSHREAL8ARRAY(dbc_data, SIZE(dbc_data, 1)*SIZE(dbc_data, 2)*&
&                   SIZE(dbc_data, 3))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(delt_old)) THEN
      CALL PUSHREAL8ARRAY(delt_old, SIZE(delt_old, 1))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(omp_dglobal)) THEN
      CALL PUSHREAL8ARRAY(omp_dglobal, SIZE(omp_dglobal, 1)*SIZE(&
&                   omp_dglobal, 2)*SIZE(omp_dglobal, 3))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(head)) THEN
      CALL PUSHREAL8ARRAY(head, SIZE(head, 1)*SIZE(head, 2)*SIZE(head, 3&
&                   )*SIZE(head, 4))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(conv_ipos)) THEN
      CALL PUSHINTEGER8ARRAY(conv_ipos, SIZE(conv_ipos, 1)*SIZE(&
&                      conv_ipos, 2))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(x)) THEN
      CALL PUSHREAL8ARRAY(x, SIZE(x, 1)*SIZE(x, 2)*SIZE(x, 3)*SIZE(x, 4)&
&                  )
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(w)) THEN
      CALL PUSHREAL8ARRAY(w, SIZE(w, 1)*SIZE(w, 2)*SIZE(w, 3)*SIZE(w, 4)&
&                  )
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(lcon)) THEN
      CALL PUSHBOOLEANARRAY(lcon, SIZE(lcon, 1)*SIZE(lcon, 2))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(conc_conv)) THEN
      CALL PUSHREAL8ARRAY(conc_conv, SIZE(conc_conv, 1)*SIZE(conc_conv, &
&                   2))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(conv_chlen)) THEN
      CALL PUSHINTEGER8ARRAY(conv_chlen, SIZE(conv_chlen, 1)*SIZE(&
&                      conv_chlen, 2))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(temp)) THEN
      CALL PUSHREAL8ARRAY(temp, SIZE(temp, 1)*SIZE(temp, 2)*SIZE(temp, 3&
&                   )*SIZE(temp, 4))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(g)) THEN
      CALL PUSHREAL8ARRAY(g, SIZE(g, 1)*SIZE(g, 2)*SIZE(g, 3)*SIZE(g, 4)&
&                  )
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(concold)) THEN
      CALL PUSHREAL8ARRAY(concold, SIZE(concold, 1)*SIZE(concold, 2)*&
&                   SIZE(concold, 3)*SIZE(concold, 4))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(f)) THEN
      CALL PUSHREAL8ARRAY(f, SIZE(f, 1)*SIZE(f, 2)*SIZE(f, 3)*SIZE(f, 4)&
&                  )
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(conv_history)) THEN
      CALL PUSHREAL8ARRAY(conv_history, SIZE(conv_history, 1)*SIZE(&
&                   conv_history, 2)*SIZE(conv_history, 3))
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(e)) THEN
      CALL PUSHREAL8ARRAY(e, SIZE(e, 1)*SIZE(e, 2)*SIZE(e, 3)*SIZE(e, 4)&
&                  )
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    IF (ALLOCATED(d)) THEN
      CALL PUSHREAL8ARRAY(d, SIZE(d, 1)*SIZE(d, 2)*SIZE(d, 3)*SIZE(d, 4)&
&                  )
      CALL PUSHCONTROL1B(1)
    ELSE
      CALL PUSHCONTROL1B(0)
    END IF
    CALL FORWARD_PICARD(iter, ismpl)
! ##################################
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(d, SIZE(d, 1)*SIZE(d, 2)*SIZE(&
&                                   d, 3)*SIZE(d, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(e, SIZE(e, 1)*SIZE(e, 2)*SIZE(&
&                                   e, 3)*SIZE(e, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(conv_history, SIZE(&
&                                   conv_history, 1)*SIZE(conv_history, &
&                                   2)*SIZE(conv_history, 3))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(f, SIZE(f, 1)*SIZE(f, 2)*SIZE(&
&                                   f, 3)*SIZE(f, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(concold, SIZE(concold, 1)*SIZE&
&                                   (concold, 2)*SIZE(concold, 3)*SIZE(&
&                                   concold, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(g, SIZE(g, 1)*SIZE(g, 2)*SIZE(&
&                                   g, 3)*SIZE(g, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(temp, SIZE(temp, 1)*SIZE(temp&
&                                   , 2)*SIZE(temp, 3)*SIZE(temp, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPINTEGER8ARRAY(conv_chlen, SIZE(conv_chlen&
&                                      , 1)*SIZE(conv_chlen, 2))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(conc_conv, SIZE(conc_conv, 1)*&
&                                   SIZE(conc_conv, 2))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPBOOLEANARRAY(lcon, SIZE(lcon, 1)*SIZE(&
&                                     lcon, 2))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(w, SIZE(w, 1)*SIZE(w, 2)*SIZE(&
&                                   w, 3)*SIZE(w, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(x, SIZE(x, 1)*SIZE(x, 2)*SIZE(&
&                                   x, 3)*SIZE(x, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPINTEGER8ARRAY(conv_ipos, SIZE(conv_ipos, &
&                                      1)*SIZE(conv_ipos, 2))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(head, SIZE(head, 1)*SIZE(head&
&                                   , 2)*SIZE(head, 3)*SIZE(head, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(omp_dglobal, SIZE(omp_dglobal&
&                                   , 1)*SIZE(omp_dglobal, 2)*SIZE(&
&                                   omp_dglobal, 3))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(delt_old, SIZE(delt_old, 1))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(dbc_data, SIZE(dbc_data, 1)*&
&                                   SIZE(dbc_data, 2)*SIZE(dbc_data, 3))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPINTEGER8ARRAY(omp_iglobal, SIZE(&
&                                      omp_iglobal, 1)*SIZE(omp_iglobal&
&                                      , 2)*SIZE(omp_iglobal, 3))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(tempold, SIZE(tempold, 1)*SIZE&
&                                   (tempold, 2)*SIZE(tempold, 3))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPINTEGER8ARRAY(flag_1st_timestep, SIZE(&
&                                      flag_1st_timestep, 1))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPINTEGER8ARRAY(flag_delt, SIZE(flag_delt, &
&                                      1))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPINTEGER8ARRAY(delt_count, SIZE(delt_count&
&                                      , 1))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(tsal, SIZE(tsal, 1)*SIZE(tsal&
&                                   , 2)*SIZE(tsal, 3)*SIZE(tsal, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(presold, SIZE(presold, 1)*SIZE&
&                                   (presold, 2)*SIZE(presold, 3))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(conc, SIZE(conc, 1)*SIZE(conc&
&                                   , 2)*SIZE(conc, 3)*SIZE(conc, 4)*&
&                                   SIZE(conc, 5))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(pres, SIZE(pres, 1)*SIZE(pres&
&                                   , 2)*SIZE(pres, 3)*SIZE(pres, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(simtime, SIZE(simtime, 1))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(a, SIZE(a, 1)*SIZE(a, 2)*SIZE(&
&                                   a, 3)*SIZE(a, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(b, SIZE(b, 1)*SIZE(b, 2)*SIZE(&
&                                   b, 3)*SIZE(b, 4))
    CALL POPCONTROL1B(branch)
    IF (branch .EQ. 1) CALL POPREAL8ARRAY(c, SIZE(c, 1)*SIZE(c, 2)*SIZE(&
&                                   c, 3)*SIZE(c, 4))
    CALL POPINTEGER8(iter_nlold)
    CALL FORWARD_PICARD_AD(iter, ismpl)
  END IF
END SUBROUTINE FORWARD_WRAPPER_AD


C Copyright(c) 1998, Space Science and Engineering Center, UW-Madison
C Refer to "McIDAS Software Acquisition and Distribution Policies"
C in the file  mcidas/data/license.txt

C *** $Id: nvxgmsx.dlm,v 1.4 1998/10/13 20:25:50 dglo Exp $ ***
C S. Chiswell/Unidata    2/02   Changed names of routines to avoid conflicts
C                               with GOES nav
C
C                               NVXINI --> GMSXINI
C                               NVXSAE --> GMSXSAE
C                               NVXEAS --> GMSXEAS
C                               NVXOPT --> GMSXOPT
C				NLLXYZ --> GMSLLXYZ
C				NXYZLL --> GMSXYZLL

      INTEGER FUNCTION GMSXINI(IFUNC,IPARMS)

      INTEGER IFUNC
      INTEGER IPARMS(*)
C      INTEGER OFFSET1
C      INTEGER OFFSET2
      CHARACTER*4 CLIT
      CHARACTER FORM*5
      CHARACTER CPARMS(3200)*1
      INTEGER*4	ICPRMS(800)
      EQUIVALENCE (CPARMS,ICPRMS)
      COMMON/GMSNAVCOM/NAVTYPE

      IF (IFUNC .EQ. 1) THEN

c* Remove "MORE" from every 128th word before initilizing
c* mapping common block.

C* UPC Replace use of MOVC with EQUIV to ICPRMS
C        OFFSET1 = 4
C        OFFSET2 = 0
C        CALL MOVC(504,IPARMS,OFFSET1,CPARMS,OFFSET2)
C        OFFSET1 = OFFSET1 + 508
C        OFFSET2 = OFFSET2 + 504
C
C      DO 100 i = 1, 4
C        CALL MOVC(508,IPARMS,OFFSET1,CPARMS,OFFSET2)
C        OFFSET1 = OFFSET1 + 512
C        OFFSET2 = OFFSET2 + 508
C100   continue

	DO I=1, 126
	   ICPRMS ( I ) = IPARMS( I + 1)
	END DO

	IOFF = 127
	DO J = 1, 4
	   DO I=1,127
	      ICPRMS ( IOFF ) = IPARMS ( IOFF + j + 1)
	      IOFF = IOFF + 1
	   END DO
	END DO
C* End UPC MOD

        FORM = 'short'
        CALL DECODE_OA_BLOCK(CPARMS,FORM)

      ELSE IF (IFUNC.EQ.2) THEN
         IF(INDEX(CLIT(IPARMS(1)),'XY').NE.0) NAVTYPE=1
         IF(INDEX(CLIT(IPARMS(1)),'LL').NE.0) NAVTYPE=2
      ENDIF

      GMSXINI = 0
      RETURN
      END

      INTEGER FUNCTION GMSXSAE(LIN,ELE,DUM1,LAT,LON,Z)

      INTEGER*4    IRET
      INTEGER*4    MODE
      COMMON/GMSNAVCOM/NAVTYPE
      REAL*4       RINF(8)
      REAL*8       DSCT
      REAL LAT
      REAL LON
      REAL ELE
      REAL LIN
      REAL DUM1
      REAL Z
      REAL LATLON(2)
      REAL SUBLAT
      REAL SUBLON
      REAL YLAT
      REAL YLON

        MODE=-1

        CALL SUBLATLON(LATLON)
        SUBLAT = LATLON(1)
        SUBLON = LATLON(2)
        CALL MGIVSR(MODE,ELE,LIN,LON,LAT,0.0,RINF,DSCT,IRET)
        IF(IRET .NE. 0)GOTO 100
        IF(ABS(LON) .GT. 180.)GOTO 100
        LON = (-1.)*LON
      IF((LON .GT. 90.-SUBLON).AND.(LON .LT. 270.-SUBLON))GOTO 100

      IF(NAVTYPE.EQ.1) THEN
         YLAT=LAT
         YLON=LON
         CALL LLCART(YLAT,YLON,LAT,LON,Z)
      ENDIF

      GMSXSAE = 0
      RETURN

100   GMSXSAE = -1
      RETURN
      END

      INTEGER FUNCTION GMSXEAS(INLAT,INLON,Z,LIN,ELE,DUM1)
      INTEGER MODE
      INTEGER*4    IRET
      COMMON/GMSNAVCOM/NAVTYPE
      REAL*4       RINF(8)
      REAL*8       DSCT
      REAL       INLAT
      REAL       INLON
      REAL       LAT
      REAL       LON
      REAL       LIN
      REAL       ELE
      REAL DUM1
      REAL LATLON(2)
      REAL SUBLAT
      REAL SUBLON
      REAL X
      REAL Y
      REAL Z

      LAT=INLAT
      LON=INLON

      IF(NAVTYPE.EQ.1) THEN
         X=LAT
         Y=LON
         CALL CARTLL(X,Y,Z,LAT,LON)
      ENDIF

      MODE=1

      CALL SUBLATLON(LATLON)
      SUBLAT = LATLON(1)
      SUBLON = LATLON(2)
      IF( ABS(LAT).GT.90 ) GOTO 100
      IF( ABS(LON).GT. 180 ) GOTO 100
      IF( LON.GT.90.-SUBLON .AND. LON.LT.270.-SUBLON) GOTO 100
      LON=(-1.0)*LON

        CALL MGIVSR(MODE,ELE,LIN,LON,LAT,0.0,RINF,DSCT,IRET)
        IF(IRET .NE. 0)GOTO 100

      GMSXEAS = 0
      RETURN
100   GMSXEAS = -1
      RETURN
      END

      INTEGER FUNCTION GMSXOPT(IFUNC,XIN,XOUT)
C
C IFUNC= 'SPOS'    SUBSATELLITE LAT/LON
C
C        XIN - NOT USED
C        XOUT - 1. SUB-SATELLITE LATITUDE
C             - 2. SUB-SATELLITE LONGITUDE
C
C
C IFUNC= 'ANG '   ANGLES
C
C        XIN - 1. SSYYDDD
C              2. TIME (HOURS)
C              3. LATITUDE
C              4. LONGITUDE (***** WEST NEGATIVE *****)
C        XOUT- 1. SATELLITE ANGLE
C              2. SUN ANGLE
C              3. RELATIVE ANGLE
C
C
C
C IFUNC= 'HGT '   INPUT HEIGHT FOR PARALLAX
C
C        XIN - 1. HEIGHT (KM)
C
      REAL*4 XIN(*),XOUT(*)
      CHARACTER*4 CLIT,CFUNC
      CFUNC=CLIT(IFUNC)
      GMSXOPT=0
      IF(CFUNC.EQ.'SPOS') THEN
         CALL SUBLATLON(XOUT)
C         CALL SDEST('IN NVX OPT USING --- SPOS',0)
      ELSE IF(CFUNC.EQ.'ANG ') THEN
C         CALL SDEST('IN NVX OPT USING --- ANG ',0)
      ELSE IF(CFUNC.EQ.'HGT ') THEN
C         CALL SDEST('IN NVX OPT USING --- HGT ',0)
      ELSE
         GMSXOPT=1
      ENDIF
      RETURN
      END
C
C
C
C
C-----SUBSIDIARY SUBPROGRAMS
C
C
C
c     FUNCTION ICON1(YYMMDD)
C
C     CONVERTS YYMMDD TO YYDDD
C
c     IMPLICIT INTEGER(A-Z)
c     DIMENSION NUM(12)
c     DATA NUM/0,31,59,90,120,151,181,212,243,273,304,334/
C
c     YEAR=MOD(YYMMDD/10000,100)
c     MONTH=MOD(YYMMDD/100,100)
c     DAY=MOD(YYMMDD,100)
c     IF(MONTH.LT.0.OR.MONTH.GT.12)MONTH=1
c     JULDAY=DAY+NUM(MONTH)
c     IF(MOD(YEAR,4).EQ.0.AND.MONTH.GT.2) JULDAY=JULDAY+1
c     ICON1=1000*YEAR+JULDAY
c     RETURN
c     END
C
C MRNLLXYZ MB   09/15/83; BYPASS GEOLAT & MAKE WEST = +
C MRLLXYZ  MB    7/09/82;  CNVERT LAT/LON TO/FROM EARTH-CENTERED X,Y,Z
c     SUBROUTINE GMSLLXYZ(XLAT,XLON,X,Y,Z)
C-----CONVERT LAT,LON TO EARTH CENTERED X,Y,Z
C     (DALY, 1978)
C-----XLAT,XLON ARE IN DEGREES, WITH NORTH AND WEST POSITIVE
C-----X,Y,Z ARE GIVEN IN KM. THEY ARE THE COORDINATES IN A RECTANGULAR
C        FRAME WITH ORIGIN AT THE EARTH CENTER, WHOSE POSITIVE
C        X-AXIS PIERCES THE EQUATOR AT LON 0 DEG, WHOSE POSITIVE Y-AXIS
C        PIERCES THE EQUATOR AT LON 90 DEG, AND WHOSE POSITIVE Z-AXIS
C        INTERSECTS THE NORTH POLE.
c     AB=40546851.22
c     ASQ=40683833.48
c     BSQ=40410330.18
c     R=6371.221
c     RSQ=R*R
c     RDPDG=1.745329252E-02
c     YLAT=RDPDG*XLAT
C-----CONVERT TO GEOCENTRIC (SPHERICAL) LATITUDE
CCC     YLAT=GEOLAT(YLAT,1)
c     YLAT=ATAN2(BSQ*SIN(YLAT),ASQ*COS(YLAT))
c     YLON=-RDPDG*XLON
c     SNLT=SIN(YLAT)
c     CSLT=COS(YLAT)
c     CSLN=COS(YLON)
c     SNLN=SIN(YLON)
c     TNLT=(SNLT/CSLT)**2
c     R=AB*SQRT((1.0+TNLT)/(BSQ+ASQ*TNLT))
c     X=R*CSLT*CSLN
c     Y=R*CSLT*SNLN
c     Z=R*SNLT
c     RETURN
c     END
c     SUBROUTINE GMSXYZLL(X,Y,Z,XLAT,XLON)
C-----CONVERT EARTH-CENTERED X,Y,Z TO LAT & LON
C-----X,Y,Z ARE GIVEN IN KM. THEY ARE THE COORDINATES IN A RECTANGULAR
C        COORDINATE SYSTEM WITH ORIGIN AT THE EARTH CENTER, WHOSE POS.
C        X-AXIS PIERCES THE EQUATOR AT LON 0 DEG, WHOSE POSITIVE Y-AXIS
C        PIERCES THE EQUATOR AT LON 90 DEG, AND WHOSE POSITIVE Z-AXIS
C        INTERSECTS THE NORTH POLE.
C-----XLAT,XLON ARE IN DEGREES, WITH NORTH AND WEST POSITIVE
C
c     ASQ=40683833.48
c     BSQ=40410330.18
c     RDPDG=1.745329252E-02
C
c     XLAT=100.0
c     XLON=200.0
c     IF(X.EQ.0..AND.Y.EQ.0..AND.Z.EQ.0.) GO TO 90
c     A=ATAN(Z/SQRT(X*X+Y*Y))
C-----CONVERT TO GEODETIC LATITUDE
CCC     XLAT=GEOLAT(ATAN(Z/SQRT(X*X+Y*Y)),2)/RDPDG
c     XLAT=ATAN2(ASQ*SIN(A),BSQ*COS(A))/RDPDG
c     XLON=-ATAN2(Y,X)/RDPDG
c  90 RETURN
c     END


"!" !%!&)$+#("( %/-$,$-1&/5&2-)0-'"%!&*#))-,,.4*25/#8**#'2--5(8(+35#,.46&0?;C?MASQ9=2FOPEINVUVE<923);+,<<9H2A8+)&$>$97.+=:HD;9?()'131::37/2@<+3.?7633#@*/&*)+9%--,.1+5553154.0(.43818+<02/?9KZV\rYlZUJDPK/;.$.*,/47)9236'/54"/B5374,/?+5B2-48=/5@5.,8'C-=(291+A@)7*+36>855:9=33;849;4:+'7*770J7K:WEAF;C1213%6..1(%.-4,6/;/3.%3.+"5196-7550B@<3)/-)55":,2('%$/(206>02@5-8?A4ABE@751<.$.323!%8 .)# !).!-&./,&,6%(-"2%#1*$%%,##(%3'// $&0++*&-#,%/.2A66KKFA57541"&3-&+&/"'.#*9+:422.;!,0#+2"3*7("")  $+#,"&(&#*##$)#$* -;4<<F?C*4'*-!%# $&!)&&&#"!%!##%(,*/7@4-5.@;G*- "%!"((&(##&.$&!##($*'&*-/+.,,$%#+#$)'(3+!#

 %!)(;+'+4*3.%))

	 +/&*0G2::FC.094)


!
!  Copyright 2017-2019 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
module structure_opt_sub
  implicit none
  real(8),allocatable :: r1_opt(:),r2_opt(:)
  real(8),allocatable :: H_opt(:,:),H_opt_temp(:,:)
contains
  !=======================================================================
  !==============================================================initilize
  subroutine structure_opt_ini(iMI_opt)
    use salmon_parallel, only: nproc_id_global
    use salmon_communication, only: comm_is_root
    implicit none
    integer,intent(in) :: iMI_opt
    allocate(r1_opt(3*iMI_opt),r2_opt(3*iMI_opt))
    allocate(H_opt(3*iMI_opt,3*iMI_opt),H_opt_temp(3*iMI_opt,3*iMI_opt))
    r1_opt(:)=0.0d0; r2_opt(:)=0.0d0;
    H_opt(:,:)=0.0d0; H_opt_temp(:,:)=0.0d0;
    if(comm_is_root(nproc_id_global))then
      write(*,*) "===== Grand State Optimization Start ====="
      write(*,*) "       (Quasi-Newton method using Force only)       "
    end if
  end subroutine structure_opt_ini
  !=======================================================================
  !======================================================convergence check
  subroutine structure_opt_check(iMI_opt,iopt,itranc,rforce_opt)
    use salmon_global, only: convrg_opt_fmax,unit_system,flag_geo_opt_atom
    use salmon_parallel, only: nproc_id_global,nproc_group_global
    use salmon_communication, only: comm_is_root,comm_bcast
    implicit none
    integer,intent(in) :: iMI_opt,iopt
    integer,intent(inout) :: itranc
    real(8),intent(in) :: rforce_opt(3,iMI_opt)
    real(8),parameter :: a_B=0.529177d0,Ry=13.6058d0
    integer :: iatom,iatom_count
    real(8) :: fabs,fmax,fave
    fmax=0.0d0; fave= 0d0;
    iatom_count=0
    do iatom=1,iMI_opt
      if(flag_geo_opt_atom(iatom)=='y') then
        iatom_count=iatom_count+1
        fabs=rforce_opt(1,iatom)**2.0d0+rforce_opt(2,iatom)**2.0d0+rforce_opt(3,iatom)**2.0d0
        fave=fave+fabs
        if(fabs>=fmax) fmax=fabs
      end if
    enddo
    select case(unit_system)
    case('au','a.u.')
      fmax = sqrt(fmax)
      fave = sqrt(fave/iatom_count)
    case('A_eV_fs')
      fmax = sqrt(fmax)*2.d0*Ry/a_B
      fave = sqrt(fave/iatom_count)*2.d0*Ry/a_B
    end select
    if(comm_is_root(nproc_id_global))then
      write(*,*) " Max-force=",fmax, "  Mean-force=",fave
      write(*,*) "==================================================="
      write(*,*) "Quasi-Newton Optimization Step = ", iopt
      if(fmax<=convrg_opt_fmax) itranc=1;
    end if
    call comm_bcast(itranc,nproc_group_global)
  end subroutine structure_opt_check
  !=======================================================================
  !===========================================================optimization
  subroutine structure_opt(iMI_opt,iopt,rforce_opt,Rion_opt)
    use salmon_global, only: flag_geo_opt_atom
    use salmon_parallel, only: nproc_group_global
    use salmon_communication, only: comm_bcast
    implicit none
    integer,intent(in) :: iMI_opt,iopt
    real(8),intent(in) :: rforce_opt(3,iMI_opt)
    real(8),intent(inout) :: Rion_opt(3,iMI_opt)
    real(8), parameter :: alpha=1.0d0,theta_opt=1.0d0  !theta_opt=0.0d0:DFP,theta_opt=1.0d0:BFGS in Quasi_Newton method
    integer :: ii,ij,icount_opt,iatom
    real(8) :: const1_opt,const2_opt
    real(8) :: rforce_1d(3*iMI_opt),del_Rion_1d(3*iMI_opt),optmat_1d(3*iMI_opt)
    real(8) :: del_Rion(3,iMI_opt)
    real(8) :: optmat1_2d((3*iMI_opt),(3*iMI_opt)),optmat2_2d((3*iMI_opt),(3*iMI_opt)),optmat3_2d((3*iMI_opt),(3*iMI_opt))
    !transrate rforce to rforce_1d
    icount_opt=1
    do iatom=1,iMI_opt
      do ii=1,3
        rforce_1d(icount_opt)=rforce_opt(ii,iatom)
        icount_opt=icount_opt+1
      end do
    end do
    if(iopt==1)then
      !update H_opt
      do ii=1,(3*iMI_opt)
        do ij=1,(3*iMI_opt)
          if(ii==ij)then
            H_opt(ii,ij)=1.0d0
          else
            H_opt(ii,ij)=0.0d0
          end if
          H_opt_temp(ii,ij)=H_opt(ii,ij)
        end do
      end do
    else
      !update r2_opt
      r2_opt=-(rforce_1d-r2_opt)
      !prepare const and matrix
      call dgemm('n','n',1,1,(3*iMI_opt),1.0d0,r1_opt,1,r2_opt,(3*iMI_opt),0.0d0,const1_opt,1)
      call dgemm('n','n',(3*iMI_opt),1,(3*iMI_opt),1.0d0,H_opt,(3*iMI_opt),r2_opt,(3*iMI_opt),0.0d0,optmat_1d,(3*iMI_opt))
      call dgemm('n','n',1,1,(3*iMI_opt),1.0d0,r2_opt,1,optmat_1d,(3*iMI_opt),0.0d0,const2_opt,1)
      call dgemm('n','n',(3*iMI_opt),(3*iMI_opt),1,1.0d0,r1_opt,(3*iMI_opt),r1_opt,1,0.0d0,optmat1_2d,(3*iMI_opt))
      !update H_opt
      H_opt=H_opt_temp+((const1_opt+theta_opt*const2_opt)/(const1_opt**2.0d0))*optmat1_2d
      if(theta_opt==0.0d0)then
        !theta_opt=0.0d0:DFP
        call dgemm('n','n',(3*iMI_opt),(3*iMI_opt),1,1.0d0,optmat_1d,(3*iMI_opt),optmat_1d,1,0.0d0,optmat2_2d,(3*iMI_opt))
        H_opt=H_opt-(1.0d0/const2_opt)*optmat2_2d
      elseif(theta_opt==1.0d0)then
        !theta_opt=1.0d0:BFGS
        call dgemm('n','n',(3*iMI_opt),(3*iMI_opt),1,1.0d0,optmat_1d,(3*iMI_opt),r1_opt,1,0.0d0,optmat2_2d,(3*iMI_opt))
        call dgemm('n','n',(3*iMI_opt),(3*iMI_opt),1,1.0d0,r1_opt,(3*iMI_opt),optmat_1d,1,0.0d0,optmat3_2d,(3*iMI_opt))
        H_opt=H_opt-(theta_opt/const1_opt)*(optmat2_2d+optmat3_2d)
      endif
      !update H_opt_temp
      H_opt_temp=H_opt
    end if
    !update del_Rion_1d and del_Rion
    del_Rion_1d(:)=0.0d0;
    call dgemm('n','n',(3*iMI_opt),1,(3*iMI_opt),1.0d0,H_opt,(3*iMI_opt),rforce_1d,(3*iMI_opt),0.0d0,del_Rion_1d,(3*iMI_opt))
    do iatom=1,iMI_opt
      del_Rion(1:3,iatom)=del_Rion_1d((1+3*(iatom-1)):(3+3*(iatom-1)))
    end do
    !update r1_opt,r2_opt
    r1_opt=alpha*del_Rion_1d
    r2_opt=rforce_1d
    !update Rion
    do iatom=1,iMI_opt
      if(flag_geo_opt_atom(iatom)=='y') then
        Rion_opt(1:3,iatom)=Rion_opt(1:3,iatom)+alpha*del_Rion(1:3,iatom)
      end if
    end do
    call comm_bcast(Rion_opt,nproc_group_global)
  end subroutine structure_opt
  !=======================================================================
  !===============================================================finilize
  subroutine structure_opt_fin
    use salmon_parallel, only: nproc_id_global
    use salmon_communication, only: comm_is_root
    implicit none
    deallocate(r1_opt,r2_opt)
    deallocate(H_opt,H_opt_temp)
    if(comm_is_root(nproc_id_global)) write(*,*) "Optimization Converged"
  end subroutine structure_opt_fin
end module structure_opt_sub