C*************************************************************** ECLIPS
C
      SUBROUTINE ECLIPS201707 ( IDIR, IPRN, TTAG, SVBCOS, ANOON, ANIGHT,
     &                    NECLIPS, ECLSTM, ECLETM, IECLIPS, PI ,
C Jan 10, 2017
C    &                    xsv, santxyz, vsvc, beta, iblk)
     &                    xsv, santxyz, vsvc, beta, iblk, BETAINI,
C July 2017
     &                    yaw_angle)

C Jan 16, 2015
C *******************WARNING************************************
C the IIA body-x orientation (+x=> Sun) is used for all satellites, including
C IIR/IIRM. For the hardware IIR/IIRM orientation (+x=> deep space), the
C eclipsIIR.f version should be used or implemented
C
C NOTE: the IIA body-x orientation (+x=> Sun) IS NOW THE IGS STANDARD
C FOR ALL SATELLITES AND GNSS' !!!
C *************************************************************
C
C       NAME            ECLIPS (version Feb  2017)
C
C     PURPOSE   DETECT ECLIPSING & YAW ROTATE ECLIP. SATELLITES
C                       (THE INPUT BODY-X UNIT VECTOR - SANTXYZ IS YAW-ROTATED
C                        BY PHI-YANGLE (THE ECL-NOMINAL) YAW ANGLE DIFFERENCE)
C
C       COPYRIGHT       GEODETIC SURVEY DIVISION, 2011.
C                       ALL RIGHTS RESERVED.
C                       ALL TERMS AND CONDITIONS APPLY AS DETAILED IN
C                       " TERMS AND CONDITIONS FOR SOFTWARE "
C
C       CONTACT         kouba@rogers.com
C
C       UPDATE HISTORY: Aug. 23, 2011:1996-2008 W. AVERAGES of JPL REPROCESSING
C                                YRATE SOLUTIONS FOR ALL II/IIA CODED IN DATA
C                                STATEMENT, THIS ENABLES REPROCESSING FROM 1996
C                       Sep 26, 2011: 1. Corrected bug causing Block IIF shadow
C                               CROSSING MANEVURE WITH 0.06 DEG/SEC RATE EVEN
C                               FOR BETADG > 8 DEG
C                                     2. CORRECTED/improved IIA RECOVERY logic
C                       Dec 18, 2013: 1.corrected IIF night turns (USAF Doc.)
C                                     2.small neg beta IIF and small pos IIA noon turn
C                                    (wrong) directions  for |beta| < 0.9deg
C                                     3. PRN/SVN 23 IIA YBIAS= -0.5 deg up to Feb 2004
C                                     4. All the above changes labeled "C Dec 12, 2013"
C
C                      Jan 24, 2014:  NOON RECOVERY CORRECTED IF IIA/IIF's HAVE YBIAS=0
C                                    (NOT APPLICABLE CURRENTLY,POSSIBLE FOR FUTURE IIF?)
C                                    & SMALL IIA/IIF BETA IF STATEMENT SIMPLIFIED
C
C                      Jan 16, 2015: the IIA body-x orientation
C                                    (+x=>Sun) and logic is implemented also for
C                                    IIR/IIRM eclipsing (no SANTXYZ reversal )
C
C                      Mar 09, 2016 - upper limits for GLONASS PRN's -64
C
C                      Jan 10, 2017  BEIDOU (PRN: 101-136) ECLIPSING
C                                    GEO(BLK 23, 27) - ON (Orbit normal) YAW
C                                    IGEO(22,26)&MEO(21,25)-ON YAW FOR |BETA|<2DEG
C
C                      Jan 10, 2017 : GALILEO ECLIPSING ACCORDING TO:
C(https://www.gsc-europa.eu/support-to-developers/galileo-iov-satellite-metadata)
C                NOTE: SETTING BETAy=>BETA0=0deg DISABLES (ONLY) GAL/BEI ECLIPSING!
C                ANIGHT = 180+15.0 deg IS SET FOR THE GAL BETAx = 15 DEG
C
C                      Feb 27, 2017 :GPS, GLN, GAL- A POSSIBLE BETA SIGN
C                                    CHANGE DURING NOON OR SHADOW TURNS
C                                    BETAINI- TURN START BETA ANGLE SET WHEN
C                                    |BETA|=< 0.07 DEG (a beta sign change
C                                    possible), OTHERWISE, BETAINI(IPRN) = 0 .
C                                    THEN, WHEN |BETA| =< 0.07 DEG AND
C                                    BETAINI(IPRN).NE.0, BETAINI IS USED
C                                    FOR THE TURN, OTHERWISE BETA IS USED
C
C                                    ALSO: IIF YAW BIAS SET TO -0.7 DEG
C                                    AS RECOMMENDED BY KUANG AT AL (2016)
C                                    GPS Solut
C                                    DOI 10.1007/s10291-016-0562-9
C
C                                    AND ALL GPS IIA WITH BETA (0,+0.5]
C                                    HAVE NOON TURNS IN WRONG DIRECTION
C                                    DUE TO THE YAW BIAS OF +0.5 DEG
C
C     PARAMETERS        DESCRIPTION
C
C        IDIR           DIRECTION OF PROCESSING (1=FORWARD, -1=BACKWARD)
C        IPRN           SV PRN NUMBER (.LE.32 FOR GPS, .GT.32 FOR GLONASS)
C        TTAG           OBSERVATION EPOCH TIME TAG (EG SEC OF GPS WEEK)
C        SVBCOS         SV BETA ANGLE (BETWEEN SV AND SUN RADIUS) COSINE
C        ANOON          SV BETA ANGLE LIMIT (DEG) FOR A NOON TURN MANEVURE
C        ANIGHT         SV BETA ANGLE LIMIT (DEG) FOR A NIGHT SHADOW CROSSING
C        NECLIPS        NUMBER OF ECLIPSING FOR THE PRN SATELLITE
C        ECLSTM         ECLIPSE START TIME(EG SEC OF GPS WEEK)
C        ECLETM         ECLIPSE END TIME  ( "         "      )
C        IECLIPS        SV ECLIPSING (0=NO,1, 2=YES(1=night, 2=noon))
C        PI             = PI=3.1415926536D0
C        XSV(3)         SV X, Y, Z (m)(ITRF)
C        SANTXYZ        BODY-X UNIT VECTOR (ITRF)
C                       WARNING: THE IIA BODY-X ORIENTATION EXPECTED FOR THE IIR
C                        THE  BODY-X REVERSED FOR IIR (SEE BELOW) & RETURNED
C        VSVC           SV INERTIAL VELOCIRY VECTOR IN ITRF
C        BETA           90 DEG + THE SUN ANGLE WITH ORBITAL PLANE(IN RAD)
C        IBLK           SV BLOCK  1=I, 2=II, 3=IIA, IIR=(4, 5) IIF=6
C Jan 10, 2017
C                                BEI MEO= 21, 25: IGEO= 22, 26: GEO= 23, 27
C        BETAINI        INITIAL (GPS, GLN, GAL) BETA AT TURN START ONLY WHEN
C                       |BETA| =< 0.07 DEG. (MUST BE EXTERNALLY INITILIZED
C                       TO ZEROS!)
C
C        INTERNAL PARAMETRS DESCRIPTION
C Dec 12, 2013
C        YBIAS       IIA YAW BIAS= 0.5 deg SINCE NOV95,EXCEPT PRN/SVN23?
C Feb 27, 2017
C                        (ALSO USED AS BETA LIMIT FOR IIA WRONG DIR NOON
C                        TURNS)
C                    IIF YAW BIAS=-0.7 deg (USED FOR BETA LIMIT
C                        OF WRONG DIRECTION NOON TURNS)
C                        YAWBIAS= 0 DISABLES SMALL NEG BETA IIF TURNS!
C        YANGLE         THE NOMINAL YAW ANGLE
C        PHI            THE ECLIPSING YAW ANGLE
C Jan 10, 2017
C        BETA0       GAL, BEIDOU HARD CODED ECLIPS BETA LIMIT (= 2 DEG)
C                    = 0 DISABLES GAL; BEI MEO(BLK 21, 25) AND
C                    BEI IGEO(BLK 22, 26) ECLIPSING
C                    (BEI GEO(BLK 23, 27) ALWAYS USE THE ORB NORM YAW PHI=0)
C        BETAE       THE GAL MODEL SHy LIMIT
C
c REMARKS:
c SVBCOS, the COS of the angle between the sv radius vector and the sun
c radius vector, (the dot product of the above respective unit vectors),
c SVBCOS is used to test against CNOON=COS(ANOON), if sv is entering
c a noon maneuverer (i.e., SVBCOS > CNOON). The ANOON limit
c (typically < 5.7 deg), is determined within the subroutine and depends
c on the  sv yaw rate (YRATE)and GNSS (GPS or GLONASS).
c
c ANIGHT , the shadow limit is the "input " in the subroutine
c call statement, it can be hard coded as it is constant for a GNSS type,
c e.g.,
c 180.D0+-13.25D0 for GPS (IPRN [1, 32]) and 180.D0+-14.20D0 for
c GLONASS (IPRN [33,64]), resp. CNIGHT=COS(ANIGHT) is used for testing.
c When SVBCOS < CNIGHT (CNIGHT is negative and close to -1),
c the SV enters, or it is in the shadow.
C
C Jan 10, 2017
C FOR GAL (IPRN [65,100])  ANIGHT SET INTERNALLY TO 180 + 15 DEG
C         AND ANOON TO 15 DEG TO APPROXIMATE THE BETAx TURN LIMIT
C Feb 27, 2017
C FOR BEIDOU (IPRN [101, 136]) 180 + 2 DEG (USED FOR ECLIPS REPORT ONLY)
c
C *********************************************************************

C ----------------------------------------------------------------------
C Modified Version of ECLIPS.f
C ----------------------------------------------------------------------
C  Dr. Thomas Papanikolaou
C  Cooperative Research Centre for Spatial Information, Australia
C  July 2017
C ----------------------------------------------------------------------
C The current version has been modified accordingly to the modifications
C implemented in the ECLIPS (V. Dec 2013) that has been used by
C Papanikolaou and Melachroinos (2016).
C The modifications impact is given as follows:
C - GPS IIA night turn and shadow exit recovery
C - GPS IIR night turn
C - GPS noon turn
C ----------------------------------------------------------------------

      IMPLICIT NONE
C
C     MAXSAT - MAXIMUM NUMBER OF SATELLITES, CHANGED IF REQUIRED
C
      INTEGER MAXSAT
C Jan 10, 2017
C     PARAMETER (MAXSAT=64)
      PARAMETER (MAXSAT=136)
      REAL*8    BETAINI(*)
C
      INTEGER*4 IDIR, IPRN
      INTEGER*4 IECLIPS, NECLIPS(*)
C
      REAL*8    TTAG, TWOHR, HALFHR
      REAL*8    SVBCOS, PI
      REAL*8    ECLSTM(MAXSAT,*)
      REAL*8    ECLETM(MAXSAT,*)
      REAL*8    ANOON, ANIGHT
      REAL*8    CNOON, CNIGHT
      REAL*8    DTR, DTTAG
      REAL*8    XSV(*), SANTXYZ(*), VSVC(*), BETA, MURATE, YANGLE, DET,
C Jan 10, 2017
C    &          YRATE(64), BETADG, PHI, SANTX, SANTY,        v(3),r(3)
     &          YRATE(136),BETADG, PHI, SANTX, SANTY, v(3),r(3), BETA0,
C    &          SMTH, BETAE
     &          BETAE
      REAL*8    YAWEND
C Dec 12, 2013
      REAL*8 YBIAS
      INTEGER*4 IBLK(*), J, I
C
      LOGICAL   NOON, NIGHT

C 22 March 2017
      REAL*8 yaw_angle(2)

C MAX YAW RATES OF CURRENT&PAST BLOCK II/IIA's,(AVER'D 1996-2008 JPL SOLUTIONS)
C CHANGE IF REQUIRED OR INPUT IF ESTIMATED
C PRN                 01     02      03      04     05       06     07
      DATA YRATE /.1211d0,.1339d0,.123d0,.1233d0,.1180d0,.1266d0,.1269d0
