!+ Program to merge a SAMSON field on to a background.
!
! Method:
!	Two SAMSON files are read, one giving the background field
!	and the other the field to be merged. Options for merging
!	are obtained and the merged field is written out.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!	Version		Date		Comment
!	1.0		12-04-95	First Version under RCS
!					(J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77 with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
      PROGRAM MERGE
!
!
!
      IMPLICIT NONE
!
!
!     INCLUDE HEADER FILES.
      INCLUDE 'incl/samson_parm.ecf'
      INCLUDE 'incl/samson_pstar.ecf'
      INCLUDE 'incl/dimensions_field.ucf'
      INCLUDE 'incl/def_std_io.icf'
      INCLUDE 'incl/interp_mode.pcf'
      INCLUDE 'incl/prec_machine.ucf'
      INCLUDE 'incl/precision.pcf'
      INCLUDE 'incl/error.pcf'
      INCLUDE 'incl/method_merge.pcf'
!
!     DECLARATION OF VARIABLES.
      INTEGER
     &     IERR
!             ERROR FLAG
     &   , IOS
!             I/O ERROR FLAG
     &   , I
!             LOOP VARIABLE
     &   , L
!             LOOP VARIABLE
     &   , N_PROFILE
!             NUMBER OF PROFILES
     &   , N_PROFILE_FRONT
!             NUMBER OF PROFILES IN MERGING FIELD
     &   , N_LEVEL_FRONT
!             NUMBER OF LEVELS IN MERGING FIELD
     &   , N_LEVEL_BACK
!             NUMBER OF LEVELS IN BACKGROUND
     &   , N_LEVEL_COMPOSITE
!             NUMBER OF LEVELS IN COMPOSITE
     &   , I_METHOD
!             METHOD OF MERGING
     &   , I_MODE
!             FITTING MODE
      LOGICAL
     &     L_SPLINED_FRONT
!             MERGING SPLINE FLAG
     &   , L_SPLINED_BACK
!             BACKGROUND SPLINE FLAG
     &   , L_TOP_ONLY
!             LOGICAL TO MERGE ONLY TOP
!
      LOGICAL
     &     LOCK_CODE
!             LOGICAL TO FORBID INTERACTIVE LOOPING
      EXTERNAL
     &     LOCK_CODE
!
      CHARACTER
     &     FILE_FRONT*80
!             FILE TO BE MERGED
     &   , FILE_BACK*80
!             BACKGROUND FILE
     &   , FILE_COMPOSITE*80
!             COMPOSITE FILE
     &   , TITLE_FRONT*80
!             FILE TO BE MERGED
     &   , TITLE_BACK*80
!             BACKGROUND FILE
     &   , TITLE_COMPOSITE*80
!             COMPOSITE FILE
     &   , CHAR_YN*1
!             CHARACTER RESPONSE VARIABLE
      REAL*8
     &     FIELD_FRONT(NPD_PROFILE, NPD_LAYER+1)
!             FIELD TO BE MERGED
     &   , FIELD_BACK(NPD_PROFILE, NPD_LAYER+1)
!             BACKGROUND FIELD
     &   , FIELD_COMPOSITE(NPD_PROFILE, NPD_LAYER+1)
!             COMPOSITE FIELD
      REAL*8
     &     P_FRONT_LOW
!             LOW PRESSURE IN MERGED FIELD
     &   , P_FRONT_HIGH
!             HIGH PRESSURE IN MERGED FIELD
     &   , P_MERGE_LOW
!             LOW MERGING PRESSURE
     &   , P_MERGE_HIGH
!             HIGH MERGING PRESSURE
     &   , P_FRONT(NPD_LAYER+1)
!             PRESSURE IN MERGING FIELD
     &   , P_BACK(NPD_LAYER+1)
!             PRESSURE IN BACKGROUND FIELD
     &   , PSTAR
!             SURFACE PRESSURE
     &   , A_FRONT(NPD_LAYER+1)
!             DATA IN MERGING FIELD
     &   , A_BACK(NPD_LAYER+1)
!             DATA IN BACKGROUND FIELD
     &   , P_COMPOSITE(NPD_LAYER+1)
!             PRESSURE IN COMPOSITE FIELD
     &   , FIELD_FRONT_INT
!             INTERPOLATED MERGING VALUE
     &   , FIELD_BACK_INT
!             INTERPOLATED BACKGROUND VALUE
     &   , WEIGHT_FRONT
!             WEIGHT FOR MERGING FIELD
     &   , WEIGHT_BACK
!             WEIGHT FOR BACKGROUND FIELD
     &   , PP
!             TEMPORARY PRESSURE VARIABLE
      REAL*8
     &     X_FRONT(NPD_LAYER+1)
!             ABSCISSA FOR MERGED FIELD
     &  ,  Y_FRONT(NPD_LAYER+1)
!             ORDINATE FOR MERGED FIELD
     &  ,  Y2_FRONT(NPD_LAYER+1)
!             2ND-DERIVATIVE FOR MERGED FIELD
     &  ,  X_BACK(NPD_LAYER+1)
!             ABSCISSA FOR BACKGROUND FIELD
     &  ,  Y_BACK(NPD_LAYER+1)
!             ORDINATE FOR BACKGROUND FIELD
     &  ,  Y2_BACK(NPD_LAYER+1)
!             2ND-DERIVATIVE FOR BACKGROUND FIELD
     &  ,  WORK(NPD_LAYER+1)
!             WORKING ARRAY
!
!     SUBROUTINES CALLED:
      EXTERNAL
     &     READ_SAMSON_FIELD, MERGE_PRESSURE, INTERPOLATE_P
     &   , WRITE_SAMSON_FIELD
!
!
      DATA PSTAR/PSTAR_DEFAULT/
!
!
!
      WRITE(IU_USER, '(/A)')
     &   'ENTER NAME OF BACKGROUND FIELD.'
      READ(IU_STDIN, '(A)') FILE_BACK
      CALL READ_SAMSON_FIELD(IERR, .TRUE., .FALSE.
     &   , FILE_BACK, TITLE_BACK
     &   , N_PROFILE, N_LEVEL_BACK, P_BACK, PSTAR, FIELD_BACK)
      IF (IERR.NE.I_NORMAL) STOP
      N_LEVEL_BACK=N_LEVEL_BACK+1
!
!     READ THE FIELD TO BE MERGED IN.
      WRITE(IU_USER, '(/A)') 'ENTER NAME OF FILE CONTAINING FIELD '
     &   //'TO BE MERGED.'
      READ(IU_STDIN, '(A)') file_front
      CALL READ_SAMSON_FIELD(IERR, .TRUE., .FALSE.
     &   , FILE_FRONT, TITLE_FRONT
     &   , N_PROFILE_FRONT, N_LEVEL_FRONT, P_FRONT, PSTAR, FIELD_FRONT)
      IF (IERR.NE.I_NORMAL) THEN
         STOP
      ENDIF
      IF (N_PROFILE_FRONT.NE.N_PROFILE) THEN
         WRITE(IU_ERR, '(/A)') 
     &      '*** ERROR: NUMBER OF PROFILES IN MERGING FILE '
     &      //'DOES NOT MATCH BACKGROUND NUMBER.'
         IERR=I_ERR_FATAL
         STOP
      ENDIF
      N_LEVEL_FRONT=N_LEVEL_FRONT+1
      P_FRONT_LOW=P_FRONT(1)
      P_FRONT_HIGH=P_FRONT(N_LEVEL_FRONT)
      WRITE(IU_USER, '(A)')
     &   'THIS PROFILE CONTAINS DATA BETWEEN PRESSURE LEVELS: '
      WRITE(IU_USER, '(1PE12.5, A9, 1PE12.5, A4)')
     &   P_FRONT_LOW, ' Pa, AND ', P_FRONT_HIGH
     &   , ' Pa.'
!
!     DETERMINE WHETHER ONLY THE TOP SHOULD BE MERGED.
      WRITE(IU_USER, '(/A)')
     &   'DO YOU WISH TO MERGE ONLY AT THE TOP? (Y/N)'
1     READ(IU_STDIN, '(A)') CHAR_YN
      IF ( (CHAR_YN.EQ.'N').OR.(CHAR_YN.EQ.'n') ) THEN
         L_TOP_ONLY=.FALSE.
      ELSE IF ( (CHAR_YN.EQ.'Y').OR.(CHAR_YN.EQ.'y') ) THEN
         L_TOP_ONLY=.TRUE.
      ELSE
         WRITE(IU_ERR, '(A)') '+++ INVALID RESPONSE:'
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error_main.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RE-ENTER.'
            GOTO 1
         ENDIF
      ENDIF
!
!     DETERMINE THE METHOD OF MERGING.
      WRITE(IU_USER, '(/A)') 'ENTER THE METHOD OF MERGING DATA.'
2     READ(IU_STDIN, *, IOSTAT=IOS) I_METHOD
      IF (IOS.NE.0) THEN
         WRITE(IU_ERR, '(A)') '+++ILLEGAL INPUT:'
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error_main.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RE-ENTER'
            GOTO 2
         ENDIF
      ENDIF
      IF ( (I_METHOD.LT.1).OR.(I_METHOD.GT.P_METHOD_MERGE) ) THEN
         WRITE(IU_ERR, '(A)') '+++ INPUT OUT OF RANGE:'
         IF (LOCK_CODE(.TRUE.)) THEN
            INCLUDE 'batch_error_main.finc'
         ELSE
            WRITE(IU_USER, '(A)') 'PLEASE RE-ENTER'
            GOTO 2
         ENDIF
      ENDIF
!
      IF (I_METHOD.EQ.IP_MERGE_LINEAR) THEN
         WRITE(IU_USER, '(A)') 'ENTER MERGING PRESSURES.'
3        READ(IU_STDIN, *, IOSTAT=IOS) P_MERGE_LOW, P_MERGE_HIGH
         IF (IOS.NE.0) THEN
            WRITE(IU_ERR, '(A)') '+++ UNRECOGNIZED RESPONSE:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE RETYPE.'
               GOTO 3
            ENDIF
         ENDIF
         IF (P_MERGE_HIGH.LT.P_MERGE_LOW) THEN
            WRITE(IU_ERR, '(A)') '+++ UNSUITABLE MERGING PRESSURES:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
               GOTO 3
            ENDIF
         ENDIF
         IF (P_MERGE_LOW.LT.P_FRONT_LOW) THEN
            IF (P_FRONT_LOW.GT.P_BACK(1)) THEN
               WRITE(IU_ERR, '(A)') '+++ UNSUITABLE MERGING PRESSURES:'
               IF (LOCK_CODE(.TRUE.)) THEN
                  INCLUDE 'batch_error_main.finc'
               ELSE
                  WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
                  GOTO 3
               ENDIF
            ELSE
               P_MERGE_LOW=P_FRONT_LOW
            ENDIF
         ENDIF
         IF (P_MERGE_HIGH.GT.P_FRONT_HIGH) THEN
            IF (P_FRONT_HIGH.LT.P_BACK(N_LEVEL_BACK)) THEN
               WRITE(IU_ERR, '(A)') 'UNSUITABLE MERGING PRESSURES:'
               IF (LOCK_CODE(.TRUE.)) THEN
                  INCLUDE 'batch_error_main.finc'
               ELSE
                  WRITE(IU_USER, '(A)') 'PLEASE REENTER.'
                  GOTO 3
               ENDIF
            ELSE
               P_MERGE_HIGH=P_FRONT_HIGH
            ENDIF
         ENDIF
!
!        IN THIS CASE AN INTERPOLATION RULE IS REQUIRED.
         WRITE(IU_USER, '(/A)') 'ENTER MODE OF INTERPOLATION.'
4        READ(IU_STDIN, *, IOSTAT=IOS) I_MODE
         IF (IOS.NE.0) THEN
            WRITE(IU_ERR, '(A)') '+++ UNRECOGNIZED RESPONSE:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE RE-ENTER.'
               GOTO 4
            ENDIF
         ENDIF
         IF ( (I_MODE.NE.IP_1_LIN_LIN).AND.
     &        (I_MODE.NE.IP_1_LOG_LIN).AND.
     &        (I_MODE.NE.IP_1_LIN_LOG).AND.
     &        (I_MODE.NE.IP_1_LOG_LOG).AND.
     &        (I_MODE.NE.IP_3_LIN_LIN).AND.
     &        (I_MODE.NE.IP_3_LOG_LIN).AND.
     &        (I_MODE.NE.IP_3_LIN_LOG).AND.
     &        (I_MODE.NE.IP_3_LOG_LOG) ) THEN
            WRITE(IU_ERR, '(A)') '+++ UNSUPPORTED MODE:'
            IF (LOCK_CODE(.TRUE.)) THEN
               INCLUDE 'batch_error_main.finc'
            ELSE
               WRITE(IU_USER, '(A)') 'PLEASE RE-ENTER.'
               GOTO 4
            ENDIF
         ENDIF
      ELSE
!        SET A DEFAULT MODE IN THESE CASES.
         I_MODE=IP_1_LIN_LIN
      ENDIF
!
!     CONSTRUCT THE MERGED PRESSURE FIELD.
      CALL MERGE_PRESSURE(IERR
     &   , N_LEVEL_FRONT, P_FRONT, N_LEVEL_BACK, P_BACK
     &   , N_LEVEL_COMPOSITE, P_COMPOSITE
     &   , P_FRONT_LOW, P_FRONT_HIGH
     &   , L_TOP_ONLY
     &   )
      IF (IERR.NE.I_NORMAL) STOP
!
!     WORK OUT THE INTERPOLATED FIELDS IN THE MERGED GRID
      DO L=1, N_PROFILE
         DO I=1, N_LEVEL_FRONT
            A_FRONT(I)=FIELD_FRONT(L, I)
         ENDDO
         DO I=1, N_LEVEL_BACK
            A_BACK(I)=FIELD_BACK(L, I)
         ENDDO
      ENDDO
      DO I=1, N_LEVEL_COMPOSITE
         PP=P_COMPOSITE(I)
         IF (I_METHOD.EQ.IP_MERGE_DIRECT) THEN
            IF ( (PP.LT.P_FRONT_LOW).OR.(PP.GT.P_FRONT_HIGH) ) THEN
               WEIGHT_FRONT=0.0D+00
            ELSE
               WEIGHT_FRONT=1.0D+00
            ENDIF
            WEIGHT_BACK=1.0D+00-WEIGHT_FRONT
         ELSE IF (I_METHOD.EQ.IP_MERGE_LINEAR) THEN
            IF ( (PP.LT.P_FRONT_LOW).OR.(PP.GT.P_FRONT_HIGH) ) THEN
               WEIGHT_FRONT=0.0D+00
            ELSE IF ( (PP.GE.P_FRONT_LOW)
     &            .AND.(PP.LT.P_MERGE_LOW) ) THEN
               IF (ABS(P_MERGE_LOW-P_FRONT_LOW).GT.TOL_DIV) THEN
                  WEIGHT_FRONT=(PP-P_FRONT_LOW)
     &               /(P_MERGE_LOW-P_FRONT_LOW)
               ELSE
!                 THIS SITUATION ARISES ONLY IN THE EXCEPTIONAL CASE
!                 OF NON_OVERLAPPING DATA.
                  WEIGHT_FRONT=1.0D+00
               ENDIF
            ELSE IF ( (PP.GE.P_MERGE_LOW)
     &            .AND.(PP.LT.P_MERGE_HIGH) ) THEN
               WEIGHT_FRONT=1.0D+00
            ELSE IF ( (PP.GT.P_MERGE_HIGH)
     &            .AND.(PP.LE.P_FRONT_HIGH) ) THEN
               IF (ABS(P_MERGE_HIGH-P_FRONT_HIGH).GT.TOL_DIV) THEN
                  WEIGHT_FRONT=(P_FRONT_HIGH-PP)
     &               /(P_FRONT_HIGH-P_MERGE_HIGH)
               ELSE
!                 THIS SITUATION ARISES ONLY IN THE EXCEPTIONAL CASE
!                 OF NON_OVERLAPPING DATA.
                  WEIGHT_FRONT=1.0D+00
               ENDIF
            ENDIF
            WEIGHT_BACK=1.0D+00-WEIGHT_FRONT
         ELSE IF (I_METHOD.EQ.IP_MERGE_ZERO) THEN
            IF ( (PP.GE.P_FRONT_LOW).AND.(PP.LE.P_FRONT_HIGH) ) THEN
               WEIGHT_FRONT=1.0D+00
            ELSE
               WEIGHT_FRONT=0.0D+00
            ENDIF
            WEIGHT_BACK=0.0D+00
         ENDIF
!
         DO L=1, N_PROFILE
!           INTERPOLATE THE FRONT AND BACK FIELDS.
            IF ( (PP.LT.P_FRONT_LOW).OR.(PP.GT.P_FRONT_HIGH) ) THEN
               FIELD_FRONT_INT=0.0D+00
            ELSE
               CALL INTERPOLATE_P(IERR, N_LEVEL_FRONT, P_FRONT
     &            , A_FRONT, X_FRONT, Y_FRONT, Y2_FRONT, WORK
     &            , PP, FIELD_FRONT_INT
     &            , I_MODE, L_SPLINED_FRONT
     &            )
            IF (IERR.NE.I_NORMAL) STOP
            ENDIF
            CALL INTERPOLATE_P(IERR, N_LEVEL_BACK, P_BACK
     &         , A_BACK, X_BACK, Y_BACK, Y2_BACK, WORK
     &         , PP, FIELD_BACK_INT
     &         , I_MODE, L_SPLINED_BACK
     &         )
            IF (IERR.NE.I_NORMAL) STOP
            FIELD_COMPOSITE(L, I)=
     &         WEIGHT_FRONT*FIELD_FRONT_INT+WEIGHT_BACK*FIELD_BACK_INT
         ENDDO
      ENDDO
      TITLE_COMPOSITE(1:80)='Merged Field: '//TITLE_FRONT(1:66)
!

      WRITE(IU_USER, '(/A)')
     &   'ENTER NAME OF OUTPUT FILE.'
      READ(IU_STDIN, '(A)') FILE_COMPOSITE

      CALL WRITE_SAMSON_FIELD(IERR, .FALSE.
     &   , FILE_COMPOSITE, TITLE_COMPOSITE
     &   , N_PROFILE, N_LEVEL_COMPOSITE-1, P_COMPOSITE
     &   , PSTAR, FIELD_COMPOSITE)
      IF (IERR.NE.I_NORMAL) STOP
!
!
      STOP
      END