C             08      09     10      11      12      13      14      15
     & ,.1033d0,.1278d0,.0978d0,0.200d0,0.199d0,0.200d0,0.0815d0,.1303d0
C PRN          16     17     18      19      20      21      22     23
     & ,.0838d0,.1401d0,.1069d0, .098d0, .103d0,0.1366d0,.1025d0,.1140d0
C PRN          24     25      26      27     28      29      30     31
     & ,.1089d0,.1001d0,.1227d0,.1194d0,.1260d0, .1228d0,.1165d0,.0969d0
C PRN         32  33-64: GLONASS RATES (DILSSNER 2010)
C
C Jan 10, 2017 - start: GALILEO ANOON of 2 DEG => YAW RATE of .203 DEG/s
C                Note: THE BEIDOU HARDWARE RATES NOT NEEDED
C    &  ,.1140d0, 32*0.250d0/
     &  ,.1140d0, 32*0.250d0, 36*0.203d0, 36*0.203d0/
C Jan 10, 2017
C     GAL  BETAy => BETA0
C     GAL  BETAx => ANOON=15DEG:  (ANIGHT-180); ANIGHT =180 + 15 DEG
C NOTE:BETA0= 0 DISABLES GALILEO AND/OR BEIDOU IGEO/MEO ECLIPSING!
       BETA0= 2.0D0
C Jan 10, 2017
C      SMTH = 258.D0
C
C  CHECK FOR BLOCK IIR AND FIX TO NOMINAL YAW RATE
      IF( IPRN .LE. 32 .AND. IBLK(IPRN).GE.4 ) YRATE(IPRN)=0.2D0
C THE NEW GPS BLK IIF YAW RATES ( DILSSNER (2010) INSIDE GNSS)
      IF( IPRN .LE. 32 .AND. IBLK(IPRN).GT.5 ) YRATE(IPRN)=0.11D0
C Dec 12, 2013
C  YBIAS=-0.5 FOR IIA (IBLK<4) PRN23 (SVN23 UP TO FEB2004,AFTER  IIR SVN60
C Feb 27, 2017
C   AND NOT USED), IIF (IBLK=6)=-0.7, USED FOR SMALL NEG BETA NOON TURNS ONLY!
      YBIAS=0.0D0
      IF(IBLK(IPRN).LE.3) YBIAS= 0.5D0
C Feb 27, 2017
C     IF(IPRN.EQ.23.OR.IBLK(IPRN).EQ.6) YBIAS=-0.5D0
C YBIAS=0 DISABLES SMALL NEGATIVE BETA IIF TURNS
C IF REQUIRED, CHANGE IIF YBIAS (BETA) LIMIT
      IF(IBLK(IPRN).EQ.6) YBIAS=-0.7D0
C Jan 10, 2017 - start
C GAL BETAX => ANIGHT
      IF(IPRN.GT.64.AND.IPRN.LE.100)ANIGHT= 180.D0 +15.D0
C BEIDOU NIGHT TURN => BETA0 DEG (FOR REPORTING ONLY)
      IF(IPRN.GT.100.AND.IPRN.LE.136)ANIGHT= 180.D0 + BETA0
C Jan 10, 2017 -end
C Init PHI
      PHI = PI/2.d0
C
      IECLIPS=0
      TWOHR = 7200.D0
      HALFHR= 1800.D0
C Jan 10, 2017 - no 1/2h extension for GALILEO
        IF(IPRN .GT.64.AND.IPRN.LE.100) HALFHR= 0.D0
      DTR=PI/180.D0
C compute the noon beta angle limit (beta zero) FOR A NOON TURN from YRATEs
C & THE ACTUAL SAT ORBIT ANGLE RATE (MURATE) (~0.00836 FOR GPS; ~ 0.00888 GLNS)
       MURATE= sqrt((VSVC(1)**2+VSVC(2)**2+VSVC(3)**2)/
     & (xsv(1)**2+xsv(2)**2+xsv(3)**2))/DTR
      ANOON=ATAN(MURATE/YRATE(IPRN))/DTR
C Jan 10, 2017
C  GAL & BEI NOON TURN LIMITS
C     IF(IPRN.GT.64.AND.IPRN.LE.100) ANOON=ANIGHT-180.d0
      IF(IPRN.GT.64.AND.IPRN.LE.136) ANOON=ANIGHT-180.d0

C July 2017
C CNOON limit extension
C      CNOON=DCOS(ANOON*DTR)
      CNOON=DCOS( (ANOON + HALFHR * MURATE) * DTR)

      CNIGHT=DCOS(ANIGHT*DTR)

C July 2017
C CNIGHT limit expansion for GPS IIA shadow exit recovery
 	  If ( IBLK(IPRN).LE.3 ) Then
		CNIGHT = DCOS( (ANIGHT + HALFHR * MURATE) * DTR)
	  End If

C
      NOON=.FALSE.
      NIGHT=.FALSE.
      BETADG = beta/DTR - 90.d0
C Mar 09, 2016
C      IF(IPRN.GT.32.AND.ABS(BETADG).LT.ANOON) THEN
       IF(IPRN.GT.32.AND.IPRN.LE.64.AND.ABS(BETADG).LT.ANOON) THEN
C GLONASS NOON TURN MODE ACORDING TO DILSSNER 2010
         YAWEND=75.D0
C  ITERATION FOR YAWEND OF THE GLONASS  NOON TURN
         DO J=1,3
           YAWEND=ABS(ATAN2(-TAN(BETADG*DTR),SIN(PI-
     &       DTR*MURATE*YAWEND/YRATE(IPRN)))/DTR -
     &       ATAN2(-TAN(BETADG*DTR),SIN(PI+
     &       DTR*MURATE*YAWEND/YRATE(IPRN)))/DTR)/2.D0
         END DO
C UPDATE ANOON, CNOON FOR NEW GLONASS NOON TURN LIMITS
          ANOON= MURATE*YAWEND/YRATE(IPRN)
          CNOON= DCOS(ANOON*DTR)
       ENDIF
C BLK IIR'S
C Jan 10, 2017 - ADD GAL & BEI
C       IF(IBLK(IPRN).EQ.4 .OR. IBLK(IPRN).EQ.5) THEN
        IF(IBLK(IPRN).EQ.4 .OR. IBLK(IPRN).EQ.5.OR.
C    &             (IPRN.GT.64.AND.IPRN.LE.100)) THEN
     &             (IPRN.GT.64.AND.IPRN.LE.136)) THEN

C July 2017
C Night turn analogous to Noon turn has been deactivated
C         CNIGHT=DCOS((ANOON+180.d0)*DTR)

C Jan 16, 2015
C NO LOMGER THE IGS STANDARD - NO IIR BODY-X REVERSAL!
C      DO J=1,3
C BODY-X U VECTOR REVERSAL FOR IIR ONLY
c       SANTXYZ(J)=-SANTXYZ(J)
C        END DO
        END IF
C
      IF (SVBCOS .LT. CNIGHT) THEN
        NIGHT=.TRUE.
      END IF
      IF (SVBCOS .GT. CNOON) THEN
        NOON=.TRUE.
      END IF
C Jan 10, 2017 - IGNORE GAL ECLIPSING FOR BETA >= BETA0!
      IF(IPRN.GT.64.AND.IPRN.LE.100.AND.ABS(BETADG).GE.BETA0 ) THEN
       NIGHT = .FALSE.
       NOON  = .FALSE.
      END IF
C
C     IF SV IN NIGHT SHADOW OR NOON TURN DURING FORWARD PASS
C     STORE START AND END TIME OF YAW MANEUVRE (FOR THE BACKWARD RUN)
C
C YAW ANLGE
      YANGLE=   acos((santxyz(1)*vsvc(1) +
     &santxyz(2)*vsvc(2)+santxyz(3)*vsvc(3))/sqrt(vsvc(1)**2+vsvc(2)**2+
     & vsvc(3)**2))/DTR
C IIR REVERSAL NO LONGER APPLICABLE/USED
C IIR YANGLE has the same sign as beta, II/IIA has the opposite sign
C Jan 16, 2015
C      IF(BETADG.LT.0.d0.AND.IBLK(IPRN).GE.4.AND.IBLK(IPRN).LE.5)
C    &            YANGLE=-YANGLE
c      IF(BETADG.GT.0.d0.AND.IBLK(IPRN).NE.4.AND.IBLK(IPRN).NE.5)
       IF(BETADG.GT.0.d0)
     &            YANGLE=-YANGLE
C
C Jan 10, 2017 - Start
C BEIDOU ON YAW(=0) FOR GEO ALWAYS and FOR IGSO & MEO when BETADG < 2 DEG
      IF(IPRN.GT.100.AND.IPRN.LE.136) THEN
       IF(IBLK(IPRN).EQ.23.OR.IBLK(IPRN).EQ.27.OR.ABS(BETADG).LE.BETA0)
     &     THEN
         DO J=1,3
C BODY-X ON(ORBIT NORMAL YAW) FOR BEIDOU GEO(BLK 23,28) OR FOR
C |BETA| =< BETA0  (BODYX =>  SAT VELOCITY (YAW PHI=0))
           SANTXYZ(J)= VSVC(J)/sqrt(VSVC(1)**2+VSVC(2)**2+VSVC(3)**2)
          ENDDO
          PHI =  0.D0
        IF (NIGHT) THEN
C BEI NIGHT ECLIPS REPORTING
c              write(*,*)"R",IPRN,TTAG,YANGLE, PHI,DET,
c     &        BETADG
             IECLIPS=1
             NECLIPS(IPRN)=1
        ENDIF
        IF(NOON) THEN
C BEI NOON ECLIPS REPORTING
c              write(*,*)"S",IPRN,TTAG,YANGLE, PHI,DET,
c     &        BETADG
             IECLIPS=2
             NECLIPS(IPRN)=1
        ENDIF
       END IF
       GOTO 1
      END IF
C Jan 10, 2017  end
      IF ( (NIGHT .OR. NOON)) THEN
       DET=SQRT((180.d0-acos(svbcos)/DTR)**2-BETADG**2)
       PHI = PI/2.d0
C Check if already after a midnight or noon
       IF(NIGHT) THEN
C Jan 16, 2015 - Start (NO IIR X-REVERSAL!)
c        IF(IBLK(IPRN).EQ.4.OR.IBLK(IPRN).EQ.5) THEN
c         IF(DABS(YANGLE).GT.90.d0) DET=-DET
c         IF(DET.NE.0.d0)PHI=ATAN2( TAN(BETADG*DTR),-SIN(-DET*DTR))/DTR
c        ELSE
C BLK IIA & GLONASS & IIR & IIF TOO !
          IF(DABS(YANGLE).LT.90.d0) DET=-DET
          IF(DET.NE.0.d0)PHI=ATAN2(-TAN(BETADG*DTR), SIN(-DET*DTR))/DTR
c        END IF
C Jan 16, 2015- end
       END IF
       IF(NOON) THEN
       DET=SQRT((acos(svbcos)*180./pi)**2-BETADG**2)
C Jan 16, 2015- start (NO IIR X-REVERSAL!)
c        IF(IBLK(IPRN).EQ.4.OR.IBLK(IPRN).EQ.5) THEN
c         IF(DABS(YANGLE).LT.90.d0) DET=-DET
c         IF(DET.NE.0.d0)PHI=ATAN2(TAN(BETADG*DTR),-SIN(PI-DET*DTR))/DTR
c        ELSE
C BLK IIA & GLONASS !
          IF(DABS(YANGLE).GT.90.d0) DET=-DET
          IF(DET.NE.0.d0)PHI=ATAN2(-TAN(BETADG*DTR),SIN(PI-DET*DTR))/DTR
c        END IF
C Jan 16, 2015 - end
       END IF

C July 2017
C Replace YANGLE value with the PHI value
      YANGLE = PHI

C ONLY FORWARD
       IF (IDIR .GT. 0 ) THEN
C
C       INITIALIZE ECLIPSE START AND TIME TAG ARRAYS
C
        IF ( NECLIPS(IPRN) .EQ. 0 ) THEN
        NECLIPS(IPRN)=NECLIPS(IPRN)+1
          ECLSTM(IPRN,NECLIPS(IPRN))=TTAG+DET/MURATE
C IIR MIDNIGHT/NOON TURN or II/IIA NOON TURN START
C for IIR/GLONAS NIGHT (turn) only makes sense when |BETADG| < ANOON!
C For IIA it gets here only when NOON is true and that happens only when |BETADG|< ANOON!
          YAWEND=ATAN(MURATE/YRATE(IPRN))/DTR
          IF((IBLK(IPRN).GT.3.AND.IBLK(IPRN).LE.5.OR.NOON).AND.
     &       ABS(BETADG).LT.YAWEND) THEN
C GLONASS
C Mar 09, 2016
C           IF(     IPRN .GT.32) THEN
C jan 10, 2017       - ALSO GAL NOON TURN TIMES(ANOON=ANIGHT-180deg)
C           IF(     IPRN .GT.32.AND.IPRN.LE.64) THEN
            IF(     IPRN .GT.32.AND.IPRN.LE.100) THEN
C GLONASS NOON TURN MODE, ANOON ACORDING TO DILSSNER ET AL 2010
             ECLSTM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))-
     &        ANOON/MURATE
             ECLETM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))+
     &        2.D0*ANOON/MURATE
            ELSE
C GPS IIA/IIR/IIF NOON OR IIR MIDNIGHT TURNs
             ECLSTM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))-
     &        ABS(BETADG)*sqrt(ANOON/ABS(BETADG)-1.d0)/MURATE
             ECLETM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))+
     &        2*ABS(BETADG)*sqrt(ANOON/ABS(BETADG)-1.d0)/MURATE
            ENDIF
          END IF
C     II/IIA SHADOW START & END TIMES
C Jan 10, 2017 - ADD GALILEO NIGHT
C         IF((IBLK(IPRN).LE.3.OR.IBLK(IPRN).GT.5).AND.NIGHT) THEN
          IF((IBLK(IPRN).LE.3.OR.IBLK(IPRN).GT.5
     &         .OR.(IPRN .GT.64.AND.IPRN.LE.100)).AND.NIGHT) THEN
           ECLSTM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))-
     &      SQRT((ANIGHT-180.d0)**2-BETADG**2)/MURATE
           ECLETM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))+
     &      2.d0*SQRT((ANIGHT-180.d0)**2-BETADG**2)/MURATE
          END IF
      END IF
C
C       UPDATE SV COSINE AND TIME TAG ARRAYS
C       (TO BE USED DURING BACKWARDS RUN)
C
        IF( (NIGHT .AND. SVBCOS .LT. CNIGHT)
     &       .OR. (NOON .AND. SVBCOS .GT. CNOON) ) THEN
          DTTAG= ABS(TTAG-ECLSTM(IPRN,NECLIPS(IPRN)))
C
C         ECLIPSE TIME IS MORE THAN 2 HOURS, THIS IS A NEW ECLIPSE!
C
C Feb 27, 2017
C SET GPS, GLN, GAL BETAINI IF APPLICABLE, I.E. FWD & |BETA| =< 0.07 DEG
            IF(IDIR.GT.0.AND.IPRN.LE.100.AND.ABS(BETADG).LE.0.07D0
     &         .AND.BETAINI(IPRN).EQ.0.D0) BETAINI(IPRN)= BETADG
         IF( DTTAG .GT. TWOHR ) THEN
          NECLIPS(IPRN)=NECLIPS(IPRN)+1
            ECLSTM(IPRN,NECLIPS(IPRN))=TTAG+DET/MURATE
C IIR MIDNIGHT/NOON TURN  or II/IIA NOON TURN START
C                                  AND GLONASS NOON
            IF(IBLK(IPRN).GT.3.AND.IBLK(IPRN).LE.5.OR.NOON) THEN
C GLONASS
C Mar 09, 2016
C            IF(IPRN.GT.32) THEN
C Jan 10, 2017 - include  ALSO GAL
C            IF(IPRN.GT.32.AND.IPRN.LE.64) THEN
             IF(IPRN.GT.32.AND.IPRN.LE.100) THEN
C GLONASS NOON TURN MODE ACORDING TO DILSSNER ET AL 2010
              ECLSTM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))-
     &          ANOON/MURATE
              ECLETM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))+
     &         2.D0*ANOON/MURATE
             ELSE
C GPS TURNS ONLY
              ECLSTM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))-
     &         ABS(BETADG)*sqrt(ANOON/ABS(BETADG)-1.d0)/MURATE
              ECLETM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))+
     &         2*ABS(BETADG)*sqrt(ANOON/ABS(BETADG)-1.d0)/MURATE
C Jan 10, 2017 - GALILEO NOON - start
              IF(IPRN .GT.64.AND.IPRN.LE.100)THEN
           ECLSTM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))-
     &      SQRT(ANOON**2-BETADG**2)/MURATE
           ECLETM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))+
     &      2.d0*SQRT(ANOON**2-BETADG**2)/MURATE
              END IF
             ENDIF
            END IF
C     II/IIA SHADOW START & END TIMES
C   & GLONASS & IIF AS WELL !
C Jan 10, 2017 - ADD GAL NIGHT
C           IF((IBLK(IPRN).LE.3.OR.IBLK(IPRN).GT.5).AND.NIGHT) THEN
            IF((IBLK(IPRN).LE.3.OR.IBLK(IPRN).GT.5
     &           .OR.(IPRN .GT.64.AND.IPRN.LE.100)).AND.NIGHT) THEN
             ECLSTM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))-
     &       SQRT((ANIGHT-180.d0)**2-BETADG**2)/MURATE
             ECLETM(IPRN,NECLIPS(IPRN))= ECLSTM(IPRN,NECLIPS(IPRN))+
     &       2.d0*SQRT((ANIGHT-180.d0)**2-BETADG**2)/MURATE
            END IF
        END IF
        ENDIF
C  END OF FORWARD (FWD) LOOP (IDIR = 1)
       ENDIF
      ENDIF
C
C     BOTH FWD (IDIR= 1) OR BWD (IDIR=-1)
C     SET ECLIPSE FLAG (1=NIGHT SHADOW, 2=NOON TURN)
C
      IF ( NECLIPS(IPRN) .NE. 0 ) THEN
C CHECK IF IPRN IS ECLIPSING AND WHICH SEQ NO (I)
        I=0
        DO J=1, NECLIPS(IPRN)
         IF( TTAG.GE.ECLSTM(IPRN,J).AND.TTAG.LE.(ECLETM(IPRN,J)+HALFHR))
     &   I= J
        END DO
C CURRENTLY NOT ECLIPSING (i=0)
        IF(I.EQ.0) GO TO 1
        IF ( TTAG .GE. ECLSTM(IPRN,I) .AND.
     &            TTAG .LE.(ECLETM(IPRN,I)+HALFHR) ) THEN
C Feb 27, 2017
C FOR GPS & GLN ONLY! USE BETAINI FOR ALL TURNS WHEN |BETADG|.LE. 0.07 DEG
C TO ENSURE NO BETA SIGN CHANGE AND IIF |START-END YAW DIFF| < 180 DEG
            IF(ABS(BETADG).LE.0.07D0.AND.IPRN.LE.64
     &         .AND.BETAINI(IPRN).NE.0.0D0) BETADG = BETAINI(IPRN)
C velocity & radius unit vectors V & R
             DO J=1,3
              V(J)=VSVC(J)/SQRT(VSVC(1)**2+VSVC(2)**2+VSVC(3)**2)
              R(J)=XSV(J)/SQRT(XSV(1)**2+XSV(2)**2+XSV(3)**2)
             END DO
C ORBIT ANGLE MU AT ECLIPSE/TURN START
             DET= MURATE*(ECLETM(IPRN,I)-
     &                        ECLSTM(IPRN,I))/2.d0
C Dec 12, 2013 - start
C YAWEND HERE - IIF SHADOW YAW RATE
C HERE |YAW start-YAW end| ALWAYS < 180 DEG DUE TO POSSIBLE USE OF BETAINI
                  YAWEND=(ATAN2(-TAN(BETADG*DTR), SIN( DET*DTR))-
     &             ATAN2(-TAN(BETADG*DTR), SIN(-DET*DTR)))/DTR/
     &                  (ECLETM(IPRN,I)-ECLSTM(IPRN,I))
c Dec 12, 2013 - end
           IF (SVBCOS .LT. 0) THEN
C SHADOW CROSSING
C BLK IIA/IIF SHADOW CROSSING
                IF(IPRN.LE.32.AND.(IBLK(IPRN).LE.3.OR.IBLK(IPRN).GT.5))
     &             THEN
                 IF(TTAG.LE.ECLETM(IPRN,I)) THEN
C IIA NIGHT TURN
                  IF(IBLK(IPRN).LE.3)
     &             PHI=ATAN2(-TAN(BETADG*DTR), SIN(-DET*DTR))/DTR

C July 2017
C Yaw-bias is replaced by the beta angle.  Case: GPS IIA for beta<0
C     &           +SIGN(YRATE(IPRN),YBIAS)*(TTAG-ECLSTM(IPRN,I))
     &         +SIGN(YRATE(IPRN),BETADG)*(TTAG-ECLSTM(IPRN,I))

c               write(*,*) iprn, phi, betadg, betaini(iprn)

C Dec 12, 2013
c    &           +SIGN(YRATE(IPRN),0.5d0)*(TTAG-ECLSTM(IPRN,I))
C IIF NIGHT TURN (DILSSNER  2010)
                   IF(IBLK(IPRN).GT.5)
     &             PHI=ATAN2(-TAN(BETADG*DTR), SIN(-DET*DTR))/DTR
C Dec 12, 2013- start
C Correct IIF  NIGHT CROSSING USING COMPUTING YAW RATE (YAWEND)
C ACCORDING TO THE USAF IIF DOCUMENT
C    &           +SIGN(0.06D0, BETADG)*(TTAG-ECLSTM(IPRN,I))
     &           +  YAWEND            *(TTAG-ECLSTM(IPRN,I))
C Dec 12, 2013 - end
                 ELSE
C **** WARNING
C IIA SHADOW EXIT RECOVERY: USING THE IIA DATA  DURING
C THE IIA RECOVERY (UP TO 30 MIN) IS NOT RECOMMENDED!
C **** WARNING
C GPS IIA  AT SHADOW EXIT
                   IF(IBLK(IPRN).LE.3)
     &             PHI=ATAN2(-TAN(BETADG*DTR), SIN(-DET*DTR))/DTR
C Dec 12, 2013
C    &          +SIGN(YRATE(IPRN),0.5d0)*(ECLETM(IPRN,I)-ECLSTM(IPRN,I))

C July 2017
C Yaw-bias is replaced by the beta angle.  Case: GPS IIA for beta<0
C     &          +SIGN(YRATE(IPRN),YBIAS)*(ECLETM(IPRN,I)-ECLSTM(IPRN,I))
     &      +SIGN(YRATE(IPRN),BETADG)*(ECLETM(IPRN,I)-ECLSTM(IPRN,I))

C GPS IIF AT SHADOW EXIT
C Dec 12, 2013
C NO NEED FOR IIF (IBLK=6) RECOVERY, ALREADY AT THE EXIT YAW!
                   IF(IBLK(IPRN).GT.5)GO TO 1
c                  IF(IBLK(IPRN).GT.5)
c    &             PHI=ATAN2(-TAN(BETADG*DTR), SIN(-DET*DTR))/DTR
C    &          +SIGN(0.06D0, BETADG)*(ECLETM(IPRN,I)-ECLSTM(IPRN,I))
C YAWEND- HERE THE ACTUAL YAW DIFFERENCE  AT THE SHADOW EXIT
                   YAWEND= YANGLE- PHI

C July 2017
C Angle reduction has been deactivated in order to avoid opposite SIGN
C                   YAWEND=DMOD(YAWEND, 360.D0)
C                   IF(ABS(YAWEND).GT.180.D0) YAWEND= YAWEND-360.D0*
C     &               YAWEND/ABS(YAWEND)

                   PHI=PHI
     &                   +SIGN(YRATE(IPRN),YAWEND)*(TTAG-ECLETM(IPRN,I))
C SANTX- THE CURRENT ANGLE DIFF, CONSISTENT WITH YAWEND
                   SANTX= YANGLE-PHI

C July 2017
C Angle reduction has been deactivated in order to avoid opposite SIGN
C                   SANTX =DMOD(SANTX , 360.D0)
C                   IF(ABS(SANTX).GT.180.D0) SANTX = SANTX -360.D0*
C     &               SANTX /ABS(SANTX )

C STOP! THE NOMINAL YAW (YANGLE) REACHED!
                  IF(ABS(SANTX).GT.ABS(YAWEND)) GOTO 1
                  IF(YAWEND.NE.0.D0.AND.((SANTX)/YAWEND).LT.0.D0) GOTO 1

C July 2017
C Angle reduction has been deactivated;
C abs(Phi)>180 may occurs during initial epochs of GPS IIA exit recovery
C SET PHI [-180,+180]
C                   PHI= DMOD(PHI, 360.D0)
C                   IF(ABS(PHI).GT.180.D0) PHI= PHI-360.D0*PHI/ABS(PHI)

                 ENDIF
                ENDIF
C GLONASS
C Mar 09, 2016
C               IF(IPRN.GT.32) THEN
                IF(IPRN.GT.32.AND.IPRN.LE.64) THEN
C GLONASS      NIGHT TURN (DILSSNER AT AL 2010 )
                 IF(TTAG.GT.ECLETM(IPRN,I)) GOTO 1
                 YAWEND=YRATE(IPRN)
                 PHI=ATAN2(-TAN(BETADG*DTR), SIN(-DET*DTR))/DTR
     &      +SIGN(YAWEND     ,BETADG)*(TTAG-ECLSTM(IPRN,I))
C YAWEND -YAW ANGLE AT THE (GLONASS) SHADOW EXIT
                  YAWEND=ATAN2(-TAN(BETADG*DTR), SIN( DET*DTR))/DTR
                 IF((YAWEND/PHI).GE.1.d0.OR.(PHI/YAWEND).LT.0.d0) THEN
                  PHI = YAWEND
                 ENDIF
                ENDIF
C Dec 12, 2013 - start
c                  IF(IPRN.LE.32.AND.IBLK(IPRN).GT.5) THEN
C GPS BLK IIF NIGHT YAW RATE(DILSSNER 2010):
c                   IF(ABS(BETADG).GT.8.D0) GO TO 1
c                  ENDIF
C Jan 10, 2017
C              IF(IBLK(IPRN).GT.3.AND.IBLK(IPRN).LE.5) THEN
              IF(IPRN.LE.32.AND.IBLK(IPRN).GT.3.AND.IBLK(IPRN).LE.5)THEN
C BLK II R SHADOW (MIDNIGHT TURN) CROSSING
C Jan 16, 2015
c               PHI=ATAN2( TAN(BETADG*DTR),-SIN(-DET*DTR))/DTR
                PHI=ATAN2(-TAN(BETADG*DTR), SIN(-DET*DTR))/DTR
     &      +SIGN(YRATE(IPRN),BETADG)*(TTAG-ECLSTM(IPRN,I))
C Jan 16, 2015
C               IF((PHI/YANGLE).GE.1.d0.OR.(PHI/YANGLE).LT.0.d0) GO TO 1
                IF((YANGLE/PHI).GE.1.d0.OR.(PHI/YANGLE).LT.0.d0) GO TO 1
               END IF
C jan 10, 2017 - GALILEO night - start
               IF(IPRN.GT.64.AND.IPRN.LE.100) THEN
C  SIN ORB ANGLE MU => YAWEND
               YAWEND=
     &         SIN((ttag-(ECLSTM(IPRN,I)+ECLETM(IPRN,I))/2)*MURATE*DTR)
C Jan 10, 2017 - start
C GAL ECLIPS MODEL: Shy => BETAE
               BETAE=0.5*(-SIGN(SIN(BETA0*DTR),BETADG)-SIN(BETADG*DTR))
     &         +0.5D0*(-SIGN(SIN(BETA0*DTR),BETADG)+SIN(BETADG*DTR))*
     &         COS(PI*ABS(YAWEND*COS(BETADG*DTR))/SIN(ANOON*DTR))
                 IF(ABS(BETADG).LT.0.07D0) THEN
C USE BETAINI IF NOT ZERO, SINCE BETA SIGN CHANGE IS POSSIBLE DURING THE
C MODEL TURN
                  IF(BETAINI(IPRN).NE.0.D0)
     &BETAE=0.5*(-SIGN(SIN(BETA0*DTR),BETAINI(IPRN))-SIN(BETADG*DTR))
     &+0.5D0*(-SIGN(SIN(BETA0*DTR),BETAINI(IPRN))+SIN(BETADG*DTR))*
     &         COS(PI*ABS(YAWEND*COS(BETADG*DTR))/SIN(ANOON*DTR))
                 ENDIF
               PHI   = ATAN2(BETAE, YAWEND*COS(BETADG*DTR))/DTR
               ENDIF
C  GALILEO night - ends
C Jan 10, 2017 - end
c              write(*,*)"R",IPRN,TTAG,YANGLE, PHI,DET,
c     & BETADG, ECLETM(IPRN,I),I
             IECLIPS=1
           ELSE
C NOON TURNS
           PHI=ATAN2(-TAN(BETADG*DTR),SIN(PI-DET*DTR))/DTR
     &      -SIGN(YRATE(IPRN),BETADG)*(TTAG-ECLSTM(IPRN,I))
C Dec 12, 2013 -start
C SMALL NEGATIVE BETA IIF OR SMALL POSITIVE IIA NOON TURN PROBLEM
C Jan 24, 2014
C               IF((IBLK(IPRN).LE.3.OR.IBLK(IPRN).EQ.6).AND.
C APPLY WRONG DIRECTIONs TO ALL IIA (IBLK.LE.3) NOON WITH BETA (0,0.5DEG) AND
C IIF (IBLK=6) NNON TURNS WITH BETA (-0.7,0) DEG
C FOR ONLY IIF WRONG NOONS, USE:
C               IF(IPRN.LE.32.AND.IBLK(IPRN).EQ.6.AND.
                IF(IPRN.LE.32.AND.
C Feb 27, 2017
C USE YBIAS AS  BETA LIMIT FOR WRONG NOON TURN DIRECTION
C    &             (BETADG*SIGN(1.D0,YBIAS)).LE.0.9D0  .AND.

C July 2017
C Deactivation of the limit of ABS(YBIAS) when close to beta sign change
C     &             (BETADG*SIGN(1.D0,YBIAS)).LE.ABS(YBIAS).AND.
     &             (BETADG*SIGN(1.D0,YBIAS)).LE.0.1D0 .AND.

     &             (BETADG*YBIAS).GT.0.0D0)                  THEN
                    PHI=ATAN2(-TAN(BETADG*DTR),SIN(PI-DET*DTR))/DTR
     &              +SIGN(YRATE(IPRN),YBIAS )*(TTAG-ECLSTM(IPRN,I))
                 ENDIF
C Dec 12, 2013 - end
                IF(IBLK(IPRN).GT.3.AND.IBLK(IPRN).LE.5) THEN
C BLK IIR NOON TURNS ONLY
C Jan 16, 2015
c                PHI=ATAN2( TAN(BETADG*DTR),-SIN(PI-DET*DTR))/DTR
c    &      -SIGN(YRATE(IPRN),BETADG)*(TTAG-ECLSTM(IPRN,I))
C IIR END TURN CHECK
C                IF((YANGLE/PHI).GE.1.d0.OR.(PHI/YANGLE).LT.0.d0) GOTO 1
                 IF((PHI/YANGLE).GE.1.d0.OR.(PHI/YANGLE).LT.0.d0) GOTO 1
                ELSE
C GLONASS END TURN CHECK
C Mar 09, 2016
C                IF(     IPRN .GT.32.AND.TTAG.GT.ECLETM(IPRN,I)) GOTO 1
C Jan 10, 2017
C        IF(IPRN.GT.32.AND.IPRN.LE.64.AND.TTAG.GT.ECLETM(IPRN,I)) GOTO 1
         IF(IPRN.GT.32.AND.IPRN.LE.100.AND.TTAG.GT.ECLETM(IPRN,I))GOTO 1
C IIA OR IIF END TURN CHECK
C Dec 12, 2013 -start
C Feb 27, 2017
C                IF(IPRN.LE.32.AND.BETADG*SIGN(1.D0,YBIAS).LE.0.9D0.AND.
                 IF(IPRN.LE.32.AND.BETADG*SIGN(1.D0,YBIAS).LE.ABS(YBIAS)
     &              .AND.
C Jan 24, 2014
C    &             BETADG*SIGN(1.D0,YBIAS).GT.0.0D0.AND.
     &             BETADG*YBIAS.GT.0.0D0.AND.
     &            (((PHI-SIGN(1.d0,YBIAS)*360.D0)/YANGLE).LE.1.d0.OR.
     &            ((PHI-SIGN(1.D0,YBIAS)*360.D0)/YANGLE).LT.0.d0))GOTO 1
C                IF(IPRN.LE.32.AND.
                 IF(IPRN.LE.32.AND.(BETADG*SIGN(1.D0,YBIAS).GT.0.7D0.OR.
C Jan 24, 2014
C    &              BETADG*SIGN(1.D0,YBIAS).LE.0.0D0).AND.
     &              BETADG*YBIAS.LE.0.0D0).AND.
     &            ((PHI/YANGLE).GE.1.d0.OR.(PHI/YANGLE).LT.0.d0)) GOTO 1
                ENDIF

C July 2017
C GPS IIA/IIF Noon turn end check
	  IF ( IBLK(IPRN)<=3 .OR. IBLK(IPRN)==6 ) THEN
         IF (ABS(YANGLE)>170.D0 .AND. ABS(YANGLE/PHI)<1.0D0)  GOTO 1
      END IF

C Jan 10, 2017 - GALILEO noon  - start
               IF(IPRN.GT.64.AND.IPRN.LE.100) THEN
C  SIN ORB ANGLE MU => YAWEND
               YAWEND= SIN(
     &         PI +(TTAG-(ECLSTM(IPRN,I)+ECLETM(IPRN,I))/2)*MURATE*DTR)
C Jan 10, 2017
C GAL ECLIPS MODEL: Shy => BETAE
               BETAE=0.5*(-SIGN(SIN(BETA0*DTR),BETADG)-SIN(BETADG*DTR))
     &         +0.5D0*(-SIGN(SIN(BETA0*DTR),BETADG)+SIN(BETADG*DTR))*
     &         COS(PI*ABS(YAWEND*COS(BETADG*DTR))/SIN(ANOON*DTR))
                 IF(ABS(BETADG).LT.0.07D0) THEN
C USE BETAINI IF NOT ZERO, SINCE BETA SIGN CHANGE IS POSSIBLE DURING THE
C MODEL TURN
                  IF(BETAINI(IPRN).NE.0.D0)
     &BETAE=0.5*(-SIGN(SIN(BETA0*DTR),BETAINI(IPRN))-SIN(BETADG*DTR))
     &+0.5D0*(-SIGN(SIN(BETA0*DTR),BETAINI(IPRN))+SIN(BETADG*DTR))*
     &         COS(PI*ABS(YAWEND*COS(BETADG*DTR))/SIN(ANOON*DTR))
                 ENDIF
               PHI   = ATAN2(BETAE, YAWEND*COS(BETADG*DTR))/DTR
C Jan 10, 2017 - end
               ENDIF
C Jan 10, 2017 - GALILEO noon  - ends
C
c              write(*,*)"S",IPRN,TTAG,YANGLE, PHI,DET,
c     & BETADG, ECLSTM(IPRN,I)
             IECLIPS=2
           END IF
C ROTATE X-VECTOR TO ECLIPSING YAW ANGLE PHI
C ECLIPSING (II/IIA) NOT TO BE USED  A HALF HR AFTER SHADOW !
       SANTX=(COS((PHI-YANGLE)*DTR)*(V(2)-V(3)*R(2)/R(3))-COS(PHI*
     & DTR)*
     &(SANTXYZ(2)-SANTXYZ(3)*R(2)/R(3)))/(SANTXYZ(1)*V(2)-SANTXYZ(2)*v(1
     &)+((SANTXYZ(2)*V(3)-SANTXYZ(3)*V(2))*R(1)+(SANTXYZ(3)*V(1)-SANTXYZ
     &(1)*V(3))*R(2))/R(3))
       SANTY = (COS(PHI*DTR) - (V(1)-V(3)*R(1)/R(3))*SANTX)/
     & (V(2)-V(3)*R(2)/R(3))
C THE BODY-X UNIT VECTOR ROTATED BY (PHI-YANGLE) RETURNED
          SANTXYZ(1)= SANTX
          SANTXYZ(2)= SANTY
          SANTXYZ(3)= (-R(1)*SANTX-R(2)*SANTY)/R(3)
      END IF
      ENDIF

C July 2017
C The output argument "yaw_angle" has been added for providing the computed
C values of the nominal yaw angle (YANGLE) and the eclipsing yaw angle (PHI)
      yaw_angle(1) = YANGLE
      yaw_angle(2) = PHI

1     RETURN
C
      END
C2345678901234567890123456789012345678901234567890123456789012345678901234567890


      SUBROUTINE ML5_0_HELAS_CALLS_AMPB_1(P,NHEL,H,IC)
C
C     Modules
C
      USE ML5_0_POLYNOMIAL_CONSTANTS
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=5)
      INTEGER    NCOMB
      PARAMETER (NCOMB=48)
      INTEGER NBORNAMPS
      PARAMETER (NBORNAMPS=8)
      INTEGER    NLOOPS, NLOOPGROUPS, NCTAMPS
      PARAMETER (NLOOPS=144, NLOOPGROUPS=77, NCTAMPS=252)
      INTEGER    NLOOPAMPS
      PARAMETER (NLOOPAMPS=396)
      INTEGER    NWAVEFUNCS,NLOOPWAVEFUNCS
      PARAMETER (NWAVEFUNCS=28,NLOOPWAVEFUNCS=267)
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
      REAL*16     MP__ZERO
      PARAMETER (MP__ZERO=0.0E0_16)
C     These are constants related to the split orders
      INTEGER    NSO, NSQUAREDSO, NAMPSO
      PARAMETER (NSO=0, NSQUAREDSO=0, NAMPSO=0)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL)
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      INTEGER H
C
C     LOCAL VARIABLES
C
      INTEGER I,J,K
      COMPLEX*16 COEFS(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)

      LOGICAL DUMMYFALSE
      DATA DUMMYFALSE/.FALSE./
C
C     GLOBAL VARIABLES
C
      INCLUDE 'coupl.inc'
      INCLUDE 'mp_coupl.inc'

      INTEGER HELOFFSET
      INTEGER GOODHEL(NCOMB)
      LOGICAL GOODAMP(NSQUAREDSO,NLOOPGROUPS)
      COMMON/ML5_0_FILTERS/GOODAMP,GOODHEL,HELOFFSET

      LOGICAL CHECKPHASE
      LOGICAL HELDOUBLECHECKED
      COMMON/ML5_0_INIT/CHECKPHASE, HELDOUBLECHECKED

      INTEGER SQSO_TARGET
      COMMON/ML5_0_SOCHOICE/SQSO_TARGET

      LOGICAL UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE,CT_REQ_SO_DONE
     $ ,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_SO_DONE
     $ ,CTCALL_REQ_SO_DONE,FILTER_SO
      COMMON/ML5_0_SO_REQS/UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE
     $ ,CT_REQ_SO_DONE,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE
     $ ,MP_LOOP_REQ_SO_DONE,CTCALL_REQ_SO_DONE,FILTER_SO

      INTEGER I_SO
      COMMON/ML5_0_I_SO/I_SO
      INTEGER I_LIB
      COMMON/ML5_0_I_LIB/I_LIB

      COMPLEX*16 AMP(NBORNAMPS)
      COMMON/ML5_0_AMPS/AMP
      COMPLEX*16 W(20,NWAVEFUNCS)
      COMMON/ML5_0_W/W

      COMPLEX*16 WL(MAXLWFSIZE,0:LOOPMAXCOEFS-1,MAXLWFSIZE,
     $ -1:NLOOPWAVEFUNCS)
      COMPLEX*16 PL(0:3,-1:NLOOPWAVEFUNCS)
      COMMON/ML5_0_WL/WL,PL

      COMPLEX*16 AMPL(3,NCTAMPS)
      COMMON/ML5_0_AMPL/AMPL

C
C     ----------
C     BEGIN CODE
C     ----------

C     The target squared split order contribution is already reached
C      if true.
      IF (FILTER_SO.AND.CT_REQ_SO_DONE) THEN
        GOTO 1001
      ENDIF

      CALL VXXXXX(P(0,1),ZERO,NHEL(1),-1*IC(1),W(1,1))
      CALL VXXXXX(P(0,2),ZERO,NHEL(2),-1*IC(2),W(1,2))
      CALL VXXXXX(P(0,3),MDL_MW,NHEL(3),+1*IC(3),W(1,3))
      CALL OXXXXX(P(0,4),MDL_MT,NHEL(4),+1*IC(4),W(1,4))
      CALL IXXXXX(P(0,5),MDL_MB,NHEL(5),-1*IC(5),W(1,5))
      CALL VVV1P0_1(W(1,1),W(1,2),GC_4,ZERO,ZERO,W(1,6))
      CALL FFV2_1(W(1,4),W(1,3),GC_11,MDL_MB,ZERO,W(1,7))
C     Amplitude(s) for born diagram with ID 1
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),GC_5,AMP(1))
      CALL FFV2_2(W(1,5),W(1,3),GC_11,MDL_MT,MDL_WT,W(1,8))
C     Amplitude(s) for born diagram with ID 2
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),GC_5,AMP(2))
      CALL FFV1_1(W(1,4),W(1,1),GC_5,MDL_MT,MDL_WT,W(1,9))
      CALL FFV1_2(W(1,5),W(1,2),GC_5,MDL_MB,ZERO,W(1,10))
C     Amplitude(s) for born diagram with ID 3
      CALL FFV2_0(W(1,10),W(1,9),W(1,3),GC_11,AMP(3))
C     Amplitude(s) for born diagram with ID 4
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),GC_5,AMP(4))
      CALL FFV1_2(W(1,5),W(1,1),GC_5,MDL_MB,ZERO,W(1,11))
      CALL FFV1_1(W(1,4),W(1,2),GC_5,MDL_MT,MDL_WT,W(1,12))
C     Amplitude(s) for born diagram with ID 5
      CALL FFV2_0(W(1,11),W(1,12),W(1,3),GC_11,AMP(5))
C     Amplitude(s) for born diagram with ID 6
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),GC_5,AMP(6))
C     Amplitude(s) for born diagram with ID 7
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),GC_5,AMP(7))
C     Amplitude(s) for born diagram with ID 8
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),GC_5,AMP(8))
      CALL FFV1_2(W(1,5),W(1,6),GC_5,MDL_MB,ZERO,W(1,13))
C     Counter-term amplitude(s) for loop diagram number 9
      CALL R2_QQ_1_R2_QQ_2_0(W(1,13),W(1,7),R2_QQQ,R2_QQB,AMPL(1,1))
      CALL R2_QQ_2_0(W(1,13),W(1,7),UV_BMASS_1EPS,AMPL(2,2))
      CALL R2_QQ_2_0(W(1,13),W(1,7),UV_BMASS,AMPL(1,3))
      CALL FFV1P0_3(W(1,5),W(1,7),GC_5,ZERO,ZERO,W(1,14))
C     Counter-term amplitude(s) for loop diagram number 10
      CALL R2_GG_1_R2_GG_2_0(W(1,6),W(1,14),R2_GGG_1,R2_GGG_2,AMPL(1,4)
     $ )
C     Counter-term amplitude(s) for loop diagram number 11
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),R2_GQQ,AMPL(1,5))
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),UV_GQQB_1EPS,AMPL(2,6))
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),UV_GQQB_1EPS,AMPL(2,7))
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),UV_GQQB_1EPS,AMPL(2,8))
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),UV_GQQB_1EPS,AMPL(2,9))
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),UV_GQQB_1EPS,AMPL(2,10))
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),UV_GQQB_1EPS,AMPL(2,11))
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),UV_GQQG_1EPS,AMPL(2,12))
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),UV_GQQB,AMPL(1,13))
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),UV_GQQT,AMPL(1,14))
      CALL FFV1_1(W(1,4),W(1,6),GC_5,MDL_MT,MDL_WT,W(1,15))
C     Counter-term amplitude(s) for loop diagram number 13
      CALL R2_QQ_1_R2_QQ_2_0(W(1,8),W(1,15),R2_QQQ,R2_QQT,AMPL(1,15))
      CALL R2_QQ_2_0(W(1,8),W(1,15),UV_TMASS_1EPS,AMPL(2,16))
      CALL R2_QQ_2_0(W(1,8),W(1,15),UV_TMASS,AMPL(1,17))
      CALL FFV1P0_3(W(1,8),W(1,4),GC_5,ZERO,ZERO,W(1,16))
C     Counter-term amplitude(s) for loop diagram number 14
      CALL R2_GG_1_R2_GG_2_0(W(1,6),W(1,16),R2_GGG_1,R2_GGG_2,AMPL(1
     $ ,18))
C     Counter-term amplitude(s) for loop diagram number 15
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),R2_GQQ,AMPL(1,19))
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),UV_GQQB_1EPS,AMPL(2,20))
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),UV_GQQB_1EPS,AMPL(2,21))
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),UV_GQQB_1EPS,AMPL(2,22))
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),UV_GQQB_1EPS,AMPL(2,23))
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),UV_GQQB_1EPS,AMPL(2,24))
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),UV_GQQB_1EPS,AMPL(2,25))
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),UV_GQQG_1EPS,AMPL(2,26))
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),UV_GQQB,AMPL(1,27))
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),UV_GQQT,AMPL(1,28))
C     Counter-term amplitude(s) for loop diagram number 17
      CALL FFV2_0(W(1,13),W(1,4),W(1,3),R2_BXTW,AMPL(1,29))
C     Counter-term amplitude(s) for loop diagram number 21
      CALL FFV2_0(W(1,5),W(1,15),W(1,3),R2_BXTW,AMPL(1,30))
      CALL FFV2_1(W(1,9),W(1,3),GC_11,MDL_MB,ZERO,W(1,17))
C     Counter-term amplitude(s) for loop diagram number 22
      CALL R2_QQ_1_R2_QQ_2_0(W(1,10),W(1,17),R2_QQQ,R2_QQB,AMPL(1,31))
      CALL R2_QQ_2_0(W(1,10),W(1,17),UV_BMASS_1EPS,AMPL(2,32))
      CALL R2_QQ_2_0(W(1,10),W(1,17),UV_BMASS,AMPL(1,33))
      CALL FFV2_2(W(1,10),W(1,3),GC_11,MDL_MT,MDL_WT,W(1,18))
C     Counter-term amplitude(s) for loop diagram number 23
      CALL R2_QQ_1_R2_QQ_2_0(W(1,18),W(1,9),R2_QQQ,R2_QQT,AMPL(1,34))
      CALL R2_QQ_2_0(W(1,18),W(1,9),UV_TMASS_1EPS,AMPL(2,35))
      CALL R2_QQ_2_0(W(1,18),W(1,9),UV_TMASS,AMPL(1,36))
C     Counter-term amplitude(s) for loop diagram number 24
      CALL FFV2_0(W(1,10),W(1,9),W(1,3),R2_BXTW,AMPL(1,37))
C     Counter-term amplitude(s) for loop diagram number 25
      CALL FFV1_0(W(1,5),W(1,17),W(1,2),R2_GQQ,AMPL(1,38))
      CALL FFV1_0(W(1,5),W(1,17),W(1,2),UV_GQQB_1EPS,AMPL(2,39))
      CALL FFV1_0(W(1,5),W(1,17),W(1,2),UV_GQQB_1EPS,AMPL(2,40))
      CALL FFV1_0(W(1,5),W(1,17),W(1,2),UV_GQQB_1EPS,AMPL(2,41))
      CALL FFV1_0(W(1,5),W(1,17),W(1,2),UV_GQQB_1EPS,AMPL(2,42))
      CALL FFV1_0(W(1,5),W(1,17),W(1,2),UV_GQQB_1EPS,AMPL(2,43))
      CALL FFV1_0(W(1,5),W(1,17),W(1,2),UV_GQQB_1EPS,AMPL(2,44))
      CALL FFV1_0(W(1,5),W(1,17),W(1,2),UV_GQQG_1EPS,AMPL(2,45))
      CALL FFV1_0(W(1,5),W(1,17),W(1,2),UV_GQQB,AMPL(1,46))
      CALL FFV1_0(W(1,5),W(1,17),W(1,2),UV_GQQT,AMPL(1,47))
C     Counter-term amplitude(s) for loop diagram number 27
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),R2_GQQ,AMPL(1,48))
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),UV_GQQB_1EPS,AMPL(2,49))
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),UV_GQQB_1EPS,AMPL(2,50))
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),UV_GQQB_1EPS,AMPL(2,51))
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),UV_GQQB_1EPS,AMPL(2,52))
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),UV_GQQB_1EPS,AMPL(2,53))
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),UV_GQQB_1EPS,AMPL(2,54))
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),UV_GQQG_1EPS,AMPL(2,55))
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),UV_GQQB,AMPL(1,56))
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),UV_GQQT,AMPL(1,57))
      CALL FFV1_1(W(1,9),W(1,2),GC_5,MDL_MT,MDL_WT,W(1,19))
C     Counter-term amplitude(s) for loop diagram number 28
      CALL R2_QQ_1_R2_QQ_2_0(W(1,8),W(1,19),R2_QQQ,R2_QQT,AMPL(1,58))
      CALL R2_QQ_2_0(W(1,8),W(1,19),UV_TMASS_1EPS,AMPL(2,59))
      CALL R2_QQ_2_0(W(1,8),W(1,19),UV_TMASS,AMPL(1,60))
      CALL FFV1_2(W(1,8),W(1,2),GC_5,MDL_MT,MDL_WT,W(1,20))
C     Counter-term amplitude(s) for loop diagram number 29
      CALL R2_QQ_1_R2_QQ_2_0(W(1,20),W(1,9),R2_QQQ,R2_QQT,AMPL(1,61))
      CALL R2_QQ_2_0(W(1,20),W(1,9),UV_TMASS_1EPS,AMPL(2,62))
      CALL R2_QQ_2_0(W(1,20),W(1,9),UV_TMASS,AMPL(1,63))
C     Counter-term amplitude(s) for loop diagram number 31
      CALL FFV2_0(W(1,5),W(1,19),W(1,3),R2_BXTW,AMPL(1,64))
      CALL FFV2_2(W(1,11),W(1,3),GC_11,MDL_MT,MDL_WT,W(1,21))
C     Counter-term amplitude(s) for loop diagram number 35
      CALL R2_QQ_1_R2_QQ_2_0(W(1,21),W(1,12),R2_QQQ,R2_QQT,AMPL(1,65))
      CALL R2_QQ_2_0(W(1,21),W(1,12),UV_TMASS_1EPS,AMPL(2,66))
      CALL R2_QQ_2_0(W(1,21),W(1,12),UV_TMASS,AMPL(1,67))
      CALL FFV2_1(W(1,12),W(1,3),GC_11,MDL_MB,ZERO,W(1,22))
C     Counter-term amplitude(s) for loop diagram number 36
      CALL R2_QQ_1_R2_QQ_2_0(W(1,11),W(1,22),R2_QQQ,R2_QQB,AMPL(1,68))
      CALL R2_QQ_2_0(W(1,11),W(1,22),UV_BMASS_1EPS,AMPL(2,69))
      CALL R2_QQ_2_0(W(1,11),W(1,22),UV_BMASS,AMPL(1,70))
C     Counter-term amplitude(s) for loop diagram number 37
      CALL FFV2_0(W(1,11),W(1,12),W(1,3),R2_BXTW,AMPL(1,71))
C     Counter-term amplitude(s) for loop diagram number 38
      CALL FFV1_0(W(1,21),W(1,4),W(1,2),R2_GQQ,AMPL(1,72))
      CALL FFV1_0(W(1,21),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,73))
      CALL FFV1_0(W(1,21),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,74))
      CALL FFV1_0(W(1,21),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,75))
      CALL FFV1_0(W(1,21),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,76))
      CALL FFV1_0(W(1,21),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,77))
      CALL FFV1_0(W(1,21),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,78))
      CALL FFV1_0(W(1,21),W(1,4),W(1,2),UV_GQQG_1EPS,AMPL(2,79))
      CALL FFV1_0(W(1,21),W(1,4),W(1,2),UV_GQQB,AMPL(1,80))
      CALL FFV1_0(W(1,21),W(1,4),W(1,2),UV_GQQT,AMPL(1,81))
C     Counter-term amplitude(s) for loop diagram number 40
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),R2_GQQ,AMPL(1,82))
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),UV_GQQB_1EPS,AMPL(2,83))
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),UV_GQQB_1EPS,AMPL(2,84))
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),UV_GQQB_1EPS,AMPL(2,85))
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),UV_GQQB_1EPS,AMPL(2,86))
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),UV_GQQB_1EPS,AMPL(2,87))
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),UV_GQQB_1EPS,AMPL(2,88))
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),UV_GQQG_1EPS,AMPL(2,89))
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),UV_GQQB,AMPL(1,90))
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),UV_GQQT,AMPL(1,91))
      CALL FFV1_2(W(1,11),W(1,2),GC_5,MDL_MB,ZERO,W(1,23))
C     Counter-term amplitude(s) for loop diagram number 41
      CALL R2_QQ_1_R2_QQ_2_0(W(1,23),W(1,7),R2_QQQ,R2_QQB,AMPL(1,92))
      CALL R2_QQ_2_0(W(1,23),W(1,7),UV_BMASS_1EPS,AMPL(2,93))
      CALL R2_QQ_2_0(W(1,23),W(1,7),UV_BMASS,AMPL(1,94))
      CALL FFV1_1(W(1,7),W(1,2),GC_5,MDL_MB,ZERO,W(1,24))
C     Counter-term amplitude(s) for loop diagram number 42
      CALL R2_QQ_1_R2_QQ_2_0(W(1,11),W(1,24),R2_QQQ,R2_QQB,AMPL(1,95))
      CALL R2_QQ_2_0(W(1,11),W(1,24),UV_BMASS_1EPS,AMPL(2,96))
      CALL R2_QQ_2_0(W(1,11),W(1,24),UV_BMASS,AMPL(1,97))
C     Counter-term amplitude(s) for loop diagram number 44
      CALL FFV2_0(W(1,23),W(1,4),W(1,3),R2_BXTW,AMPL(1,98))
C     Counter-term amplitude(s) for loop diagram number 48
      CALL FFV1_0(W(1,5),W(1,22),W(1,1),R2_GQQ,AMPL(1,99))
      CALL FFV1_0(W(1,5),W(1,22),W(1,1),UV_GQQB_1EPS,AMPL(2,100))
      CALL FFV1_0(W(1,5),W(1,22),W(1,1),UV_GQQB_1EPS,AMPL(2,101))
      CALL FFV1_0(W(1,5),W(1,22),W(1,1),UV_GQQB_1EPS,AMPL(2,102))
      CALL FFV1_0(W(1,5),W(1,22),W(1,1),UV_GQQB_1EPS,AMPL(2,103))
      CALL FFV1_0(W(1,5),W(1,22),W(1,1),UV_GQQB_1EPS,AMPL(2,104))
      CALL FFV1_0(W(1,5),W(1,22),W(1,1),UV_GQQB_1EPS,AMPL(2,105))
      CALL FFV1_0(W(1,5),W(1,22),W(1,1),UV_GQQG_1EPS,AMPL(2,106))
      CALL FFV1_0(W(1,5),W(1,22),W(1,1),UV_GQQB,AMPL(1,107))
      CALL FFV1_0(W(1,5),W(1,22),W(1,1),UV_GQQT,AMPL(1,108))
C     Counter-term amplitude(s) for loop diagram number 50
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),R2_GQQ,AMPL(1,109))
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),UV_GQQB_1EPS,AMPL(2,110))
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),UV_GQQB_1EPS,AMPL(2,111))
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),UV_GQQB_1EPS,AMPL(2,112))
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),UV_GQQB_1EPS,AMPL(2,113))
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),UV_GQQB_1EPS,AMPL(2,114))
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),UV_GQQB_1EPS,AMPL(2,115))
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),UV_GQQG_1EPS,AMPL(2,116))
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),UV_GQQB,AMPL(1,117))
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),UV_GQQT,AMPL(1,118))
C     Counter-term amplitude(s) for loop diagram number 51
      CALL FFV1_0(W(1,18),W(1,4),W(1,1),R2_GQQ,AMPL(1,119))
      CALL FFV1_0(W(1,18),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,120))
      CALL FFV1_0(W(1,18),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,121))
      CALL FFV1_0(W(1,18),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,122))
      CALL FFV1_0(W(1,18),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,123))
      CALL FFV1_0(W(1,18),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,124))
      CALL FFV1_0(W(1,18),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,125))
      CALL FFV1_0(W(1,18),W(1,4),W(1,1),UV_GQQG_1EPS,AMPL(2,126))
      CALL FFV1_0(W(1,18),W(1,4),W(1,1),UV_GQQB,AMPL(1,127))
      CALL FFV1_0(W(1,18),W(1,4),W(1,1),UV_GQQT,AMPL(1,128))
C     Counter-term amplitude(s) for loop diagram number 53
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),R2_GQQ,AMPL(1,129))
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),UV_GQQB_1EPS,AMPL(2,130))
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),UV_GQQB_1EPS,AMPL(2,131))
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),UV_GQQB_1EPS,AMPL(2,132))
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),UV_GQQB_1EPS,AMPL(2,133))
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),UV_GQQB_1EPS,AMPL(2,134))
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),UV_GQQB_1EPS,AMPL(2,135))
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),UV_GQQG_1EPS,AMPL(2,136))
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),UV_GQQB,AMPL(1,137))
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),UV_GQQT,AMPL(1,138))
C     Counter-term amplitude(s) for loop diagram number 56
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),R2_3GG,AMPL(1,139))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),UV_3GB_1EPS,AMPL(2,140))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),UV_3GB_1EPS,AMPL(2,141))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),UV_3GB_1EPS,AMPL(2,142))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),UV_3GB_1EPS,AMPL(2,143))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),UV_3GB_1EPS,AMPL(2,144))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),UV_3GB_1EPS,AMPL(2,145))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),UV_3GG_1EPS,AMPL(2,146))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),UV_3GB,AMPL(1,147))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),UV_3GT,AMPL(1,148))
C     Counter-term amplitude(s) for loop diagram number 59
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),R2_3GG,AMPL(1,149))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),UV_3GB_1EPS,AMPL(2,150))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),UV_3GB_1EPS,AMPL(2,151))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),UV_3GB_1EPS,AMPL(2,152))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),UV_3GB_1EPS,AMPL(2,153))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),UV_3GB_1EPS,AMPL(2,154))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),UV_3GB_1EPS,AMPL(2,155))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),UV_3GG_1EPS,AMPL(2,156))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),UV_3GB,AMPL(1,157))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),UV_3GT,AMPL(1,158))
C     Counter-term amplitude(s) for loop diagram number 62
      CALL FFV1_0(W(1,5),W(1,24),W(1,1),R2_GQQ,AMPL(1,159))
      CALL FFV1_0(W(1,5),W(1,24),W(1,1),UV_GQQB_1EPS,AMPL(2,160))
      CALL FFV1_0(W(1,5),W(1,24),W(1,1),UV_GQQB_1EPS,AMPL(2,161))
      CALL FFV1_0(W(1,5),W(1,24),W(1,1),UV_GQQB_1EPS,AMPL(2,162))
      CALL FFV1_0(W(1,5),W(1,24),W(1,1),UV_GQQB_1EPS,AMPL(2,163))
      CALL FFV1_0(W(1,5),W(1,24),W(1,1),UV_GQQB_1EPS,AMPL(2,164))
      CALL FFV1_0(W(1,5),W(1,24),W(1,1),UV_GQQB_1EPS,AMPL(2,165))
      CALL FFV1_0(W(1,5),W(1,24),W(1,1),UV_GQQG_1EPS,AMPL(2,166))
      CALL FFV1_0(W(1,5),W(1,24),W(1,1),UV_GQQB,AMPL(1,167))
      CALL FFV1_0(W(1,5),W(1,24),W(1,1),UV_GQQT,AMPL(1,168))
C     Counter-term amplitude(s) for loop diagram number 65
      CALL FFV1_0(W(1,20),W(1,4),W(1,1),R2_GQQ,AMPL(1,169))
      CALL FFV1_0(W(1,20),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,170))
      CALL FFV1_0(W(1,20),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,171))
      CALL FFV1_0(W(1,20),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,172))
      CALL FFV1_0(W(1,20),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,173))
      CALL FFV1_0(W(1,20),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,174))
      CALL FFV1_0(W(1,20),W(1,4),W(1,1),UV_GQQB_1EPS,AMPL(2,175))
      CALL FFV1_0(W(1,20),W(1,4),W(1,1),UV_GQQG_1EPS,AMPL(2,176))
      CALL FFV1_0(W(1,20),W(1,4),W(1,1),UV_GQQB,AMPL(1,177))
      CALL FFV1_0(W(1,20),W(1,4),W(1,1),UV_GQQT,AMPL(1,178))
      CALL FFV1_1(W(1,12),W(1,1),GC_5,MDL_MT,MDL_WT,W(1,25))
C     Counter-term amplitude(s) for loop diagram number 70
      CALL R2_QQ_1_R2_QQ_2_0(W(1,8),W(1,25),R2_QQQ,R2_QQT,AMPL(1,179))
      CALL R2_QQ_2_0(W(1,8),W(1,25),UV_TMASS_1EPS,AMPL(2,180))
      CALL R2_QQ_2_0(W(1,8),W(1,25),UV_TMASS,AMPL(1,181))
      CALL FFV1_2(W(1,8),W(1,1),GC_5,MDL_MT,MDL_WT,W(1,26))
C     Counter-term amplitude(s) for loop diagram number 71
      CALL R2_QQ_1_R2_QQ_2_0(W(1,26),W(1,12),R2_QQQ,R2_QQT,AMPL(1,182))
      CALL R2_QQ_2_0(W(1,26),W(1,12),UV_TMASS_1EPS,AMPL(2,183))
      CALL R2_QQ_2_0(W(1,26),W(1,12),UV_TMASS,AMPL(1,184))
C     Counter-term amplitude(s) for loop diagram number 73
      CALL FFV2_0(W(1,5),W(1,25),W(1,3),R2_BXTW,AMPL(1,185))
      CALL FFV1_2(W(1,10),W(1,1),GC_5,MDL_MB,ZERO,W(1,27))
C     Counter-term amplitude(s) for loop diagram number 77
      CALL R2_QQ_1_R2_QQ_2_0(W(1,27),W(1,7),R2_QQQ,R2_QQB,AMPL(1,186))
      CALL R2_QQ_2_0(W(1,27),W(1,7),UV_BMASS_1EPS,AMPL(2,187))
      CALL R2_QQ_2_0(W(1,27),W(1,7),UV_BMASS,AMPL(1,188))
      CALL FFV1_1(W(1,7),W(1,1),GC_5,MDL_MB,ZERO,W(1,28))
C     Counter-term amplitude(s) for loop diagram number 78
      CALL R2_QQ_1_R2_QQ_2_0(W(1,10),W(1,28),R2_QQQ,R2_QQB,AMPL(1,189))
      CALL R2_QQ_2_0(W(1,10),W(1,28),UV_BMASS_1EPS,AMPL(2,190))
      CALL R2_QQ_2_0(W(1,10),W(1,28),UV_BMASS,AMPL(1,191))
C     Counter-term amplitude(s) for loop diagram number 80
      CALL FFV2_0(W(1,27),W(1,4),W(1,3),R2_BXTW,AMPL(1,192))
C     Counter-term amplitude(s) for loop diagram number 84
      CALL FFV1_0(W(1,5),W(1,28),W(1,2),R2_GQQ,AMPL(1,193))
      CALL FFV1_0(W(1,5),W(1,28),W(1,2),UV_GQQB_1EPS,AMPL(2,194))
      CALL FFV1_0(W(1,5),W(1,28),W(1,2),UV_GQQB_1EPS,AMPL(2,195))
      CALL FFV1_0(W(1,5),W(1,28),W(1,2),UV_GQQB_1EPS,AMPL(2,196))
      CALL FFV1_0(W(1,5),W(1,28),W(1,2),UV_GQQB_1EPS,AMPL(2,197))
      CALL FFV1_0(W(1,5),W(1,28),W(1,2),UV_GQQB_1EPS,AMPL(2,198))
      CALL FFV1_0(W(1,5),W(1,28),W(1,2),UV_GQQB_1EPS,AMPL(2,199))
      CALL FFV1_0(W(1,5),W(1,28),W(1,2),UV_GQQG_1EPS,AMPL(2,200))
      CALL FFV1_0(W(1,5),W(1,28),W(1,2),UV_GQQB,AMPL(1,201))
      CALL FFV1_0(W(1,5),W(1,28),W(1,2),UV_GQQT,AMPL(1,202))
C     Counter-term amplitude(s) for loop diagram number 87
      CALL FFV1_0(W(1,26),W(1,4),W(1,2),R2_GQQ,AMPL(1,203))
      CALL FFV1_0(W(1,26),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,204))
      CALL FFV1_0(W(1,26),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,205))
      CALL FFV1_0(W(1,26),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,206))
      CALL FFV1_0(W(1,26),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,207))
      CALL FFV1_0(W(1,26),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,208))
      CALL FFV1_0(W(1,26),W(1,4),W(1,2),UV_GQQB_1EPS,AMPL(2,209))
      CALL FFV1_0(W(1,26),W(1,4),W(1,2),UV_GQQG_1EPS,AMPL(2,210))
      CALL FFV1_0(W(1,26),W(1,4),W(1,2),UV_GQQB,AMPL(1,211))
      CALL FFV1_0(W(1,26),W(1,4),W(1,2),UV_GQQT,AMPL(1,212))
C     Counter-term amplitude(s) for loop diagram number 117
      CALL R2_GG_1_0(W(1,6),W(1,14),R2_GGQ,AMPL(1,213))
      CALL R2_GG_1_0(W(1,6),W(1,14),R2_GGQ,AMPL(1,214))
      CALL R2_GG_1_0(W(1,6),W(1,14),R2_GGQ,AMPL(1,215))
      CALL R2_GG_1_0(W(1,6),W(1,14),R2_GGQ,AMPL(1,216))
C     Counter-term amplitude(s) for loop diagram number 118
      CALL R2_GG_1_0(W(1,6),W(1,16),R2_GGQ,AMPL(1,217))
      CALL R2_GG_1_0(W(1,6),W(1,16),R2_GGQ,AMPL(1,218))
      CALL R2_GG_1_0(W(1,6),W(1,16),R2_GGQ,AMPL(1,219))
      CALL R2_GG_1_0(W(1,6),W(1,16),R2_GGQ,AMPL(1,220))
C     Counter-term amplitude(s) for loop diagram number 119
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),R2_3GQ,AMPL(1,221))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),R2_3GQ,AMPL(1,222))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),R2_3GQ,AMPL(1,223))
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),R2_3GQ,AMPL(1,224))
C     Counter-term amplitude(s) for loop diagram number 120
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),R2_3GQ,AMPL(1,225))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),R2_3GQ,AMPL(1,226))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),R2_3GQ,AMPL(1,227))
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),R2_3GQ,AMPL(1,228))
C     Counter-term amplitude(s) for loop diagram number 123
      CALL R2_GG_1_R2_GG_3_0(W(1,6),W(1,14),R2_GGQ,R2_GGB,AMPL(1,229))
C     Counter-term amplitude(s) for loop diagram number 124
      CALL R2_GG_1_R2_GG_3_0(W(1,6),W(1,16),R2_GGQ,R2_GGB,AMPL(1,230))
C     Counter-term amplitude(s) for loop diagram number 125
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),R2_3GQ,AMPL(1,231))
C     Counter-term amplitude(s) for loop diagram number 126
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),R2_3GQ,AMPL(1,232))
C     Counter-term amplitude(s) for loop diagram number 129
      CALL R2_GG_1_R2_GG_3_0(W(1,6),W(1,14),R2_GGQ,R2_GGT,AMPL(1,233))
C     Counter-term amplitude(s) for loop diagram number 130
      CALL R2_GG_1_R2_GG_3_0(W(1,6),W(1,16),R2_GGQ,R2_GGT,AMPL(1,234))
C     Counter-term amplitude(s) for loop diagram number 131
      CALL VVV1_0(W(1,1),W(1,2),W(1,14),R2_3GQ,AMPL(1,235))
C     Counter-term amplitude(s) for loop diagram number 132
      CALL VVV1_0(W(1,1),W(1,2),W(1,16),R2_3GQ,AMPL(1,236))

      GOTO 1001
 2000 CONTINUE
      CT_REQ_SO_DONE=.TRUE.
 1001 CONTINUE
      END


      subroutine FCN1(x1,f1,n1a,par1)
	  integer nmo, nim
      parameter (nss = 24)
      common /wblock2/ g_source, g_immob, g_minter, g_recov, b_v,
	1      b_vvec(87),nmo,nim
      common /wblock4/ den_m(nss), den_im(nss), gdot(nss), nnns, nnne
      common /wblock5/ enthalpy_coef, thermal_coef, temp
	  common /nab/ gn_bcc(3,43,43), n_bcc(3,43,43), np(43)
	  common /nab1/ gn_fcc(3,18,18), n_fcc(3,18,18), np1(18)
	  common /nab2/ gn_hcpt(3,86,86), n_hcpt(3,86,86), np2(86)
	  common /nab3/gn_hcp(3,87,87),n_hcp(3,87,87),den_im2(87),np3(87)
	  common /aij/ aijhcp(24,87), aijfcc(12,18), aijbcc(24,43),
	1         aijhcpt(24,86)

	  real ll, rmin(87), rimin(87), srm(24), sgdot(87), c4, r1, r2
	  real yim(24), dum, gdum(24), y1(67), ysat, fphi
	  integer n, n1, n2, nssim, nssm, n1a, ni, nj, nk
      dimension x1(n1a),f1(n1a),par1(n1a+1),yprime1(n1a)

      do i = 1, n1a
	  y1(i) = x1(i)
	  end do

	  ll = 0.0											!Mean free path
	  c4 = 0.0											!Gsource

	  if (nim == 18) then
		  nssim = 18
		  nssm = 12
		  ysat = 1e14
		  fphi = 0.1
	  else if (nim == 43) then
		  nssim = 43
		  nssm = 24
		  ysat = 1e16
		  fphi = 0.05
	  else if (nim == 86) then
		  nssim = 86
		  nssm = 24
		  ysat = 1e16
		  fphi = 0.05
	  else
		  nssim = 87
		  nssm = 24
		  ysat = 1e16
		  fphi = 0.05

	  endif

	  do i = 1, nssim
		  ni = nssm + i
		  ll = ll + y1(ni)
		  if (i .le. nssm) then
			  gdum(i) = abs(gdot(i))/b_vvec(i)
			  srm(i) = 0.7746*(y1(i)+y1(ni))
			  sgdot(i) = 0.7746*gdum(i)
			  rimin(i) = 0.7746*(y1(i) + y1(ni))*gdum(i)
		  else
			  rimin(i) = 0.0
			  sgdot(i) = 0.0
		  endif
	  end do

	  ll = 1.0/sqrt(ll)
	  fphi = fphi*ll

	  if (nim == 43) then
	  do j = 1, nssm
	  nj = nssm + j
	  do k = j+1, nssim
	  nk = nssm + k
	  if (k .le. nssm) then
		  r1 = aijbcc(j,k)*(y1(k)+y1(nk))
		  r2 = aijbcc(j,k)*(y1(j)+y1(nj))
		  srm(j) = srm(j) + r1
		  srm(k) = srm(k) + r2
		  sgdot(j) = sgdot(j) + aijbcc(j,k)*gdum(k)
		  sgdot(k) = sgdot(k) + aijbcc(j,k)*gdum(j)
		  r1 = r2*gdum(k) + r1*gdum(j)
		  rimin(n_bcc(1,j,k)) = rimin(n_bcc(1,j,k)) + gn_bcc(1,j,k)*r1
		  rimin(n_bcc(2,j,k)) = rimin(n_bcc(2,j,k)) + gn_bcc(2,j,k)*r1
		  rimin(n_bcc(3,j,k)) = rimin(n_bcc(3,j,k)) + gn_bcc(3,j,k)*r1
	  else
		  r1 = y1(nk)*aijbcc(j,k)
		  srm(j) = srm(j) + r1
		  sgdot(k) = sgdot(k) + aijbcc(j,k)*gdum(j)
		  r1 = r1*gdum(j)
		  rimin(n_bcc(1,j,k)) = rimin(n_bcc(1,j,k)) + gn_bcc(1,j,k)*r1
		  rimin(n_bcc(2,j,k)) = rimin(n_bcc(2,j,k)) + gn_bcc(2,j,k)*r1
		  rimin(n_bcc(3,j,k)) = rimin(n_bcc(3,j,k)) + gn_bcc(3,j,k)*r1
	  endif
	  end do
	  end do
	  else if (nim==18) then
	  do j = 1, nssm
	  nj = nssm + j
	  do k = j+1, nssim
	  nk = nssm + k
	  if (k .le. nssm) then
		  r1 = aijfcc(j,k)*(y1(k)+y1(nk))
		  r2 = aijfcc(j,k)*(y1(j)+y1(nj))
		  srm(j) = srm(j) + r1
		  srm(k) = srm(k) + r2
		  sgdot(j) = sgdot(j) + aijfcc(j,k)*gdum(k)
		  sgdot(k) = sgdot(k) + aijfcc(j,k)*gdum(j)
		  r1 = r2*gdum(k) + r1*gdum(j)
		  rimin(n_fcc(1,j,k)) = rimin(n_fcc(1,j,k)) + gn_fcc(1,j,k)*r1
		  rimin(n_fcc(2,j,k)) = rimin(n_fcc(2,j,k)) + gn_fcc(2,j,k)*r1
		  rimin(n_fcc(3,j,k)) = rimin(n_fcc(3,j,k)) + gn_fcc(3,j,k)*r1
	  else
		  r1 = y1(nk)*aijfcc(j,k)
		  srm(j) = srm(j) + r1
		  sgdot(k) = sgdot(k) + aijfcc(j,k)*gdum(j)
		  r1 = r1*gdum(j)
		  rimin(n_fcc(1,j,k)) = rimin(n_fcc(1,j,k)) + gn_fcc(1,j,k)*r1
		  rimin(n_fcc(2,j,k)) = rimin(n_fcc(2,j,k)) + gn_fcc(2,j,k)*r1
		  rimin(n_fcc(3,j,k)) = rimin(n_fcc(3,j,k)) + gn_fcc(3,j,k)*r1
	  endif
	  end do
	  end do
	  else if (nim==86) then
	  do j = 1, nssm
	  nj = nssm + j
	  do k = j+1, nssim
	  nk = nssm + k
	  if (k .le. nssm) then
		  r1 = aijhcpt(j,k)*(y1(k)+y1(nk))
		  r2 = aijhcpt(j,k)*(y1(j)+y1(nj))
		  srm(j) = srm(j) + r1
		  srm(k) = srm(k) + r2
		  sgdot(j) = sgdot(j) + aijhcpt(j,k)*gdum(k)
		  sgdot(k) = sgdot(k) + aijhcpt(j,k)*gdum(j)
		  r1 = r2*gdum(k) + r1*gdum(j)
		  rimin(n_hcpt(1,j,k)) = rimin(n_hcpt(1,j,k)) + gn_hcpt(1,j,k)*r1
		  rimin(n_hcpt(2,j,k)) = rimin(n_hcpt(2,j,k)) + gn_hcpt(2,j,k)*r1
		  rimin(n_hcpt(3,j,k)) = rimin(n_hcpt(3,j,k)) + gn_hcpt(3,j,k)*r1
	  else
		  r1 = y1(nk)*aijhcpt(j,k)
		  srm(j) = srm(j) + r1
		  sgdot(k) = sgdot(k) + aijhcpt(j,k)*gdum(j)
		  r1 = r1*gdum(j)
		  rimin(n_hcpt(1,j,k)) = rimin(n_hcpt(1,j,k)) + gn_hcpt(1,j,k)*r1
		  rimin(n_hcpt(2,j,k)) = rimin(n_hcpt(2,j,k)) + gn_hcpt(2,j,k)*r1
		  rimin(n_hcpt(3,j,k)) = rimin(n_hcpt(3,j,k)) + gn_hcpt(3,j,k)*r1
	  endif
	  end do
	  end do
	  else if (nim==87) then
	  do j = 1, nssm
	  nj = nssm + j
	  do k = j+1, nssim
	  nk = nssm + k
	  if (k .le. nssm) then
		  r1 = aijhcp(j,k)*(y1(k)+y1(nk))
		  r2 = aijhcp(j,k)*(y1(j)+y1(nj))
		  srm(j) = srm(j) + r1
		  srm(k) = srm(k) + r2
		  sgdot(j) = sgdot(j) + aijhcp(j,k)*gdum(k)
		  sgdot(k) = sgdot(k) + aijhcp(j,k)*gdum(j)
		  r1 = r2*gdum(k) + r1*gdum(j)
		  rimin(n_hcp(1,j,k)) = rimin(n_hcp(1,j,k)) + gn_hcp(1,j,k)*r1
		  rimin(n_hcp(2,j,k)) = rimin(n_hcp(2,j,k)) + gn_hcp(2,j,k)*r1
		  rimin(n_hcp(3,j,k)) = rimin(n_hcp(3,j,k)) + gn_hcp(3,j,k)*r1
	  else
		  r1 = y1(nk)*aijhcp(j,k)
		  srm(j) = srm(j) + r1
		  sgdot(k) = sgdot(k) + aijhcp(j,k)*gdum(j)
		  r1 = r1*gdum(j)
		  rimin(n_hcp(1,j,k)) = rimin(n_hcp(1,j,k)) + gn_hcp(1,j,k)*r1
		  rimin(n_hcp(2,j,k)) = rimin(n_hcp(2,j,k)) + gn_hcp(2,j,k)*r1
		  rimin(n_hcp(3,j,k)) = rimin(n_hcp(3,j,k)) + gn_hcp(3,j,k)*r1
	  endif
	  end do
	  end do
	  endif

	  c4 = 0.1/(ll*ll)

*------------------------------------

	  do i = 1, nssim
		  ni = nssm + i
		  if (i .le. nssm) then
		  yprime1(i) = (gdum(i)*(c4*y1(ni)/y1(i)-srm(i))
     >                 - y1(i)*sgdot(i))*fphi
		  endif
		  thermal_coef = 3376.9112279916*(1.0 - sqrt(y1(ni)/ysat))
		  c5 = -1 * thermal_coef/temp
		  yprime1(ni) = fphi*(rimin(i)
     >                - g_recov*exp(c5)*y1(ni)*sgdot(i))
	  end do

      do i = 1, n1a								!why is this only looped to n1?
	  f1(i) = x1(i) - par1(i) - par1(n1a+1)*yprime1(i)
	  end do

      return
      end