module load_sf
    use superfluid_def

    contains
    subroutine load_sf_table(prefix,sf_type,ierr)
        use exceptions_lib
        use interp_1d_def
        use interp_1d_lib

        character(len=*), intent(in) :: prefix
        integer, intent(in) :: sf_type
        integer, intent(out) :: ierr
        character(len=256) :: filename
        integer :: funit
        type(sf_table_type), pointer :: tab
        real(dp), dimension(:), pointer :: work=>null()
        real(dp), pointer, dimension(:,:) :: fval
        type(alert) :: superfluid_type=alert(scope='load_sf_table', &
        &   message='bad superfluid type')
        type(alert) :: table_loaded=alert(scope='load_sf_table', &
        &   message='overwriting already loaded type')
        type(failure) :: io_failure=failure(scope='load_sf_table', &
        &   message='unable to open file for reading')
        type(failure) :: alloc_failure=failure(scope='load_sf_table', &
        &   message='unable to allocate memory')

        if (sf_type <= max_number_sf_types .and. sf_type > 0) then
            tab => sf_tables(sf_type)
        else
            ierr = -9
            call superfluid_type% report
            return
        end if

        ! if the tables are already allocated, issue a warning and scrub the table
        if (tab% is_loaded) then
            call table_loaded% report
            call free_sf_table(tab)
        end if

        call get_file_name(prefix,sf_type,filename,ierr)

        open(newunit=funit,file=filename,status='old',action='read', &
        & iostat = ierr)
        if (io_failure% raised(ierr)) return

        ! skip the first 3 lines
        read(funit,*)
        read(funit,*)
        read(funit,*)

        ! now get the number of points and the minimum, maximum kF
        read(funit,*) tab% nv, tab% kF_min, tab% kF_max
        allocate(tab% kF(tab% nv),tab% f(4*tab% nv),stat=ierr)
        if (alloc_failure% raised(ierr)) then
            close(funit)
            return
        end if

        fval(1:4,1:tab% nv) => tab% f(1:4*tab% nv)
        read(funit,*) tab% kF(:)
        read(funit,*) fval(1,:)

        close(funit)

        allocate(work(tab% nv*pm_work_size))
        call interp_pm(tab% kF, tab% nv, tab% f, pm_work_size, work, &
        &    'load_sf_table', ierr)
        deallocate(work)
        tab% is_loaded = .TRUE.
    end subroutine load_sf_table

    subroutine get_file_name(prefix,sf_type,filename,ierr)
        use exceptions_lib
        character(len=*), intent(in) :: prefix
        integer, intent(in) :: sf_type
        character(len=*), intent(out) :: filename
        integer, intent(out) :: ierr
        character(len=2) :: typecode
        type(alert) :: invalid_type=alert(scope='get_file_name', &
        &   message='invalid superfluid type')

        ierr = 0
        filename = ''
        select case (sf_type)
            case (proton_1S0)
                typecode = 'p1'
            case (neutron_1S0)
                typecode = 'n1'
            case (neutron_3P2)
                typecode = 'n3'
            case default
                ierr = -1
                call invalid_type% report
        end select

        if (ierr == 0) then
            write (filename,'(a)') trim(sf_datadir) // '/' //trim(prefix) //  &
                &   '_' // typecode // '.data'
        end if
    end subroutine get_file_name

    subroutine free_sf_table(tab)
        type(sf_table_type), pointer :: tab
        tab% which_gap = undefined_gap
        tab% nv = 0
        tab% kF_min = 0.0
        tab% kF_max = 0.0
        if (allocated(tab% kF)) deallocate(tab% kF)
        if (associated(tab% f)) then
            deallocate(tab% f)
            nullify(tab% f)
        end if
        tab% is_loaded = .FALSE.
    end subroutine free_sf_table

end module load_sf


      SUBROUTINE SINGLE(TEST,KNO,IW,NSTA,INS,IEW,DLY,FMGC,
     &  XMGC,KLAS,PRR,CALR,ICAL,LAT,LON,V,D,DEPTH,VSQ,THK,H,G,F,
     &  TID,DID,FLT,QSPA,MSTA,PRMK,W,JMIN,P,S,SRMK,WS,AMX,PRX,CALX,RMK,
     &  DT,FMP,AZRES,SYM,QRMK,KDX,LDX,JDX,TP,WRK,KSMP,TS,TIME1,TIME2,
     &  AVXM,AVFM,XMAG,FMAG,NRES,SR,SRSQ,SRWT,QNO,MNO)
c******** besoin de iheter pour refroidir le calcul de trvhet si iheter=
	include 'H_param.f'
      common/heter2/iheter,xorgh,yorgh,cphih,sphih,xlatc,xlonc
      common/provi/epsob,iflag,elev(N_s)
      common/gradi/nlecp
C-------- SOLUTION FOR A SINGLE EARTHQUAKE ----------------------------
      CHARACTER*1 SYM(N_d),QRMK(N_d)
      CHARACTER*1 IW(N_s),INS(N_s),IEW(N_s)
      CHARACTER*1 insc,iewc
      CHARACTER*3 RMK(N_d)
      CHARACTER*4 ISW,IPRO,CHECK,NSTA(N_s)
      CHARACTER*4 MSTA(N_d),PRMK(N_d),SRMK(N_d),WRK(N_d),AZRES(N_d)
      CHARACTER*48 AHEAD
      CHARACTER*80 SUCARD
      INTEGER*4 ISKP(4),LA(10),LO(10)
      INTEGER*4 KDX(N_d),KEY(N_d),JMIN(N_d),LDX(N_d)
      INTEGER*4 ICAL(N_s),KLAS(N_s),MNO(N_s),KSMP(N_s),JDX(N_s)
      INTEGER*4 NRES(2,N_s)
      REAL*4 LATRT,LONRT,LATSV,LONSV
      REAL*4 LAT2,LON2,LATEP,LONEP,MAG,LATR,LONR
      REAL*4 QNO(4),XMEAN(4),SUM(5),WF(41),ALZ(10)
      REAL*4 V(21),D(21),VSQ(21),THK(21),H(21),DEPTH(21)
      REAL*4 TID(21,21),DID(21,21),F(21,21),G(4,21)
      REAL*4 SR(2,N_s),SRSQ(2,N_s),SRWT(2,N_s)
      REAL*4 AF(3),B(4),Y(4),SE(4),TEST(15),X(4,N_d),QSPA(9,40)
      REAL*4 FLT(2,N_s),DLY(2,N_s)
      REAL*4 AMX(N_d),PRX(N_d),CALX(N_d),XMAG(N_d)
      REAL*4 FMP(N_d),FMAG(N_d),TEMP(N_d),W(N_d),WS(N_d)
      REAL*4 DELTA(N_d),DX(N_d),DY(N_d),ANIN(N_d),AIN(N_d),AZ(N_d)
      REAL*4 WT(N_d),T(N_d),P(N_d),TP(N_d),DT(N_d),S(N_d),TS(N_d)
      REAL*4 FMGC(N_s),XMGC(N_s),PRR(N_s),CALR(N_s),LAT(N_s),LON(N_s)
      REAL*8 TIME1,TIME2
      COMMON/C1/IQ,KMS,KFM,IPUN,IMAG,IR,IPRN,KPAPER,KTEST,KAZ,KSORT,KSEL
      COMMON/C2/ ZTR,XNEAR,XFAR,POS,LATR,LONR,ONF,FLIM
      COMMON/C3/ AHEAD,IPRO,ISW
      COMMON/C4/ NL,NS,KDATE,KHR,NEAR,IEXIT,IDXS
      COMMON/C5/ PMIN,XFN
      COMMON/O1/ NI,INST,KNST,IPH,JPH,NDEC,JMAX,JAV,NR,NRP,KF,KP,KZ,KKF
      COMMON/O2/ AVRPS,DMIN,RMSSQ,ADJSQ,LATEP,LONEP,Z,ZSQ,AVR,AAR,ORG
      COMMON/O3/ SUCARD,insc,iewc
      COMMON/O4/ delta
      DATA WF/.95,0.95,0.95,0.95,0.95,0.95,0.94,0.94,0.94,0.93,
     1       0.92,0.92,0.91,0.90,0.88,0.87,0.85,0.83,0.80,0.77,
     2       0.73,0.69,0.64,0.59,0.53,0.47,0.41,0.34,0.28,0.23,
     3       0.18,0.14,0.11,0.08,0.06,0.04,0.03,0.02,0.01,0.01,0./
      DATA LA/1,1,1,1,0,0,-1,-1,-1,-1/,
     1     LO/+1,-1,+1,-1,0,0,+1,-1,+1,-1/,
     2     ALZ/-1.0,-1.0,+1.0,+1.0,-1.732,+1.732,-1.0,-1.0,+1.0,+1.0/
c************** on modifie iheter pour la premiere passe iflag=0 durant
c     ihetol=iheter
c     iheter=0
C-----------------------------------------------------------------------
      LATRT=0.
      LONRT=0.
      LATSV=0.
      LONSV=0.
  778 AVRPS = 0.0
      IEXIT=0
      ZRES=P(NR+1)
      KNST=JMIN(NR+1)/10
      INST=JMIN(NR+1)-KNST*10
      NRP=NR
	nlecp=nrp
   30 IF (IDXS .EQ. 0) GO TO 80
C------- TREAT S DATA BY AUGMENTING P DATA -----------------------------
      NOS=0
      DO 65 I=1,NRP
      IF (LDX(I) .EQ. 0) GO TO 65
      NOS=NOS+1
      NRS=NRP+NOS
      TP(NRS)=TS(I)
      W(NRS)=WS(I)
      KSMP(NRS)=0
      IF ((KNST.NE.1).AND.(KNST.NE.6)) W(NRS)=0.
      KDX(NRS)=KDX(I)
      LDX(I)=NRS
      WRK(NRS)='    '
   65 CONTINUE
      NR=NRP+NOS
	nlecp=nrp
C------- INITIALIZE TRIAL HYPOCENTER -----------------------------------
   80 K=KDX(NEAR)
      SVY1 = 0.0
      SVY2 = 0.0
      SVY3 = 0.0
      ERLMT = 0.
      DO 25 I = 1,3
      ISKP(I)=0
   25 CONTINUE
      IF (INST .NE. 9) GO TO 90
      READ(12,85) ORG1,ORG2,LAT1,LAT2,LON1,LON2,Z
   85 FORMAT(F5.0,F5.2,I5,F5.2,I5,2F5.2)
      ORG=60.*ORG1+ORG2
      LATEP=60.*LAT1+LAT2
      LONEP=60.*LON1+LON2
      GO TO 105
   90 IF (NR .GE. 4) GO TO 100
   96 WRITE(8,97)
   97 FORMAT(' ***** INSUFFICIENT DATA FOR LOCATING THIS QUAKE:')
      KKF = 1
      IF( NRP .EQ. 0 ) NRP = 1
      DO 98 L=1,NRP
c---- volcniques gua
	delta(i)=3
   	WRITE(*,599) KDATE,KHR,JMIN(L),P(L),S(L),fmp(l),msta(l),prmk(l)
   98 WRITE(8,99) MSTA(L),PRMK(L),KDATE,KHR,JMIN(L),P(L),S(L)
   99 FORMAT(5X,2A4,1X,I6,2I2,F5.2,7X,F5.2,f5.2)
  599 FORMAT(I6,1x,I2,1x,i2,1x,F5.2,7X,F5.2,2x,f5.2,1x,2a4)
      IEXIT=1
c     IF (NRP .EQ. 1) then
c       iheter=ihetol
c       RETURN
c     endif
      GO TO 575
  100 Z=ZTR
	zsv=ztr
      IF (AZRES(NRP+1).NE. '    ') Z=ZRES
      ORG=PMIN-Z/5.-1.
      IF(LATRT.EQ.0.) GO TO 102
      LATEP=LATRT
      LONEP=LONRT
      IF(iew(1).EQ.'W')LonEp=-LonEp
      IF(ins(1).EQ.'S')LatEp=-LatEp
      GO TO 105
  102 IF (LATR .EQ. 0.) GO TO 104
      LATEP=LATR
      LONEP=LONR
      IF(iEW(1).EQ.'W')LonEp=-LonEp
      IF(ins(1).EQ.'S')LatEp=-LatEp
      GO TO 105
  104 LATEP=LAT(K)+0.1
      LONEP=LON(K)+0.1
  105 ADJSQ=0.
      IPH=0
      NDEC=0
      PRMSSQ=100000.
      IF (ISW .EQ. '1   ') KNO=MNO(K)
      IF(ISW .EQ. '1   ') FLTEP=FLT(KNO,K)
      NIMAX=TEST(11)+.0001
C------- GEIGER'S ITERATION TO FIND HYPOCENTRAL ADJUSTMENTS ------------
  777 NI = 1
      IF (INST .EQ. 9) NI=NIMAX
  111 IF(ERLMT .EQ. 0.) GO TO 110
      LATEP = LATSV + LA(NA)*DELAT
      LONEP = LONSV + LO(NA)*DELON
c	print *,'GI',lonep/60.,latep/60.
      Z = ZSV + ALZ(NA)*DEZ
      IF(Z .LT.test(15)) Z=test(15)
  110 FMO=0.
      FNO=0.
      DO 112 I=1,5
  112 SUM(I)=0.
c	print *,'GIi',lonep/60.,latep/60.
C------- CALCULATE EPICENTRAL DISTANCE BY RICHTER'S METHOD -------------
      DO 120 I=1,NR
      JI=KDX(I)
      PHI = 0.0174532 * ((LAT(JI)+LATEP)/120.)
      SINPHI = SIN(PHI)
      SINP2  = SINPHI**2
      SINP4  = SINP2**2
      CA = 1.8553654 + 0.0062792*SINP2 + 0.0000319*SINP4
      CB = 1.8428071 + 0.0187098*SINP2 + 0.0001583*SINP4
      DX(I) = (LON(JI)-LONEP) * CA * COS(PHI)
      DY(I) = (LAT(JI)-LATEP) * CB
      DELTA(I)=SQRT(DX(I)**2+DY(I)**2)+0.000001
      WT(I)=W(I)
      IF (NI .LE. 1) GO TO 115
C------- DISTANCE WEIGHTING --------------------------------------------
      IF (DELTA(I) .LE. XNEAR) GO TO 115
      WT(I)=W(I)*(XFAR-DELTA(I))/XFN
      IF (WT(I) .LT. 0.005) WT(I)=0.
  115 IF (WT(I) .EQ. 0.) GO TO 120
      IF (KSMP(I) .EQ. 1) FMO=FMO+1.
      FNO=FNO+1.
      SUM(4)=SUM(4)+WT(I)
  120 CONTINUE
      IF (FNO .LT. 4.) GO TO 96
      AVWT=SUM(4)/FNO
C------- NORMALIZE DISTANCE WEIGHTS ------------------------------------
      SUM(4)=0.0
      DO 122 I=1,NR
  122 WT(I)=WT(I)/AVWT
      IF ((NI.LE.2).OR.(KAZ.EQ.0)) GO TO 130
C------- AZIMUTHAL WEIGHTING -------------------------------------------
      CALL AZWTOS(DX,DY,NR,WT,KDX,AZ,TEMP,KEY,INS,IEW)
C------- COMPUTE TRAVEL TIMES & DERIVATIVES ----------------------------
  130 ZSQ=Z**2
c************** on entre dans trvdrv quand iflag=0 ( premiere passe ou
c               premier passage de la deuxieme passe )
      if(iflag.eq.0) CALL TRVDRV(ISW,V,D,DEPTH,VSQ,NL,THK,H,G,F,
     &  TID,DID,FLT,DELTA,DX,DY,NR,KDX,KNO,FLTEP,Z,ZSQ,X,T,ANIN)
  131 FDLY=1.
      IF (ISW .EQ. '1   ') FDLY=0.
C------- CALCULATE TRAVEL TIME RESIDUALS X(4,I) & MODIFY THE DERIV'S ---
      DO 150 I=1,NR
      JI=KDX(I)
      IF (I .LE. NRP) GO TO 145
C------- S PHASE DATA --------------------------------------------------
      T(I)=POS*T(I)
      X(1,I)=POS*X(1,I)
      X(2,I)=POS*X(2,I)
      X(3,I)=POS*X(3,I)
      X(4,I)=TP(I)-T(I)-ORG-POS*DLY(KNO,JI)*FDLY
      GO TO 150
  145 IF (KSMP(I) .EQ. 0) GO TO 146
C------- S-P DATA ------------------------------------------------------
      X(1,I)=(POS-1.)*X(1,I)
      X(2,I)=(POS-1.)*X(2,I)
      X(3,I)=(POS-1.)*X(3,I)
      X(4,I)=TS(I)-TP(I)-(POS-1.)*(DLY(KNO,JI)*FDLY+T(I))
      GO TO 150
C------- P TRAVEL TIME RESIDUAL ----------------------------------------
  146 X(4,I)=TP(I)-T(I)-ORG-DLY(KNO,JI)*FDLY
  150 CONTINUE
C------- COMPUTE AVR, AAR, RMSSQ, & SDR --------------------------------
      ONF=0.0
      DO 152 I=1,NR
      ONF = ONF + WT(I)*(1-KSMP(I))
      XWT = X(4,I)*WT(I)
      SUM(1)=SUM(1)+XWT
      SUM(2)=SUM(2)+ABS(XWT)
      SUM(3)=SUM(3)+X(4,I)*XWT
      SUM(5)=SUM(5)+XWT*(1-KSMP(I))
  152 CONTINUE
      IF(FNO .GT. FMO) AVRPS=SUM(5)/(ONF)
      AVR=SUM(1)/FNO
      AAR=SUM(2)/FNO
      RMSSQ=SUM(3)/FNO
      SDR=SQRT(ABS(RMSSQ-AVR**2))
      DO 153 I=1,5
      SUM(I)= 0.0
  153 CONTINUE
      IF (RMSSQ .GE. TEST(1)) GO TO 154
      IF(ERLMT .EQ. 1.) GO TO 167
      IF(INST.EQ.9) GO TO 501
      IF(NI .GE. 2) GO TO 167
      GO TO 165
C------- JEFFREYS' WEIGHTING -------------------------------------------
  154 FMO=0.
      FNO=0.
      DO 160 I=1,NR
      WRK(I)='    '
      IF (WT(I) .EQ. 0.) GO TO 160
      K=10.*ABS(X(4,I)-AVR)/SDR+1.5
      IF (K .GT. 41) K=41
      WT(I)=WT(I)*WF(K)
      IF (K .GT. 30) WRK(I)='****'
      IF (WT(I) .LT. 0.005) WT(I)=0.
      IF (WT(I) .EQ. 0.) GO TO 160
      IF (KSMP(I) .EQ. 1) FMO=FMO+1.
      FNO=FNO+1.
      SUM(4)=SUM(4)+WT(I)
  160 CONTINUE
      IF (FNO .LT. 4.) GO TO 96
      AVWT=SUM(4)/FNO
      SUM(4)=0.0
      ONF=0.0
      DO 164 I=1,NR
      WT(I)=WT(I)/AVWT
      ONF = ONF + WT(I)*(1-KSMP(I))
      XWT=X(4,I)*WT(I)
      SUM(5)=SUM(5)+XWT*(1-KSMP(I))
  164 CONTINUE
C------- RECALCULATE AVRPS ---------------------------------------------
      IF(ERLMT .EQ. 1.) GO TO 163
      IF(INST .NE. 9) GO TO 163
      AVRPS = 0.0
      IF(FNO .NE. FMO) AVRPS = SUM(5)/ONF
      GO TO 501
  163 IF(FNO.EQ.FMO) AVRPS=0.0
      IF(FNO.EQ.FMO) GO TO 167
      AVRPS=SUM(5)/(ONF)
      SUM(5)=0.0
      IF(ERLMT .EQ. 1.) GO TO 167
C------- RESET FIRST ORIGIN TIME ---------------------------------------
      IF(NI.GE. 2) GO TO 167
  165 ORG=ORG+AVRPS
      DO 166 I=1,NR
      IF(KSMP(I) .EQ. 0) X(4,I)=X(4,I)-AVRPS
      XWT=WT(I)*X(4,I)
      SUM(5)=SUM(5)+XWT*(1 - KSMP(I))
      SUM(2)=SUM(2)+ABS(XWT)
      SUM(3)=SUM(3)+X(4,I)*XWT
  166 CONTINUE
      IF(FNO .GT. FMO) AVRPS=SUM(5)/(ONF)
      AAR=SUM(2)/FNO
      RMSSQ = SUM(3)/FNO
      GO TO 169
C------- FOR NI>1, COMPUTE AAR, & RMSSQ AS IF AVRPS=0. -----------------
  167 DO 168 I=1,NR
      XWT=WT(I)*(X(4,I)-AVRPS*(1-KSMP(I)))
      SUM(2)=SUM(2)+ABS(XWT)
      SUM(3)=SUM(3)+(X(4,I)-AVRPS*(1-KSMP(I)))*XWT
  168 CONTINUE
      AAR=SUM(2)/FNO
      RMSSQ=SUM(3)/FNO
      IF(ERLMT .EQ. 0.) GO TO 169
C------- OUTPUT RMS ERROR OF AUXILIARY POINTS --------------------------
      L = LATEP/60.
      ALA = LATEP - 60.*L
      L = LONEP/60.
      ALO = LONEP - 60.*L
      RMSX= SQRT(RMSSQ)
      DRMS = RMSX - RMSSV
      GO TO (1,2,3,4,5,6,1,2,3,4), NA
    1 WRITE(8,801) ALA,ALO,Z,AVRPS,RMSX,DRMS
  801 FORMAT(5F10.2,10X,F6.2)
      GO TO 174
    2 WRITE(8,802) ALA,ALO,Z,AVRPS,RMSX,DRMS
  802 FORMAT(5F10.2,28X,F6.2)
      GO TO 174
    3 WRITE(8,803) ALA,ALO,Z,AVRPS,RMSX,DRMS
  803 FORMAT(5F10.2,13X,'(',F6.2,')')
      GO TO 174
    4 WRITE(8,804) ALA,ALO,Z,AVRPS,RMSX,DRMS
  804 FORMAT(5F10.2,31X,'(',F6.2,')')
      IF(NA .EQ. 10) GO TO 550
      GO TO 174
    5 WRITE(8,805) ALA,ALO,Z,AVRPS,RMSX,DRMS
  805 FORMAT(/5F10.2,19X,F6.2)
      WRITE(8,807) RMSSV
  807 FORMAT(40X,F10.2,23X,'0.00')
      GO TO 174
    6 WRITE(8,806) ALA,ALO,Z,AVRPS,RMSX,DRMS
  806 FORMAT(5F10.2,22X,'(',F6.2,')'/)
  174 NA = NA + 1
      GO TO 111
C------- CHECK IF SOLUTION IS BETTER THAN PREVIOUS ONE -----------------
  169 IF((NI .EQ. 1) .AND. (NDEC .EQ. 0)) GO TO 170
      IF(PRMSSQ.GE.RMSSQ) GO TO 170
      NDEC = NDEC +1
      IF(NDEC .GT. 1) GO TO 175
      DO 177 I= 1,3
      B(I) = 0.0
      AF(I)=-1.0
      SE(I) = 0.0
  177 CONTINUE
      NI = NI -1
      BM1=Y(1)
      BM2=Y(2)
      BM3=Y(3)
      BMAX = ABS(Y(1))
      IIMAX = 1
      DO 176 I = 2,3
      IF(ABS(Y(I)).LE.BMAX) GO TO 176
      BMAX = ABS(Y(I))
      IIMAX = I
  176 CONTINUE
      ISKP(IIMAX)=1
      Y(1)=-BM1/5.
      Y(2)=-BM2/5.
      Y(3)=-BM3/5.
      Y(4)=-Y(1)*XMEAN(1)-Y(2)*XMEAN(2)-Y(3)*XMEAN(3)
      XADJSQ=Y(1)**2+Y(2)**2+Y(3)**2
      KP=0
      IF(XADJSQ .LT. 4.*TEST(4)/25.) GO TO 170
  175 IF(NDEC .EQ. 5) GO TO 170
      GO TO 325
C------- STEPWISE MULTIPLE REGRESSION ANALYSIS OF TRAVEL TIME RESIDUALS-
  170 IF(NDEC .GE. 1) NI = NI + 1
      IF (INST.EQ.1) GO TO 250
      IF(ISKP(3) .EQ. 1) GO TO 250
      IF (INST .EQ. 9) GO TO 501
      IF ((FNO.EQ.4) .AND. (FMO.LT.4)) GO TO 250
C---- FREE SOLUTION
      KZ=0
      KF=0
      CALL SWMREG(TEST,IPRN,NR,KSMP,FNO,X,WT,ISKP,KF,KZ,XMEAN,
     &  B,Y,SE,AF,ONF,FLIM)
C------- AVOID CORRECTING DEPTH IF HORIZONTAL CHANGE IS LARGE ----------
      IF (Y(1)**2+Y(2)**2 .LT. TEST(2)) GO TO 300
C---- FIXED DEPTH SOLUTION
  250 KZ=1
      KF=0
      CALL SWMREG(TEST,IPRN,NR,KSMP,FNO,X,WT,ISKP,KF,KZ,XMEAN,
     &  B,Y,SE,AF,ONF,FLIM)
C------- LIMIT FOCAL DEPTH CHANGE & AVOID HYPOCENTER IN THE AIR --------
  300 DO 275 I= 1,3
      ISKP(I)=0
  275 CONTINUE
      OLDY1=Y(1)
      OLDY2=Y(2)
      OLDY3=Y(3)
      ABSY1=ABS(Y(1))
      ABSY2=ABS(Y(2))
      ABSY3=ABS(Y(3))
      IF(ABSY1.GT.ABSY2) GO TO 305
      ABSGR=ABSY2
      GO TO 308
  305 ABSGR=ABSY1
  308 IF(ABSY3.LE.TEST(5)) GO TO 310
      I=ABSY3/TEST(5)
      Y(3)=Y(3)/(I+1)
  310   continue
c	print *,'------>',z,y(3),z+y(3),test(15)
	 IF((Z+Y(3)).GT.test(15)) GO TO 315
      Y(3)=-Z*TEST(12)+.000001
      ISKP(3) = 1
C------- LIMIT HORIZONTAL ADJUSTMENT OF EPICENTER ----------------------
  315 	continue
c	print *,z,y(3)
	IF(ABSGR.LE.TEST(10)) GO TO 320
      I=ABSGR/TEST(10)
      Y(1)=Y(1)/(I+1)
      Y(2)=Y(2)/(I+1)
  320 Y(4)=Y(4)-(Y(3)-OLDY3)*XMEAN(3)-(Y(1)-OLDY1)*XMEAN(1)
     1 -(Y(2)-OLDY2)*XMEAN(2)
      XADJSQ=Y(1)**2+Y(2)**2+Y(3)**2
      KP=0
      NDEC=0
      JPH=0
c************** on sort le resultat si iprn > 1 dans le cas ou
c               deuxieme passe alors iflag # 0
c 325 IF (IPRN .GE. 1.and.(iflag.ne.0.or.ihetol.eq.0)) CALL OUTPUT
  325 IF (IPRN .GE. 1) CALL OUTPUT
     &  (TEST,KNO,IW,INS,IEW,DLY,FMGC,XMGC,
     &  KLAS,PRR,CALR,ICAL,FLT,QSPA,MSTA,
     &  PRMK,JMIN,P,S,SRMK,AMX,PRX,CALX,RMK,DT,FMP,AZRES,QRMK,KDX,LDX,
     &  WT,TP,T,WRK,KSMP,TS,TIME1,TIME2,DELTA,DX,DY,AVXM,
     &  XMAG,AVFM,FMAG,MAG,FNO,X,B,Y,SE,AF,AZ,AIN,ANIN,TEMP,KEY)
      IF(NDEC .GE. 1) GO TO 330
C------- TERMINATE ITERATION IF HYPOCENTER ADJUSTMENT < TEST(4) --------
      IF (XADJSQ .LT. TEST(4)) GO TO 500
  330 IF(NI .EQ. NIMAX) GO TO 500
C------- ADJUST HYPOCENTER ---------------------------------------------
      PHI = 0.0174532 * (LATEP/60.)
      SINPHI = SIN(PHI)
      SINP2  = SINPHI**2
      SINP4  = SINP2**2
      CA = 1.8553654 + 0.0062792*SINP2 + 0.0000319*SINP4
      CB = 1.8428071 + 0.0187098*SINP2 + 0.0001583*SINP4
      LATEP = LATEP + (Y(2)/CB)
      LONEP = LONEP + (Y(1)/(CA*COS(PHI)))
      Z=Z+Y(3)
      ORG=ORG+Y(4)
      SVY1 = Y(1)
      SVY2 = Y(2)
      SVY3 = Y(3)
      ADJSQ=XADJSQ
      IF(NDEC .EQ. 0) PRMSSQ=RMSSQ
      IF(NDEC.GE.1) GO TO 110
      NI = NI + 1
      IF(NI .LE. NIMAX) GO TO 111
C------- RESET ORIGIN TIME ---------------------------------------------
  500 ORG=ORG+XMEAN(4)
      GO TO 502
  501 XMEAN(4)=0.0
  502 DO 505 I=1,5
  505 SUM(I)=0.0
      SUMM = 0.0
      DO 510 I=1,NR
      IF (KSMP(I) .EQ. 0) X(4,I)=X(4,I)-XMEAN(4)
      IF (WT(I) .EQ. 0.) GO TO 510
      IF(INST .NE. 9) GO TO 509
      XWTS=WT(I)*(X(4,I)**2)
      IF(KSMP(I) .EQ. 0) XWTS=WT(I)*((X(4,I)-AVRPS)**2)
      SUMM = SUMM + XWTS
  509 XWT=X(4,I)*WT(I)
      SUM(1)=SUM(1)+XWT
      SUM(2)=SUM(2)+ABS(XWT)
      SUM(3)=SUM(3)+X(4,I)*XWT
      SUM(5)=SUM(5)+XWT*(1-KSMP(I))
  510 CONTINUE
      RM9SV = SUMM/FNO
      AVR=SUM(1)/FNO
      AVRPS = 0.0
      IF(FNO .GT. FMO) AVRPS=SUM(5)/ONF
      AAR=SUM(2)/FNO
      RMSSQ=SUM(3)/FNO
C------- COMPUTE ERROR ESTIMATES BY SOLVING FULL NORMAL EQUATION -------
      KF=2
      KP=1
      KZ=0
      CALL SWMREG(TEST,IPRN,NR,KSMP,FNO,X,WT,ISKP,KF,KZ,XMEAN,
     &  B,Y,SE,AF,ONF,FLIM)
      DO 521 I =1,3
  521 Y(I)=0.0
      IF(INST.EQ.1) KZ = 1
c***************  on donne si ihetol=0 ou iflag # 0  voir plus haut
c     if(iflag.ne.0.or.ihetol.eq.0)
       CALL OUTPUT(TEST,KNO,IW,INS,IEW,DLY,FMGC,XMGC,
     &  KLAS,PRR,CALR,ICAL,FLT,QSPA,MSTA,
     &  PRMK,JMIN,P,S,SRMK,AMX,PRX,CALX,RMK,DT,FMP,AZRES,QRMK,KDX,LDX,
     &  WT,TP,T,WRK,KSMP,TS,TIME1,TIME2,DELTA,DX,DY,AVXM,
     &  XMAG,AVFM,FMAG,MAG,FNO,X,B,Y,SE,AF,AZ,AIN,ANIN,TEMP,KEY)
      IF (KMS .EQ. 1) CALL MISING
     &  (NSTA,LAT,LON,NS,MAG,TEMP,DMIN,JDX,
     &  JMAX,LATEP,LONEP,INS,IEW)
      IF ((KNST.GE.5) .OR. (KFM.GE.1)) CALL FMPLOT
     &                   (KPAPER,KFM,FNO,NRP,AZ,AIN,SYM,SUCARD)
      QNO(JAV)=QNO(JAV)+1.
      IF (JAV .GT. IQ) GO TO 523
C------- COMPUTE SUMMARY OF TRAVEL TIME RESIDUALS ----------------------
      DO 522 I=1,NRP
      IF ((WT(I).EQ.0.) .OR. (KSMP(I).EQ.1))  GO TO 522
      JI=KDX(I)
      NRES(KNO,JI)=NRES(KNO,JI)+1
      SR(KNO,JI)=SR(KNO,JI)+X(4,I)*WT(I)
      SRSQ(KNO,JI)=SRSQ(KNO,JI)+X(4,I)**2*WT(I)
      SRWT(KNO,JI)=SRWT(KNO,JI)+WT(I)
  522 CONTINUE
  523 IF (KTEST .NE. 1.) goto 550
C------- COMPUTE RMS AT AUXILIARY POINTS -------------------------------
      RMSSV = SQRT(RMSSQ)
      IF(INST.EQ.9) RMSSV = SQRT(RM9SV)
      ERLMT = 1.
      LATSV = LATEP
      LONSV = LONEP
      ZSV = Z
      PHI = 0.0174532 * (LATEP/60.)
      SINPHI = SIN(PHI)
      SINP2  = SINPHI**2
      SINP4  = SINP2**2
      CA = 1.8553654 + 0.0062792*SINP2 + 0.0000319*SINP4
      CB = 1.8428071 + 0.0187098*SINP2 + 0.0001583*SINP4
      DELAT = TEST(13)/CB
      DELON = TEST(13)/(CA*COS(PHI))
      DEZ = TEST(13)
      WRITE (8,525)
  525 FORMAT (/'       LAT       LON         Z     AVRPS       RMS
     1                DRMS'/)
      NA=1
      GO TO 111
  550 TIME1=TIME2
  575 CONTINUE
C------- CHECK FOR MULTIPLE SOLUTIONS OF THE SAME EARTHQUAKE -----------
      IF(IPRO.NE.' ** ') RETURN
      NR=NRP
      NRP1=NR +1
      READ(12,600)  CHECK,IPRO,KNST,INST,ZRES,LAT1,LAT2,LON1,LON2,
     1 AZRES(NRP1)
      WRITE(8,601) CHECK,IPRO,KNST,INST,ZRES,LAT1,LAT2,LON1,LON2
  601 FORMAT(//2A4,9X,2I1,F5.2,1X,2(I4,F6.2),'--- RUN AGAIN ---')
  600 FORMAT(2A4,9X,2I1,F5.2,1X,2(I4,F6.2),T21,A4)
      LATRT=60.*LAT1+LAT2
      LONRT=60.*LON1+LON2
      IF(CHECK.EQ.'    ') GO TO 30
      WRITE(8,610) CHECK
  610 FORMAT(/' ERROR ',A4,' SKIPPED.   INST. CARD DID NOT FOLLOW ***')
      RETURN
      END


! -----------------------------------------------------------------------------
! This file was automatically created by SARAH version 4.12.2
! SARAH References: arXiv:0806.0538, 0909.2863, 1002.0840, 1207.0906, 1309.7223
! (c) Florian Staub, 2013
! ------------------------------------------------------------------------------
! File created at 18:15 on 2.10.2017
! ----------------------------------------------------------------------

Module RGEs_seesaw1nmssm

Use Control
Use Settings
Use Model_Data_seesaw1nmssm
Use Mathematics

Logical,Private,Save::OnlyDiagonal

Real(dp),Parameter::id3R(3,3)=&
   & Reshape(Source=(/&
   & 1,0,0,&
 &0,1,0,&
 &0,0,1&
 &/),shape=(/3,3/))
Contains

Subroutine GToParameters308(g,g1,g2,g3,Yd,Ye,lam,kap,lamN,Yu,Yv,Td,Te,Tlam,           &
& Tk,TLN,Tu,Tv,mq2,ml2,mHd2,mHu2,md2,mu2,me2,mv2,ms2,M1,M2,M3)

Implicit None
Real(dp), Intent(in) :: g(308)
Real(dp),Intent(out) :: g1,g2,g3,mHd2,mHu2,ms2

Complex(dp),Intent(out) :: Yd(3,3),Ye(3,3),lam,kap,lamN(3,3),Yu(3,3),Yv(3,3),Td(3,3),Te(3,3),Tlam,               &
& Tk,TLN(3,3),Tu(3,3),Tv(3,3),mq2(3,3),ml2(3,3),md2(3,3),mu2(3,3),me2(3,3),              &
& mv2(3,3),M1,M2,M3

Integer i1, i2, i3, i4, SumI

Iname = Iname +1
NameOfUnit(Iname) = 'GToParameters308'

g1= g(1)
g2= g(2)
g3= g(3)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Yd(i1,i2) = Cmplx( g(SumI+4), g(SumI+5), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Ye(i1,i2) = Cmplx( g(SumI+22), g(SumI+23), dp)
End Do
 End Do

lam= Cmplx(g(40),g(41),dp)
kap= Cmplx(g(42),g(43),dp)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
lamN(i1,i2) = Cmplx( g(SumI+44), g(SumI+45), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Yu(i1,i2) = Cmplx( g(SumI+62), g(SumI+63), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Yv(i1,i2) = Cmplx( g(SumI+80), g(SumI+81), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Td(i1,i2) = Cmplx( g(SumI+98), g(SumI+99), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Te(i1,i2) = Cmplx( g(SumI+116), g(SumI+117), dp)
End Do
 End Do

Tlam= Cmplx(g(134),g(135),dp)
Tk= Cmplx(g(136),g(137),dp)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
TLN(i1,i2) = Cmplx( g(SumI+138), g(SumI+139), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Tu(i1,i2) = Cmplx( g(SumI+156), g(SumI+157), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Tv(i1,i2) = Cmplx( g(SumI+174), g(SumI+175), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
mq2(i1,i2) = Cmplx( g(SumI+192), g(SumI+193), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
ml2(i1,i2) = Cmplx( g(SumI+210), g(SumI+211), dp)
End Do
 End Do

mHd2= g(228)
mHu2= g(229)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
md2(i1,i2) = Cmplx( g(SumI+230), g(SumI+231), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
mu2(i1,i2) = Cmplx( g(SumI+248), g(SumI+249), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
me2(i1,i2) = Cmplx( g(SumI+266), g(SumI+267), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
mv2(i1,i2) = Cmplx( g(SumI+284), g(SumI+285), dp)
End Do
 End Do

ms2= g(302)
M1= Cmplx(g(303),g(304),dp)
M2= Cmplx(g(305),g(306),dp)
M3= Cmplx(g(307),g(308),dp)
Do i1=1,308
If (g(i1).ne.g(i1)) Then
 Write(*,*) "NaN appearing in ",NameOfUnit(Iname)
 Write(*,*) "At position ", i1
 Call TerminateProgram
End if
End do
Iname = Iname - 1

End Subroutine GToParameters308

Subroutine ParametersToG308(g1,g2,g3,Yd,Ye,lam,kap,lamN,Yu,Yv,Td,Te,Tlam,             &
& Tk,TLN,Tu,Tv,mq2,ml2,mHd2,mHu2,md2,mu2,me2,mv2,ms2,M1,M2,M3,g)

Implicit None
Real(dp), Intent(out) :: g(308)
Real(dp), Intent(in) :: g1,g2,g3,mHd2,mHu2,ms2

Complex(dp), Intent(in) :: Yd(3,3),Ye(3,3),lam,kap,lamN(3,3),Yu(3,3),Yv(3,3),Td(3,3),Te(3,3),Tlam,               &
& Tk,TLN(3,3),Tu(3,3),Tv(3,3),mq2(3,3),ml2(3,3),md2(3,3),mu2(3,3),me2(3,3),              &
& mv2(3,3),M1,M2,M3

Integer i1, i2, i3, i4, SumI

Iname = Iname +1
NameOfUnit(Iname) = 'ParametersToG308'

g(1) = g1
g(2) = g2
g(3) = g3
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+4) = Real(Yd(i1,i2), dp)
g(SumI+5) = Aimag(Yd(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+22) = Real(Ye(i1,i2), dp)
g(SumI+23) = Aimag(Ye(i1,i2))
End Do
End Do

g(40) = Real(lam,dp)
g(41) = Aimag(lam)
g(42) = Real(kap,dp)
g(43) = Aimag(kap)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+44) = Real(lamN(i1,i2), dp)
g(SumI+45) = Aimag(lamN(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+62) = Real(Yu(i1,i2), dp)
g(SumI+63) = Aimag(Yu(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+80) = Real(Yv(i1,i2), dp)
g(SumI+81) = Aimag(Yv(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+98) = Real(Td(i1,i2), dp)
g(SumI+99) = Aimag(Td(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+116) = Real(Te(i1,i2), dp)
g(SumI+117) = Aimag(Te(i1,i2))
End Do
End Do

g(134) = Real(Tlam,dp)
g(135) = Aimag(Tlam)
g(136) = Real(Tk,dp)
g(137) = Aimag(Tk)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+138) = Real(TLN(i1,i2), dp)
g(SumI+139) = Aimag(TLN(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+156) = Real(Tu(i1,i2), dp)
g(SumI+157) = Aimag(Tu(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+174) = Real(Tv(i1,i2), dp)
g(SumI+175) = Aimag(Tv(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+192) = Real(mq2(i1,i2), dp)
g(SumI+193) = Aimag(mq2(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+210) = Real(ml2(i1,i2), dp)
g(SumI+211) = Aimag(ml2(i1,i2))
End Do
End Do

g(228) = mHd2
g(229) = mHu2
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+230) = Real(md2(i1,i2), dp)
g(SumI+231) = Aimag(md2(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+248) = Real(mu2(i1,i2), dp)
g(SumI+249) = Aimag(mu2(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+266) = Real(me2(i1,i2), dp)
g(SumI+267) = Aimag(me2(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+284) = Real(mv2(i1,i2), dp)
g(SumI+285) = Aimag(mv2(i1,i2))
End Do
End Do

g(302) = ms2
g(303) = Real(M1,dp)
g(304) = Aimag(M1)
g(305) = Real(M2,dp)
g(306) = Aimag(M2)
g(307) = Real(M3,dp)
g(308) = Aimag(M3)
Iname = Iname - 1

End Subroutine ParametersToG308

Subroutine rge308(len, T, GY, F)
Implicit None
Integer, Intent(in) :: len
Real(dp), Intent(in) :: T, GY(len)
Real(dp), Intent(out) :: F(len)
Integer :: i1,i2,i3,i4
Integer :: j1,j2,j3,j4,j5,j6,j7
Real(dp) :: q
Real(dp) :: g1,betag11,betag12,Dg1,g2,betag21,betag22,Dg2,g3,betag31,betag32,         &
& Dg3,mHd2,betamHd21,betamHd22,DmHd2,mHu2,betamHu21,betamHu22,DmHu2,ms2,betams21,        &
& betams22,Dms2
Complex(dp) :: Yd(3,3),betaYd1(3,3),betaYd2(3,3),DYd(3,3),adjYd(3,3),Ye(3,3)          &
& ,betaYe1(3,3),betaYe2(3,3),DYe(3,3),adjYe(3,3),lam,betalam1,betalam2,Dlam,             &
& kap,betakap1,betakap2,Dkap,lamN(3,3),betalamN1(3,3),betalamN2(3,3),DlamN(3,3)          &
& ,adjlamN(3,3),Yu(3,3),betaYu1(3,3),betaYu2(3,3),DYu(3,3),adjYu(3,3),Yv(3,3)            &
& ,betaYv1(3,3),betaYv2(3,3),DYv(3,3),adjYv(3,3),Td(3,3),betaTd1(3,3),betaTd2(3,3)       &
& ,DTd(3,3),adjTd(3,3),Te(3,3),betaTe1(3,3),betaTe2(3,3),DTe(3,3),adjTe(3,3)             &
& ,Tlam,betaTlam1,betaTlam2,DTlam,Tk,betaTk1,betaTk2,DTk,TLN(3,3),betaTLN1(3,3)          &
& ,betaTLN2(3,3),DTLN(3,3),adjTLN(3,3),Tu(3,3),betaTu1(3,3),betaTu2(3,3),DTu(3,3)        &
& ,adjTu(3,3),Tv(3,3),betaTv1(3,3),betaTv2(3,3),DTv(3,3),adjTv(3,3),mq2(3,3)             &
& ,betamq21(3,3),betamq22(3,3),Dmq2(3,3),ml2(3,3),betaml21(3,3),betaml22(3,3)            &
& ,Dml2(3,3),md2(3,3),betamd21(3,3),betamd22(3,3),Dmd2(3,3),mu2(3,3),betamu21(3,3)       &
& ,betamu22(3,3),Dmu2(3,3),me2(3,3),betame21(3,3),betame22(3,3),Dme2(3,3),               &
& mv2(3,3),betamv21(3,3),betamv22(3,3),Dmv2(3,3),M1,betaM11,betaM12,DM1,M2,              &
& betaM21,betaM22,DM2,M3,betaM31,betaM32,DM3
Real(dp) :: Tr1(3),Tr2(3),Tr3(3)
Real(dp) :: Tr2U1(3,3)
Real(dp) :: Abslam,Abskap,AbsTlam,AbsTk,AbsM1,AbsM2,AbsM3
Complex(dp) :: md2Yd(3,3),me2Ye(3,3),ml2adjYe(3,3),ml2adjYv(3,3),mq2adjYd(3,3),mq2adjYu(3,3),        &
& mu2Yu(3,3),mv2Yv(3,3),Ydmq2(3,3),YdadjYd(3,3),Yeml2(3,3),YeadjYe(3,3),Yumq2(3,3),      &
& YuadjYu(3,3),Yvml2(3,3),YvadjYv(3,3),lamNClamN(3,3),adjYdmd2(3,3),adjYdYd(3,3),        &
& adjYdTd(3,3),adjYeme2(3,3),adjYeYe(3,3),adjYeTe(3,3),adjYumu2(3,3),adjYuYu(3,3),       &
& adjYuTu(3,3),adjYvmv2(3,3),adjYvYv(3,3),adjYvlamN(3,3),adjYvTv(3,3),adjYvTLN(3,3),     &
& adjTdTd(3,3),adjTeTe(3,3),adjTuTu(3,3),adjTvTv(3,3),Cmv2ClamN(3,3),CYvTpYv(3,3),       &
& CYvTpTv(3,3),ClamNmv2(3,3),ClamNYv(3,3),ClamNlamN(3,3),ClamNTv(3,3),ClamNTLN(3,3),     &
& CTdTpTd(3,3),CTeTpTe(3,3),CTuTpTu(3,3),CTvTpTv(3,3),CTLNTLN(3,3),TdadjTd(3,3),         &
& TeadjTe(3,3),TuadjTu(3,3),TvadjTv(3,3),TLNCTLN(3,3),md2YdadjYd(3,3),me2YeadjYe(3,3),   &
& ml2adjYeYe(3,3),ml2adjYvYv(3,3),mq2adjYdYd(3,3),mq2adjYuYu(3,3),mu2YuadjYu(3,3),       &
& mv2YvadjYv(3,3),mv2lamNClamN(3,3),Ydmq2adjYd(3,3),YdadjYdmd2(3,3),YdadjYdYd(3,3),      &
& YdadjYdTd(3,3),YdadjYuYu(3,3),YdadjYuTu(3,3),Yeml2adjYe(3,3),YeadjYeme2(3,3),          &
& YeadjYeYe(3,3),YeadjYeTe(3,3),YeadjYvYv(3,3),YeadjYvTv(3,3),Yumq2adjYu(3,3),           &
& YuadjYdYd(3,3),YuadjYdTd(3,3),YuadjYumu2(3,3),YuadjYuYu(3,3),YuadjYuTu(3,3),           &
& Yvml2adjYv(3,3),YvadjYeYe(3,3),YvadjYeTe(3,3),YvadjYvmv2(3,3),YvadjYvYv(3,3),          &
& YvadjYvlamN(3,3),YvadjYvTv(3,3),YvadjYvTLN(3,3),lamNCmv2ClamN(3,3),lamNCYvTpYv(3,3),   &
& lamNCYvTpTv(3,3),lamNClamNmv2(3,3),lamNClamNYv(3,3),lamNClamNlamN(3,3),lamNClamNTv(3,3),&
& lamNClamNTLN(3,3),adjYdmd2Yd(3,3),adjYdYdmq2(3,3),adjYeme2Ye(3,3),adjYeYeml2(3,3),     &
& adjYumu2Yu(3,3),adjYuYumq2(3,3),adjYvmv2Yv(3,3),adjYvYvml2(3,3),TdadjYdYd(3,3),        &
& TdadjYuYu(3,3),TeadjYeYe(3,3),TeadjYvYv(3,3),TuadjYdYd(3,3),TuadjYuYu(3,3),            &
& TvadjYeYe(3,3),TvadjYvYv(3,3),TvadjYvlamN(3,3),TLNCYvTpYv(3,3),TLNClamNYv(3,3),        &
& TLNClamNlamN(3,3)

Complex(dp) :: Trmd2,Trme2,Trml2,Trmq2,Trmu2,TrYdadjYd,TrYeadjYe,TrYuadjYu,TrYvadjYv,TrlamNClamN,    &
& TradjYdTd,TradjYeTe,TradjYuTu,TradjYvTv,TrClamNTLN,TrCTdTpTd,TrCTeTpTe,TrCTuTpTu,      &
& TrCTvTpTv,TrCTLNTLN,Trmd2YdadjYd,Trme2YeadjYe,Trml2adjYeYe,Trml2adjYvYv,               &
& Trmq2adjYdYd,Trmq2adjYuYu,Trmu2YuadjYu,Trmv2YvadjYv,Trmv2lamNClamN

Real(dp) :: g1p2,g1p3,g2p2,g2p3,g3p2,g3p3

Complex(dp) :: sqrt3ov5,ooSqrt15,lamp2

Iname = Iname +1
NameOfUnit(Iname) = 'rge308'

OnlyDiagonal = .Not.GenerationMixing
q = t

Call GToParameters308(gy,g1,g2,g3,Yd,Ye,lam,kap,lamN,Yu,Yv,Td,Te,Tlam,Tk,             &
& TLN,Tu,Tv,mq2,ml2,mHd2,mHu2,md2,mu2,me2,mv2,ms2,M1,M2,M3)

Abslam = Conjg(lam)*lam
Abskap = Conjg(kap)*kap
AbsTlam = Conjg(Tlam)*Tlam
AbsTk = Conjg(Tk)*Tk
AbsM1 = Conjg(M1)*M1
AbsM2 = Conjg(M2)*M2
AbsM3 = Conjg(M3)*M3
Call Adjungate(Yd,adjYd)
Call Adjungate(Ye,adjYe)
Call Adjungate(lamN,adjlamN)
Call Adjungate(Yu,adjYu)
Call Adjungate(Yv,adjYv)
Call Adjungate(Td,adjTd)
Call Adjungate(Te,adjTe)
Call Adjungate(TLN,adjTLN)
Call Adjungate(Tu,adjTu)
Call Adjungate(Tv,adjTv)
 md2Yd = Matmul2(md2,Yd,OnlyDiagonal)
 me2Ye = Matmul2(me2,Ye,OnlyDiagonal)
 ml2adjYe = Matmul2(ml2,adjYe,OnlyDiagonal)
 ml2adjYv = Matmul2(ml2,adjYv,OnlyDiagonal)
 mq2adjYd = Matmul2(mq2,adjYd,OnlyDiagonal)
 mq2adjYu = Matmul2(mq2,adjYu,OnlyDiagonal)
 mu2Yu = Matmul2(mu2,Yu,OnlyDiagonal)
 mv2Yv = Matmul2(mv2,Yv,OnlyDiagonal)
 Ydmq2 = Matmul2(Yd,mq2,OnlyDiagonal)
 YdadjYd = Matmul2(Yd,adjYd,OnlyDiagonal)
Forall(i2=1:3)  YdadjYd(i2,i2) =  Real(YdadjYd(i2,i2),dp)
 Yeml2 = Matmul2(Ye,ml2,OnlyDiagonal)
 YeadjYe = Matmul2(Ye,adjYe,OnlyDiagonal)
Forall(i2=1:3)  YeadjYe(i2,i2) =  Real(YeadjYe(i2,i2),dp)
 Yumq2 = Matmul2(Yu,mq2,OnlyDiagonal)
 YuadjYu = Matmul2(Yu,adjYu,OnlyDiagonal)
Forall(i2=1:3)  YuadjYu(i2,i2) =  Real(YuadjYu(i2,i2),dp)
 Yvml2 = Matmul2(Yv,ml2,OnlyDiagonal)
 YvadjYv = Matmul2(Yv,adjYv,OnlyDiagonal)
Forall(i2=1:3)  YvadjYv(i2,i2) =  Real(YvadjYv(i2,i2),dp)
 lamNClamN = Matmul2(lamN,adjlamN,OnlyDiagonal)
 adjYdmd2 = Matmul2(adjYd,md2,OnlyDiagonal)
 adjYdYd = Matmul2(adjYd,Yd,OnlyDiagonal)
Forall(i2=1:3)  adjYdYd(i2,i2) =  Real(adjYdYd(i2,i2),dp)
 adjYdTd = Matmul2(adjYd,Td,OnlyDiagonal)
 adjYeme2 = Matmul2(adjYe,me2,OnlyDiagonal)
 adjYeYe = Matmul2(adjYe,Ye,OnlyDiagonal)
Forall(i2=1:3)  adjYeYe(i2,i2) =  Real(adjYeYe(i2,i2),dp)
 adjYeTe = Matmul2(adjYe,Te,OnlyDiagonal)
 adjYumu2 = Matmul2(adjYu,mu2,OnlyDiagonal)
 adjYuYu = Matmul2(adjYu,Yu,OnlyDiagonal)
Forall(i2=1:3)  adjYuYu(i2,i2) =  Real(adjYuYu(i2,i2),dp)
 adjYuTu = Matmul2(adjYu,Tu,OnlyDiagonal)
 adjYvmv2 = Matmul2(adjYv,mv2,OnlyDiagonal)
 adjYvYv = Matmul2(adjYv,Yv,OnlyDiagonal)
Forall(i2=1:3)  adjYvYv(i2,i2) =  Real(adjYvYv(i2,i2),dp)
 adjYvlamN = Matmul2(adjYv,lamN,OnlyDiagonal)
 adjYvTv = Matmul2(adjYv,Tv,OnlyDiagonal)
 adjYvTLN = Matmul2(adjYv,TLN,OnlyDiagonal)
 adjTdTd = Matmul2(adjTd,Td,OnlyDiagonal)
 adjTeTe = Matmul2(adjTe,Te,OnlyDiagonal)
 adjTuTu = Matmul2(adjTu,Tu,OnlyDiagonal)
 adjTvTv = Matmul2(adjTv,Tv,OnlyDiagonal)
 Cmv2ClamN = Matmul2(Conjg(mv2),adjlamN,OnlyDiagonal)
 CYvTpYv = Matmul2(Conjg(Yv),Transpose(Yv),OnlyDiagonal)
Forall(i2=1:3)  CYvTpYv(i2,i2) =  Real(CYvTpYv(i2,i2),dp)
 CYvTpTv = Matmul2(Conjg(Yv),Transpose(Tv),OnlyDiagonal)
 ClamNmv2 = Matmul2(adjlamN,mv2,OnlyDiagonal)
 ClamNYv = Matmul2(adjlamN,Yv,OnlyDiagonal)
 ClamNlamN = Matmul2(adjlamN,lamN,OnlyDiagonal)
 ClamNTv = Matmul2(adjlamN,Tv,OnlyDiagonal)
 ClamNTLN = Matmul2(adjlamN,TLN,OnlyDiagonal)
 CTdTpTd = Matmul2(Conjg(Td),Transpose(Td),OnlyDiagonal)
Forall(i2=1:3)  CTdTpTd(i2,i2) =  Real(CTdTpTd(i2,i2),dp)
 CTeTpTe = Matmul2(Conjg(Te),Transpose(Te),OnlyDiagonal)
Forall(i2=1:3)  CTeTpTe(i2,i2) =  Real(CTeTpTe(i2,i2),dp)
 CTuTpTu = Matmul2(Conjg(Tu),Transpose(Tu),OnlyDiagonal)
Forall(i2=1:3)  CTuTpTu(i2,i2) =  Real(CTuTpTu(i2,i2),dp)
 CTvTpTv = Matmul2(Conjg(Tv),Transpose(Tv),OnlyDiagonal)
Forall(i2=1:3)  CTvTpTv(i2,i2) =  Real(CTvTpTv(i2,i2),dp)
 CTLNTLN = Matmul2(adjTLN,TLN,OnlyDiagonal)
 TdadjTd = Matmul2(Td,adjTd,OnlyDiagonal)
 TeadjTe = Matmul2(Te,adjTe,OnlyDiagonal)
 TuadjTu = Matmul2(Tu,adjTu,OnlyDiagonal)
 TvadjTv = Matmul2(Tv,adjTv,OnlyDiagonal)
 TLNCTLN = Matmul2(TLN,adjTLN,OnlyDiagonal)
 md2YdadjYd = Matmul2(md2,YdadjYd,OnlyDiagonal)
 me2YeadjYe = Matmul2(me2,YeadjYe,OnlyDiagonal)
 ml2adjYeYe = Matmul2(ml2,adjYeYe,OnlyDiagonal)
 ml2adjYvYv = Matmul2(ml2,adjYvYv,OnlyDiagonal)
 mq2adjYdYd = Matmul2(mq2,adjYdYd,OnlyDiagonal)
 mq2adjYuYu = Matmul2(mq2,adjYuYu,OnlyDiagonal)
 mu2YuadjYu = Matmul2(mu2,YuadjYu,OnlyDiagonal)
 mv2YvadjYv = Matmul2(mv2,YvadjYv,OnlyDiagonal)
 mv2lamNClamN = Matmul2(mv2,lamNClamN,OnlyDiagonal)
 Ydmq2adjYd = Matmul2(Yd,mq2adjYd,OnlyDiagonal)
Forall(i2=1:3)  Ydmq2adjYd(i2,i2) =  Real(Ydmq2adjYd(i2,i2),dp)
 YdadjYdmd2 = Matmul2(Yd,adjYdmd2,OnlyDiagonal)
 YdadjYdYd = Matmul2(Yd,adjYdYd,OnlyDiagonal)
 YdadjYdTd = Matmul2(Yd,adjYdTd,OnlyDiagonal)
 YdadjYuYu = Matmul2(Yd,adjYuYu,OnlyDiagonal)
 YdadjYuTu = Matmul2(Yd,adjYuTu,OnlyDiagonal)
 Yeml2adjYe = Matmul2(Ye,ml2adjYe,OnlyDiagonal)
Forall(i2=1:3)  Yeml2adjYe(i2,i2) =  Real(Yeml2adjYe(i2,i2),dp)
 YeadjYeme2 = Matmul2(Ye,adjYeme2,OnlyDiagonal)
 YeadjYeYe = Matmul2(Ye,adjYeYe,OnlyDiagonal)
 YeadjYeTe = Matmul2(Ye,adjYeTe,OnlyDiagonal)
 YeadjYvYv = Matmul2(Ye,adjYvYv,OnlyDiagonal)
 YeadjYvTv = Matmul2(Ye,adjYvTv,OnlyDiagonal)
 Yumq2adjYu = Matmul2(Yu,mq2adjYu,OnlyDiagonal)
Forall(i2=1:3)  Yumq2adjYu(i2,i2) =  Real(Yumq2adjYu(i2,i2),dp)
 YuadjYdYd = Matmul2(Yu,adjYdYd,OnlyDiagonal)
 YuadjYdTd = Matmul2(Yu,adjYdTd,OnlyDiagonal)
 YuadjYumu2 = Matmul2(Yu,adjYumu2,OnlyDiagonal)
 YuadjYuYu = Matmul2(Yu,adjYuYu,OnlyDiagonal)
 YuadjYuTu = Matmul2(Yu,adjYuTu,OnlyDiagonal)
 Yvml2adjYv = Matmul2(Yv,ml2adjYv,OnlyDiagonal)
Forall(i2=1:3)  Yvml2adjYv(i2,i2) =  Real(Yvml2adjYv(i2,i2),dp)
 YvadjYeYe = Matmul2(Yv,adjYeYe,OnlyDiagonal)
 YvadjYeTe = Matmul2(Yv,adjYeTe,OnlyDiagonal)
 YvadjYvmv2 = Matmul2(Yv,adjYvmv2,OnlyDiagonal)
 YvadjYvYv = Matmul2(Yv,adjYvYv,OnlyDiagonal)
 YvadjYvlamN = Matmul2(Yv,adjYvlamN,OnlyDiagonal)
 YvadjYvTv = Matmul2(Yv,adjYvTv,OnlyDiagonal)
 YvadjYvTLN = Matmul2(Yv,adjYvTLN,OnlyDiagonal)
 lamNCmv2ClamN = Matmul2(lamN,Cmv2ClamN,OnlyDiagonal)
 lamNCYvTpYv = Matmul2(lamN,CYvTpYv,OnlyDiagonal)
 lamNCYvTpTv = Matmul2(lamN,CYvTpTv,OnlyDiagonal)
 lamNClamNmv2 = Matmul2(lamN,ClamNmv2,OnlyDiagonal)
 lamNClamNYv = Matmul2(lamN,ClamNYv,OnlyDiagonal)
 lamNClamNlamN = Matmul2(lamN,ClamNlamN,OnlyDiagonal)
 lamNClamNTv = Matmul2(lamN,ClamNTv,OnlyDiagonal)
 lamNClamNTLN = Matmul2(lamN,ClamNTLN,OnlyDiagonal)
 adjYdmd2Yd = Matmul2(adjYd,md2Yd,OnlyDiagonal)
Forall(i2=1:3)  adjYdmd2Yd(i2,i2) =  Real(adjYdmd2Yd(i2,i2),dp)
 adjYdYdmq2 = Matmul2(adjYd,Ydmq2,OnlyDiagonal)
 adjYeme2Ye = Matmul2(adjYe,me2Ye,OnlyDiagonal)
Forall(i2=1:3)  adjYeme2Ye(i2,i2) =  Real(adjYeme2Ye(i2,i2),dp)
 adjYeYeml2 = Matmul2(adjYe,Yeml2,OnlyDiagonal)
 adjYumu2Yu = Matmul2(adjYu,mu2Yu,OnlyDiagonal)
Forall(i2=1:3)  adjYumu2Yu(i2,i2) =  Real(adjYumu2Yu(i2,i2),dp)
 adjYuYumq2 = Matmul2(adjYu,Yumq2,OnlyDiagonal)
 adjYvmv2Yv = Matmul2(adjYv,mv2Yv,OnlyDiagonal)
Forall(i2=1:3)  adjYvmv2Yv(i2,i2) =  Real(adjYvmv2Yv(i2,i2),dp)
 adjYvYvml2 = Matmul2(adjYv,Yvml2,OnlyDiagonal)
 TdadjYdYd = Matmul2(Td,adjYdYd,OnlyDiagonal)
 TdadjYuYu = Matmul2(Td,adjYuYu,OnlyDiagonal)
 TeadjYeYe = Matmul2(Te,adjYeYe,OnlyDiagonal)
 TeadjYvYv = Matmul2(Te,adjYvYv,OnlyDiagonal)
 TuadjYdYd = Matmul2(Tu,adjYdYd,OnlyDiagonal)
 TuadjYuYu = Matmul2(Tu,adjYuYu,OnlyDiagonal)
 TvadjYeYe = Matmul2(Tv,adjYeYe,OnlyDiagonal)
 TvadjYvYv = Matmul2(Tv,adjYvYv,OnlyDiagonal)
 TvadjYvlamN = Matmul2(Tv,adjYvlamN,OnlyDiagonal)
 TLNCYvTpYv = Matmul2(TLN,CYvTpYv,OnlyDiagonal)
 TLNClamNYv = Matmul2(TLN,ClamNYv,OnlyDiagonal)
 TLNClamNlamN = Matmul2(TLN,ClamNlamN,OnlyDiagonal)
 Trmd2 = Real(cTrace(md2),dp)
 Trme2 = Real(cTrace(me2),dp)
 Trml2 = Real(cTrace(ml2),dp)
 Trmq2 = Real(cTrace(mq2),dp)
 Trmu2 = Real(cTrace(mu2),dp)
 TrYdadjYd = Real(cTrace(YdadjYd),dp)
 TrYeadjYe = Real(cTrace(YeadjYe),dp)
 TrYuadjYu = Real(cTrace(YuadjYu),dp)
 TrYvadjYv = Real(cTrace(YvadjYv),dp)
 TrlamNClamN = cTrace(lamNClamN)
 TradjYdTd = cTrace(adjYdTd)
 TradjYeTe = cTrace(adjYeTe)
 TradjYuTu = cTrace(adjYuTu)
 TradjYvTv = cTrace(adjYvTv)
 TrClamNTLN = cTrace(ClamNTLN)
 TrCTdTpTd = Real(cTrace(CTdTpTd),dp)
 TrCTeTpTe = Real(cTrace(CTeTpTe),dp)
 TrCTuTpTu = Real(cTrace(CTuTpTu),dp)
 TrCTvTpTv = Real(cTrace(CTvTpTv),dp)
 TrCTLNTLN = cTrace(CTLNTLN)
 Trmd2YdadjYd = cTrace(md2YdadjYd)
 Trme2YeadjYe = cTrace(me2YeadjYe)
 Trml2adjYeYe = cTrace(ml2adjYeYe)
 Trml2adjYvYv = cTrace(ml2adjYvYv)
 Trmq2adjYdYd = cTrace(mq2adjYdYd)
 Trmq2adjYuYu = cTrace(mq2adjYuYu)
 Trmu2YuadjYu = cTrace(mu2YuadjYu)
 Trmv2YvadjYv = cTrace(mv2YvadjYv)
 Trmv2lamNClamN = cTrace(mv2lamNClamN)
 sqrt3ov5 =Sqrt(3._dp/5._dp)
 ooSqrt15 =1._dp/sqrt(15._dp)
 g1p2 =g1**2
 g1p3 =g1**3
 g2p2 =g2**2
 g2p3 =g2**3
 g3p2 =g3**2
 g3p3 =g3**3
 lamp2 =lam**2

If (TwoLoopRGE) Then
End If

Tr1(1) = g1*sqrt3ov5*(-1._dp*(mHd2) + mHu2 + Trmd2 + Trme2 - Trml2 + Trmq2 -          &
&  2._dp*(Trmu2))

If (TwoLoopRGE) Then
End If

!--------------------
! g1
!--------------------

betag11  = 33._dp*(g1p3)/5._dp

If (TwoLoopRGE) Then
betag12 = 0

Dg1 = oo16pi2*( betag11 + oo16pi2 * betag12 )

Else
Dg1 = oo16pi2* betag11
End If

!--------------------
! g2
!--------------------

betag21  = g2p3

If (TwoLoopRGE) Then
betag22 = 0

Dg2 = oo16pi2*( betag21 + oo16pi2 * betag22 )

Else
Dg2 = oo16pi2* betag21
End If

!--------------------
! g3
!--------------------

betag31  = -3._dp*(g3p3)

If (TwoLoopRGE) Then
betag32 = 0

Dg3 = oo16pi2*( betag31 + oo16pi2 * betag32 )

Else
Dg3 = oo16pi2* betag31
End If

!--------------------
! Yd
!--------------------

betaYd1  = (Abslam - 7._dp*(g1p2)/15._dp - 3._dp*(g2p2) - 16._dp*(g3p2)               &
& /3._dp + 3._dp*(TrYdadjYd) + TrYeadjYe)*Yd + 3._dp*(YdadjYdYd) + YdadjYuYu

If (TwoLoopRGE) Then
betaYd2 = 0

DYd = oo16pi2*( betaYd1 + oo16pi2 * betaYd2 )

Else
DYd = oo16pi2* betaYd1
End If

Call Chop(DYd)

!--------------------
! Ye
!--------------------

betaYe1  = (Abslam - 9._dp*(g1p2)/5._dp - 3._dp*(g2p2) + 3._dp*(TrYdadjYd)            &
&  + TrYeadjYe)*Ye + 3._dp*(YeadjYeYe) + YeadjYvYv

If (TwoLoopRGE) Then
betaYe2 = 0

DYe = oo16pi2*( betaYe1 + oo16pi2 * betaYe2 )

Else
DYe = oo16pi2* betaYe1
End If

Call Chop(DYe)

!--------------------
! lam
!--------------------

betalam1  = 2*Abskap*lam - (3*g1p2*lam)/5._dp - 3*g2p2*lam + 2*TrlamNClamN*lam +      &
&  3*TrYdadjYd*lam + TrYeadjYe*lam + 3*TrYuadjYu*lam + TrYvadjYv*lam + 4*lamp2*Conjg(lam)

If (TwoLoopRGE) Then
betalam2 = 0

Dlam = oo16pi2*( betalam1 + oo16pi2 * betalam2 )

Else
Dlam = oo16pi2* betalam1
End If

Call Chop(Dlam)

!--------------------
! kap
!--------------------

betakap1  = 6*(Abskap + Abslam + TrlamNClamN)*kap

If (TwoLoopRGE) Then
betakap2 = 0

Dkap = oo16pi2*( betakap1 + oo16pi2 * betakap2 )

Else
Dkap = oo16pi2* betakap1
End If

Call Chop(Dkap)

!--------------------
! lamN
!--------------------

betalamN1  = 2*(4._dp*(lamNClamNlamN) + lamNCYvTpYv + YvadjYvlamN + Abskap*lamN +     &
&  Abslam*lamN + TrlamNClamN*lamN)

If (TwoLoopRGE) Then
betalamN2 = 0

DlamN = oo16pi2*( betalamN1 + oo16pi2 * betalamN2 )

Else
DlamN = oo16pi2* betalamN1
End If

Call Chop(DlamN)

!--------------------
! Yu
!--------------------

betaYu1  = (Abslam - 13._dp*(g1p2)/15._dp - 3._dp*(g2p2) - 16._dp*(g3p2)              &
& /3._dp + 3._dp*(TrYuadjYu) + TrYvadjYv)*Yu + YuadjYdYd + 3._dp*(YuadjYuYu)

If (TwoLoopRGE) Then
betaYu2 = 0

DYu = oo16pi2*( betaYu1 + oo16pi2 * betaYu2 )

Else
DYu = oo16pi2* betaYu1
End If

Call Chop(DYu)

!--------------------
! Yv
!--------------------

betaYv1  = 4._dp*(lamNClamNYv) + (Abslam - 3._dp*(g1p2)/5._dp - 3._dp*(g2p2)          &
&  + 3._dp*(TrYuadjYu) + TrYvadjYv)*Yv + YvadjYeYe + 3._dp*(YvadjYvYv)

If (TwoLoopRGE) Then
betaYv2 = 0

DYv = oo16pi2*( betaYv1 + oo16pi2 * betaYv2 )

Else
DYv = oo16pi2* betaYv1
End If

Call Chop(DYv)

!--------------------
! Td
!--------------------

betaTd1  = 5._dp*(TdadjYdYd) + TdadjYuYu + 4._dp*(YdadjYdTd) + 2._dp*(YdadjYuTu)      &
&  + Abslam*Td - (7*g1p2*Td)/15._dp - 3*g2p2*Td - (16*g3p2*Td)/3._dp + 3*TrYdadjYd*Td +  &
&  TrYeadjYe*Td + Yd*((14*g1p2*M1)/15._dp + (32*g3p2*M3)/3._dp + 6*g2p2*M2 +             &
&  6._dp*(TradjYdTd) + 2._dp*(TradjYeTe) + 2*Conjg(lam)*Tlam)

If (TwoLoopRGE) Then
betaTd2 = 0

DTd = oo16pi2*( betaTd1 + oo16pi2 * betaTd2 )

Else
DTd = oo16pi2* betaTd1
End If

Call Chop(DTd)

!--------------------
! Te
!--------------------

betaTe1  = 5._dp*(TeadjYeYe) + TeadjYvYv + 4._dp*(YeadjYeTe) + 2._dp*(YeadjYvTv)      &
&  + Abslam*Te - (9*g1p2*Te)/5._dp - 3*g2p2*Te + 3*TrYdadjYd*Te + TrYeadjYe*Te +         &
&  Ye*((18*g1p2*M1)/5._dp + 6*g2p2*M2 + 6._dp*(TradjYdTd) + 2._dp*(TradjYeTe)            &
&  + 2*Conjg(lam)*Tlam)

If (TwoLoopRGE) Then
betaTe2 = 0

DTe = oo16pi2*( betaTe1 + oo16pi2 * betaTe2 )

Else
DTe = oo16pi2* betaTe1
End If

Call Chop(DTe)

!--------------------
! Tlam
!--------------------

betaTlam1  = (2*(3*g1p2*M1 + 15*g2p2*M2 + 15._dp*(TradjYdTd) + 5._dp*(TradjYeTe)      &
&  + 15._dp*(TradjYuTu) + 5._dp*(TradjYvTv) + 10._dp*(TrClamNTLN))*lam)/5._dp +          &
&  (12._dp*(Abslam) - 3._dp*(g1p2)/5._dp - 3._dp*(g2p2) + 2._dp*(TrlamNClamN)            &
&  + 3._dp*(TrYdadjYd) + TrYeadjYe + 3._dp*(TrYuadjYu) + TrYvadjYv)*Tlam +               &
&  2*Conjg(kap)*(2*lam*Tk + kap*Tlam)

If (TwoLoopRGE) Then
betaTlam2 = 0

DTlam = oo16pi2*( betaTlam1 + oo16pi2 * betaTlam2 )

Else
DTlam = oo16pi2* betaTlam1
End If

Call Chop(DTlam)

!--------------------
! Tk
!--------------------

betaTk1  = 6*(2*TrClamNTLN*kap + 3*Abskap*Tk + TrlamNClamN*Tk + Conjg(lam)            &
& *(lam*Tk + 2*kap*Tlam))

If (TwoLoopRGE) Then
betaTk2 = 0

DTk = oo16pi2*( betaTk1 + oo16pi2 * betaTk2 )

Else
DTk = oo16pi2* betaTk1
End If

Call Chop(DTk)

!--------------------
! TLN
!--------------------

betaTLN1  = 2*(6._dp*(lamNClamNTLN) + 2._dp*(lamNCYvTpTv) + 6._dp*(TLNClamNlamN)      &
&  + TLNCYvTpYv + 2._dp*(TvadjYvlamN) + YvadjYvTLN + 2*TrClamNTLN*lamN + TrlamNClamN*TLN +&
&  Conjg(kap)*(2*lamN*Tk + kap*TLN) + Conjg(lam)*(2*lamN*Tlam + lam*TLN))

If (TwoLoopRGE) Then
betaTLN2 = 0

DTLN = oo16pi2*( betaTLN1 + oo16pi2 * betaTLN2 )

Else
DTLN = oo16pi2* betaTLN1
End If

Call Chop(DTLN)

!--------------------
! Tu
!--------------------

betaTu1  = TuadjYdYd + 5._dp*(TuadjYuYu) + 2._dp*(YuadjYdTd) + 4._dp*(YuadjYuTu)      &
&  + Abslam*Tu - (13*g1p2*Tu)/15._dp - 3*g2p2*Tu - (16*g3p2*Tu)/3._dp + 3*TrYuadjYu*Tu + &
&  TrYvadjYv*Tu + Yu*((26*g1p2*M1)/15._dp + (32*g3p2*M3)/3._dp + 6*g2p2*M2 +             &
&  6._dp*(TradjYuTu) + 2._dp*(TradjYvTv) + 2*Conjg(lam)*Tlam)

If (TwoLoopRGE) Then
betaTu2 = 0

DTu = oo16pi2*( betaTu1 + oo16pi2 * betaTu2 )

Else
DTu = oo16pi2* betaTu1
End If

Call Chop(DTu)

!--------------------
! Tv
!--------------------

betaTv1  = 4._dp*(lamNClamNTv) + 8._dp*(TLNClamNYv) + TvadjYeYe + 5._dp*(TvadjYvYv)   &
&  + 2._dp*(YvadjYeTe) + 4._dp*(YvadjYvTv) + Abslam*Tv - (3*g1p2*Tv)/5._dp -             &
&  3*g2p2*Tv + 3*TrYuadjYu*Tv + TrYvadjYv*Tv + Yv*((6*g1p2*M1)/5._dp + 6*g2p2*M2 +       &
&  6._dp*(TradjYuTu) + 2._dp*(TradjYvTv) + 2*Conjg(lam)*Tlam)

If (TwoLoopRGE) Then
betaTv2 = 0

DTv = oo16pi2*( betaTv1 + oo16pi2 * betaTv2 )

Else
DTv = oo16pi2* betaTv1
End If

Call Chop(DTv)

!--------------------
! mq2
!--------------------

betamq21  = 2._dp*(adjTdTd) + 2._dp*(adjTuTu) + 2._dp*(adjYdmd2Yd) + adjYdYdmq2 +     &
&  2._dp*(adjYumu2Yu) + adjYuYumq2 - (2*AbsM1*g1p2*id3R)/15._dp - 6*AbsM2*g2p2*id3R -    &
&  (32*AbsM3*g3p2*id3R)/3._dp + 2*adjYdYd*mHd2 + 2*adjYuYu*mHu2 + mq2adjYdYd +           &
&  mq2adjYuYu + g1*id3R*ooSqrt15*Tr1(1)

If (TwoLoopRGE) Then
betamq22 = 0

Dmq2 = oo16pi2*( betamq21 + oo16pi2 * betamq22 )

Else
Dmq2 = oo16pi2* betamq21
End If

Call Chop(Dmq2)

Forall(i1=1:3) Dmq2(i1,i1) =  Real(Dmq2(i1,i1),dp)
Dmq2 = 0.5_dp*(Dmq2+ Conjg(Transpose(Dmq2)) )
!--------------------
! ml2
!--------------------

betaml21  = 2._dp*(adjTeTe) + 2._dp*(adjTvTv) + 2._dp*(adjYeme2Ye) + adjYeYeml2 +     &
&  2._dp*(adjYvmv2Yv) + adjYvYvml2 - (6*AbsM1*g1p2*id3R)/5._dp - 6*AbsM2*g2p2*id3R +     &
&  2*adjYeYe*mHd2 + 2*adjYvYv*mHu2 + ml2adjYeYe + ml2adjYvYv - g1*id3R*sqrt3ov5*Tr1(1)

If (TwoLoopRGE) Then
betaml22 = 0

Dml2 = oo16pi2*( betaml21 + oo16pi2 * betaml22 )

Else
Dml2 = oo16pi2* betaml21
End If

Call Chop(Dml2)

Forall(i1=1:3) Dml2(i1,i1) =  Real(Dml2(i1,i1),dp)
Dml2 = 0.5_dp*(Dml2+ Conjg(Transpose(Dml2)) )
!--------------------
! mHd2
!--------------------

betamHd21  = 2._dp*(AbsTlam) - (6*AbsM1*g1p2)/5._dp - 6*AbsM2*g2p2 + 2*Abslam*mHd2 +  &
&  2*Abslam*mHu2 + 2*Abslam*ms2 + 6._dp*(TrCTdTpTd) + 2._dp*(TrCTeTpTe) + 6._dp*(Trmd2YdadjYd)&
&  + 2._dp*(Trme2YeadjYe) + 2._dp*(Trml2adjYeYe) + 6._dp*(Trmq2adjYdYd) + 6*mHd2*TrYdadjYd +&
&  2*mHd2*TrYeadjYe - g1*sqrt3ov5*Tr1(1)

If (TwoLoopRGE) Then
betamHd22 = 0

DmHd2 = oo16pi2*( betamHd21 + oo16pi2 * betamHd22 )

Else
DmHd2 = oo16pi2* betamHd21
End If

!--------------------
! mHu2
!--------------------

betamHu21  = 2._dp*(AbsTlam) - (6*AbsM1*g1p2)/5._dp - 6*AbsM2*g2p2 + 2*Abslam*mHd2 +  &
&  2*Abslam*mHu2 + 2*Abslam*ms2 + 6._dp*(TrCTuTpTu) + 2._dp*(TrCTvTpTv) + 2._dp*(Trml2adjYvYv)&
&  + 6._dp*(Trmq2adjYuYu) + 6._dp*(Trmu2YuadjYu) + 2._dp*(Trmv2YvadjYv) + 6*mHu2*TrYuadjYu +&
&  2*mHu2*TrYvadjYv + g1*sqrt3ov5*Tr1(1)

If (TwoLoopRGE) Then
betamHu22 = 0

DmHu2 = oo16pi2*( betamHu21 + oo16pi2 * betamHu22 )

Else
DmHu2 = oo16pi2* betamHu21
End If

!--------------------
! md2
!--------------------

betamd21  = (-8*AbsM1*g1p2*id3R)/15._dp - (32*AbsM3*g3p2*id3R)/3._dp + 2._dp*(md2YdadjYd)&
&  + 4._dp*(TdadjTd) + 4*mHd2*YdadjYd + 2._dp*(YdadjYdmd2) + 4._dp*(Ydmq2adjYd)          &
&  + 2*g1*id3R*ooSqrt15*Tr1(1)

If (TwoLoopRGE) Then
betamd22 = 0

Dmd2 = oo16pi2*( betamd21 + oo16pi2 * betamd22 )

Else
Dmd2 = oo16pi2* betamd21
End If

Call Chop(Dmd2)

Forall(i1=1:3) Dmd2(i1,i1) =  Real(Dmd2(i1,i1),dp)
Dmd2 = 0.5_dp*(Dmd2+ Conjg(Transpose(Dmd2)) )
!--------------------
! mu2
!--------------------

betamu21  = (-32*AbsM1*g1p2*id3R)/15._dp - (32*AbsM3*g3p2*id3R)/3._dp +               &
&  2._dp*(mu2YuadjYu) + 4._dp*(TuadjTu) + 4*mHu2*YuadjYu + 2._dp*(YuadjYumu2)            &
&  + 4._dp*(Yumq2adjYu) - 4*g1*id3R*ooSqrt15*Tr1(1)

If (TwoLoopRGE) Then
betamu22 = 0

Dmu2 = oo16pi2*( betamu21 + oo16pi2 * betamu22 )

Else
Dmu2 = oo16pi2* betamu21
End If

Call Chop(Dmu2)

Forall(i1=1:3) Dmu2(i1,i1) =  Real(Dmu2(i1,i1),dp)
Dmu2 = 0.5_dp*(Dmu2+ Conjg(Transpose(Dmu2)) )
!--------------------
! me2
!--------------------

betame21  = (-24*AbsM1*g1p2*id3R)/5._dp + 2*(me2YeadjYe + 2._dp*(TeadjTe)             &
&  + 2*mHd2*YeadjYe + YeadjYeme2 + 2._dp*(Yeml2adjYe)) + 2*g1*id3R*sqrt3ov5*Tr1(1)

If (TwoLoopRGE) Then
betame22 = 0

Dme2 = oo16pi2*( betame21 + oo16pi2 * betame22 )

Else
Dme2 = oo16pi2* betame21
End If

Call Chop(Dme2)

Forall(i1=1:3) Dme2(i1,i1) =  Real(Dme2(i1,i1),dp)
Dme2 = 0.5_dp*(Dme2+ Conjg(Transpose(Dme2)) )
!--------------------
! mv2
!--------------------

betamv21  = 2*(2._dp*(lamNClamNmv2) + 4._dp*(lamNCmv2ClamN) + 4*lamNClamN*ms2 +       &
&  2._dp*(mv2lamNClamN) + mv2YvadjYv + 4._dp*(TLNCTLN) + 2._dp*(TvadjTv) +               &
&  2*mHu2*YvadjYv + YvadjYvmv2 + 2._dp*(Yvml2adjYv))

If (TwoLoopRGE) Then
betamv22 = 0

Dmv2 = oo16pi2*( betamv21 + oo16pi2 * betamv22 )

Else
Dmv2 = oo16pi2* betamv21
End If

Call Chop(Dmv2)

Forall(i1=1:3) Dmv2(i1,i1) =  Real(Dmv2(i1,i1),dp)
Dmv2 = 0.5_dp*(Dmv2+ Conjg(Transpose(Dmv2)) )
!--------------------
! ms2
!--------------------

betams21  = 4*(AbsTk + AbsTlam + 3*Abskap*ms2 + Abslam*(mHd2 + mHu2 + ms2)            &
&  + TrCTLNTLN + ms2*TrlamNClamN + 2._dp*(Trmv2lamNClamN))

If (TwoLoopRGE) Then
betams22 = 0

Dms2 = oo16pi2*( betams21 + oo16pi2 * betams22 )

Else
Dms2 = oo16pi2* betams21
End If

!--------------------
! M1
!--------------------

betaM11  = (66*g1p2*M1)/5._dp

If (TwoLoopRGE) Then
betaM12 = 0

DM1 = oo16pi2*( betaM11 + oo16pi2 * betaM12 )

Else
DM1 = oo16pi2* betaM11
End If

Call Chop(DM1)

!--------------------
! M2
!--------------------

betaM21  = 2*g2p2*M2

If (TwoLoopRGE) Then
betaM22 = 0

DM2 = oo16pi2*( betaM21 + oo16pi2 * betaM22 )

Else
DM2 = oo16pi2* betaM21
End If

Call Chop(DM2)

!--------------------
! M3
!--------------------

betaM31  = -6*g3p2*M3

If (TwoLoopRGE) Then
betaM32 = 0

DM3 = oo16pi2*( betaM31 + oo16pi2 * betaM32 )

Else
DM3 = oo16pi2* betaM31
End If

Call Chop(DM3)

Call ParametersToG308(Dg1,Dg2,Dg3,DYd,DYe,Dlam,Dkap,DlamN,DYu,DYv,DTd,DTe,            &
& DTlam,DTk,DTLN,DTu,DTv,Dmq2,Dml2,DmHd2,DmHu2,Dmd2,Dmu2,Dme2,Dmv2,Dms2,DM1,             &
& DM2,DM3,f)

Iname = Iname - 1

End Subroutine rge308

Subroutine GToParameters311(g,g1,g2,g3,Yd,Ye,lam,kap,lamN,Yu,Yv,Td,Te,Tlam,           &
& Tk,TLN,Tu,Tv,mq2,ml2,mHd2,mHu2,md2,mu2,me2,mv2,ms2,M1,M2,M3,vd,vu,vS)

Implicit None
Real(dp), Intent(in) :: g(311)
Real(dp),Intent(out) :: g1,g2,g3,mHd2,mHu2,ms2,vd,vu,vS

Complex(dp),Intent(out) :: Yd(3,3),Ye(3,3),lam,kap,lamN(3,3),Yu(3,3),Yv(3,3),Td(3,3),Te(3,3),Tlam,               &
& Tk,TLN(3,3),Tu(3,3),Tv(3,3),mq2(3,3),ml2(3,3),md2(3,3),mu2(3,3),me2(3,3),              &
& mv2(3,3),M1,M2,M3

Integer i1, i2, i3, i4, SumI

Iname = Iname +1
NameOfUnit(Iname) = 'GToParameters311'

g1= g(1)
g2= g(2)
g3= g(3)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Yd(i1,i2) = Cmplx( g(SumI+4), g(SumI+5), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Ye(i1,i2) = Cmplx( g(SumI+22), g(SumI+23), dp)
End Do
 End Do

lam= Cmplx(g(40),g(41),dp)
kap= Cmplx(g(42),g(43),dp)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
lamN(i1,i2) = Cmplx( g(SumI+44), g(SumI+45), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Yu(i1,i2) = Cmplx( g(SumI+62), g(SumI+63), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Yv(i1,i2) = Cmplx( g(SumI+80), g(SumI+81), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Td(i1,i2) = Cmplx( g(SumI+98), g(SumI+99), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Te(i1,i2) = Cmplx( g(SumI+116), g(SumI+117), dp)
End Do
 End Do

Tlam= Cmplx(g(134),g(135),dp)
Tk= Cmplx(g(136),g(137),dp)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
TLN(i1,i2) = Cmplx( g(SumI+138), g(SumI+139), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Tu(i1,i2) = Cmplx( g(SumI+156), g(SumI+157), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
Tv(i1,i2) = Cmplx( g(SumI+174), g(SumI+175), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
mq2(i1,i2) = Cmplx( g(SumI+192), g(SumI+193), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
ml2(i1,i2) = Cmplx( g(SumI+210), g(SumI+211), dp)
End Do
 End Do

mHd2= g(228)
mHu2= g(229)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
md2(i1,i2) = Cmplx( g(SumI+230), g(SumI+231), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
mu2(i1,i2) = Cmplx( g(SumI+248), g(SumI+249), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
me2(i1,i2) = Cmplx( g(SumI+266), g(SumI+267), dp)
End Do
 End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
mv2(i1,i2) = Cmplx( g(SumI+284), g(SumI+285), dp)
End Do
 End Do

ms2= g(302)
M1= Cmplx(g(303),g(304),dp)
M2= Cmplx(g(305),g(306),dp)
M3= Cmplx(g(307),g(308),dp)
vd= g(309)
vu= g(310)
vS= g(311)
Do i1=1,311
If (g(i1).ne.g(i1)) Then
 Write(*,*) "NaN appearing in ",NameOfUnit(Iname)
 Write(*,*) "At position ", i1
 Call TerminateProgram
End if
End do
Iname = Iname - 1

End Subroutine GToParameters311

Subroutine ParametersToG311(g1,g2,g3,Yd,Ye,lam,kap,lamN,Yu,Yv,Td,Te,Tlam,             &
& Tk,TLN,Tu,Tv,mq2,ml2,mHd2,mHu2,md2,mu2,me2,mv2,ms2,M1,M2,M3,vd,vu,vS,g)

Implicit None
Real(dp), Intent(out) :: g(311)
Real(dp), Intent(in) :: g1,g2,g3,mHd2,mHu2,ms2,vd,vu,vS

Complex(dp), Intent(in) :: Yd(3,3),Ye(3,3),lam,kap,lamN(3,3),Yu(3,3),Yv(3,3),Td(3,3),Te(3,3),Tlam,               &
& Tk,TLN(3,3),Tu(3,3),Tv(3,3),mq2(3,3),ml2(3,3),md2(3,3),mu2(3,3),me2(3,3),              &
& mv2(3,3),M1,M2,M3

Integer i1, i2, i3, i4, SumI

Iname = Iname +1
NameOfUnit(Iname) = 'ParametersToG311'

g(1) = g1
g(2) = g2
g(3) = g3
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+4) = Real(Yd(i1,i2), dp)
g(SumI+5) = Aimag(Yd(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+22) = Real(Ye(i1,i2), dp)
g(SumI+23) = Aimag(Ye(i1,i2))
End Do
End Do

g(40) = Real(lam,dp)
g(41) = Aimag(lam)
g(42) = Real(kap,dp)
g(43) = Aimag(kap)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+44) = Real(lamN(i1,i2), dp)
g(SumI+45) = Aimag(lamN(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+62) = Real(Yu(i1,i2), dp)
g(SumI+63) = Aimag(Yu(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+80) = Real(Yv(i1,i2), dp)
g(SumI+81) = Aimag(Yv(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+98) = Real(Td(i1,i2), dp)
g(SumI+99) = Aimag(Td(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+116) = Real(Te(i1,i2), dp)
g(SumI+117) = Aimag(Te(i1,i2))
End Do
End Do

g(134) = Real(Tlam,dp)
g(135) = Aimag(Tlam)
g(136) = Real(Tk,dp)
g(137) = Aimag(Tk)
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+138) = Real(TLN(i1,i2), dp)
g(SumI+139) = Aimag(TLN(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+156) = Real(Tu(i1,i2), dp)
g(SumI+157) = Aimag(Tu(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+174) = Real(Tv(i1,i2), dp)
g(SumI+175) = Aimag(Tv(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+192) = Real(mq2(i1,i2), dp)
g(SumI+193) = Aimag(mq2(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+210) = Real(ml2(i1,i2), dp)
g(SumI+211) = Aimag(ml2(i1,i2))
End Do
End Do

g(228) = mHd2
g(229) = mHu2
Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+230) = Real(md2(i1,i2), dp)
g(SumI+231) = Aimag(md2(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+248) = Real(mu2(i1,i2), dp)
g(SumI+249) = Aimag(mu2(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+266) = Real(me2(i1,i2), dp)
g(SumI+267) = Aimag(me2(i1,i2))
End Do
End Do

Do i1 = 1,3
Do i2 = 1,3
SumI = (i2-1) + (i1-1)*3
SumI = SumI*2
g(SumI+284) = Real(mv2(i1,i2), dp)
g(SumI+285) = Aimag(mv2(i1,i2))
End Do
End Do

g(302) = ms2
g(303) = Real(M1,dp)
g(304) = Aimag(M1)
g(305) = Real(M2,dp)
g(306) = Aimag(M2)
g(307) = Real(M3,dp)
g(308) = Aimag(M3)
g(309) = vd
g(310) = vu
g(311) = vS
Iname = Iname - 1

End Subroutine ParametersToG311

Subroutine rge311(len, T, GY, F)
Implicit None
Integer, Intent(in) :: len
Real(dp), Intent(in) :: T, GY(len)
Real(dp), Intent(out) :: F(len)
Integer :: i1,i2,i3,i4
Integer :: j1,j2,j3,j4,j5,j6,j7
Real(dp) :: q
Real(dp) :: g1,betag11,betag12,Dg1,g2,betag21,betag22,Dg2,g3,betag31,betag32,         &
& Dg3,mHd2,betamHd21,betamHd22,DmHd2,mHu2,betamHu21,betamHu22,DmHu2,ms2,betams21,        &
& betams22,Dms2,vd,betavd1,betavd2,Dvd,vu,betavu1,betavu2,Dvu,vS,betavS1,betavS2,DvS
Complex(dp) :: Yd(3,3),betaYd1(3,3),betaYd2(3,3),DYd(3,3),adjYd(3,3),Ye(3,3)          &
& ,betaYe1(3,3),betaYe2(3,3),DYe(3,3),adjYe(3,3),lam,betalam1,betalam2,Dlam,             &
& kap,betakap1,betakap2,Dkap,lamN(3,3),betalamN1(3,3),betalamN2(3,3),DlamN(3,3)          &
& ,adjlamN(3,3),Yu(3,3),betaYu1(3,3),betaYu2(3,3),DYu(3,3),adjYu(3,3),Yv(3,3)            &
& ,betaYv1(3,3),betaYv2(3,3),DYv(3,3),adjYv(3,3),Td(3,3),betaTd1(3,3),betaTd2(3,3)       &
& ,DTd(3,3),adjTd(3,3),Te(3,3),betaTe1(3,3),betaTe2(3,3),DTe(3,3),adjTe(3,3)             &
& ,Tlam,betaTlam1,betaTlam2,DTlam,Tk,betaTk1,betaTk2,DTk,TLN(3,3),betaTLN1(3,3)          &
& ,betaTLN2(3,3),DTLN(3,3),adjTLN(3,3),Tu(3,3),betaTu1(3,3),betaTu2(3,3),DTu(3,3)        &
& ,adjTu(3,3),Tv(3,3),betaTv1(3,3),betaTv2(3,3),DTv(3,3),adjTv(3,3),mq2(3,3)             &
& ,betamq21(3,3),betamq22(3,3),Dmq2(3,3),ml2(3,3),betaml21(3,3),betaml22(3,3)            &
& ,Dml2(3,3),md2(3,3),betamd21(3,3),betamd22(3,3),Dmd2(3,3),mu2(3,3),betamu21(3,3)       &
& ,betamu22(3,3),Dmu2(3,3),me2(3,3),betame21(3,3),betame22(3,3),Dme2(3,3),               &
& mv2(3,3),betamv21(3,3),betamv22(3,3),Dmv2(3,3),M1,betaM11,betaM12,DM1,M2,              &
& betaM21,betaM22,DM2,M3,betaM31,betaM32,DM3
Real(dp) :: Tr1(3),Tr2(3),Tr3(3)
Real(dp) :: Tr2U1(3,3)
Real(dp) :: Abslam,Abskap,AbsTlam,AbsTk,AbsM1,AbsM2,AbsM3
Complex(dp) :: md2Yd(3,3),me2Ye(3,3),ml2adjYe(3,3),ml2adjYv(3,3),mq2adjYd(3,3),mq2adjYu(3,3),        &
& mu2Yu(3,3),mv2Yv(3,3),Ydmq2(3,3),YdadjYd(3,3),Yeml2(3,3),YeadjYe(3,3),Yumq2(3,3),      &
& YuadjYu(3,3),Yvml2(3,3),YvadjYv(3,3),lamNClamN(3,3),adjYdmd2(3,3),adjYdYd(3,3),        &
& adjYdTd(3,3),adjYeme2(3,3),adjYeYe(3,3),adjYeTe(3,3),adjYumu2(3,3),adjYuYu(3,3),       &
& adjYuTu(3,3),adjYvmv2(3,3),adjYvYv(3,3),adjYvlamN(3,3),adjYvTv(3,3),adjYvTLN(3,3),     &
& adjTdTd(3,3),adjTeTe(3,3),adjTuTu(3,3),adjTvTv(3,3),Cmv2ClamN(3,3),CYvTpYv(3,3),       &
& CYvTpTv(3,3),ClamNmv2(3,3),ClamNYv(3,3),ClamNlamN(3,3),ClamNTv(3,3),ClamNTLN(3,3),     &
& CTdTpTd(3,3),CTeTpTe(3,3),CTuTpTu(3,3),CTvTpTv(3,3),CTLNTLN(3,3),TdadjTd(3,3),         &
& TeadjTe(3,3),TuadjTu(3,3),TvadjTv(3,3),TLNCTLN(3,3),md2YdadjYd(3,3),me2YeadjYe(3,3),   &
& ml2adjYeYe(3,3),ml2adjYvYv(3,3),mq2adjYdYd(3,3),mq2adjYuYu(3,3),mu2YuadjYu(3,3),       &
& mv2YvadjYv(3,3),mv2lamNClamN(3,3),Ydmq2adjYd(3,3),YdadjYdmd2(3,3),YdadjYdYd(3,3),      &
& YdadjYdTd(3,3),YdadjYuYu(3,3),YdadjYuTu(3,3),Yeml2adjYe(3,3),YeadjYeme2(3,3),          &
& YeadjYeYe(3,3),YeadjYeTe(3,3),YeadjYvYv(3,3),YeadjYvTv(3,3),Yumq2adjYu(3,3),           &
& YuadjYdYd(3,3),YuadjYdTd(3,3),YuadjYumu2(3,3),YuadjYuYu(3,3),YuadjYuTu(3,3),           &
& Yvml2adjYv(3,3),YvadjYeYe(3,3),YvadjYeTe(3,3),YvadjYvmv2(3,3),YvadjYvYv(3,3),          &
& YvadjYvlamN(3,3),YvadjYvTv(3,3),YvadjYvTLN(3,3),lamNCmv2ClamN(3,3),lamNCYvTpYv(3,3),   &
& lamNCYvTpTv(3,3),lamNClamNmv2(3,3),lamNClamNYv(3,3),lamNClamNlamN(3,3),lamNClamNTv(3,3),&
& lamNClamNTLN(3,3),adjYdmd2Yd(3,3),adjYdYdmq2(3,3),adjYeme2Ye(3,3),adjYeYeml2(3,3),     &
& adjYumu2Yu(3,3),adjYuYumq2(3,3),adjYvmv2Yv(3,3),adjYvYvml2(3,3),TdadjYdYd(3,3),        &
& TdadjYuYu(3,3),TeadjYeYe(3,3),TeadjYvYv(3,3),TuadjYdYd(3,3),TuadjYuYu(3,3),            &
& TvadjYeYe(3,3),TvadjYvYv(3,3),TvadjYvlamN(3,3),TLNCYvTpYv(3,3),TLNClamNYv(3,3),        &
& TLNClamNlamN(3,3)

Complex(dp) :: Trmd2,Trme2,Trml2,Trmq2,Trmu2,TrYdadjYd,TrYeadjYe,TrYuadjYu,TrYvadjYv,TrlamNClamN,    &
& TradjYdTd,TradjYeTe,TradjYuTu,TradjYvTv,TrClamNTLN,TrCTdTpTd,TrCTeTpTe,TrCTuTpTu,      &
& TrCTvTpTv,TrCTLNTLN,Trmd2YdadjYd,Trme2YeadjYe,Trml2adjYeYe,Trml2adjYvYv,               &
& Trmq2adjYdYd,Trmq2adjYuYu,Trmu2YuadjYu,Trmv2YvadjYv,Trmv2lamNClamN

Real(dp) :: g1p2,g1p3,g2p2,g2p3,g3p2,g3p3

Complex(dp) :: sqrt3ov5,ooSqrt15,lamp2

Iname = Iname +1
NameOfUnit(Iname) = 'rge311'

OnlyDiagonal = .Not.GenerationMixing
q = t

Call GToParameters311(gy,g1,g2,g3,Yd,Ye,lam,kap,lamN,Yu,Yv,Td,Te,Tlam,Tk,             &
& TLN,Tu,Tv,mq2,ml2,mHd2,mHu2,md2,mu2,me2,mv2,ms2,M1,M2,M3,vd,vu,vS)

Abslam = Conjg(lam)*lam
Abskap = Conjg(kap)*kap
AbsTlam = Conjg(Tlam)*Tlam
AbsTk = Conjg(Tk)*Tk
AbsM1 = Conjg(M1)*M1
AbsM2 = Conjg(M2)*M2
AbsM3 = Conjg(M3)*M3
Call Adjungate(Yd,adjYd)
Call Adjungate(Ye,adjYe)
Call Adjungate(lamN,adjlamN)
Call Adjungate(Yu,adjYu)
Call Adjungate(Yv,adjYv)
Call Adjungate(Td,adjTd)
Call Adjungate(Te,adjTe)
Call Adjungate(TLN,adjTLN)
Call Adjungate(Tu,adjTu)
Call Adjungate(Tv,adjTv)
 md2Yd = Matmul2(md2,Yd,OnlyDiagonal)
 me2Ye = Matmul2(me2,Ye,OnlyDiagonal)
 ml2adjYe = Matmul2(ml2,adjYe,OnlyDiagonal)
 ml2adjYv = Matmul2(ml2,adjYv,OnlyDiagonal)
 mq2adjYd = Matmul2(mq2,adjYd,OnlyDiagonal)
 mq2adjYu = Matmul2(mq2,adjYu,OnlyDiagonal)
 mu2Yu = Matmul2(mu2,Yu,OnlyDiagonal)
 mv2Yv = Matmul2(mv2,Yv,OnlyDiagonal)
 Ydmq2 = Matmul2(Yd,mq2,OnlyDiagonal)
 YdadjYd = Matmul2(Yd,adjYd,OnlyDiagonal)
Forall(i2=1:3)  YdadjYd(i2,i2) =  Real(YdadjYd(i2,i2),dp)
 Yeml2 = Matmul2(Ye,ml2,OnlyDiagonal)
 YeadjYe = Matmul2(Ye,adjYe,OnlyDiagonal)
Forall(i2=1:3)  YeadjYe(i2,i2) =  Real(YeadjYe(i2,i2),dp)
 Yumq2 = Matmul2(Yu,mq2,OnlyDiagonal)
 YuadjYu = Matmul2(Yu,adjYu,OnlyDiagonal)
Forall(i2=1:3)  YuadjYu(i2,i2) =  Real(YuadjYu(i2,i2),dp)
 Yvml2 = Matmul2(Yv,ml2,OnlyDiagonal)
 YvadjYv = Matmul2(Yv,adjYv,OnlyDiagonal)
Forall(i2=1:3)  YvadjYv(i2,i2) =  Real(YvadjYv(i2,i2),dp)
 lamNClamN = Matmul2(lamN,adjlamN,OnlyDiagonal)
 adjYdmd2 = Matmul2(adjYd,md2,OnlyDiagonal)
 adjYdYd = Matmul2(adjYd,Yd,OnlyDiagonal)
Forall(i2=1:3)  adjYdYd(i2,i2) =  Real(adjYdYd(i2,i2),dp)
 adjYdTd = Matmul2(adjYd,Td,OnlyDiagonal)
 adjYeme2 = Matmul2(adjYe,me2,OnlyDiagonal)
 adjYeYe = Matmul2(adjYe,Ye,OnlyDiagonal)
Forall(i2=1:3)  adjYeYe(i2,i2) =  Real(adjYeYe(i2,i2),dp)
 adjYeTe = Matmul2(adjYe,Te,OnlyDiagonal)
 adjYumu2 = Matmul2(adjYu,mu2,OnlyDiagonal)
 adjYuYu = Matmul2(adjYu,Yu,OnlyDiagonal)
Forall(i2=1:3)  adjYuYu(i2,i2) =  Real(adjYuYu(i2,i2),dp)
 adjYuTu = Matmul2(adjYu,Tu,OnlyDiagonal)
 adjYvmv2 = Matmul2(adjYv,mv2,OnlyDiagonal)
 adjYvYv = Matmul2(adjYv,Yv,OnlyDiagonal)
Forall(i2=1:3)  adjYvYv(i2,i2) =  Real(adjYvYv(i2,i2),dp)
 adjYvlamN = Matmul2(adjYv,lamN,OnlyDiagonal)
 adjYvTv = Matmul2(adjYv,Tv,OnlyDiagonal)
 adjYvTLN = Matmul2(adjYv,TLN,OnlyDiagonal)
 adjTdTd = Matmul2(adjTd,Td,OnlyDiagonal)
 adjTeTe = Matmul2(adjTe,Te,OnlyDiagonal)
 adjTuTu = Matmul2(adjTu,Tu,OnlyDiagonal)
 adjTvTv = Matmul2(adjTv,Tv,OnlyDiagonal)
 Cmv2ClamN = Matmul2(Conjg(mv2),adjlamN,OnlyDiagonal)
 CYvTpYv = Matmul2(Conjg(Yv),Transpose(Yv),OnlyDiagonal)
Forall(i2=1:3)  CYvTpYv(i2,i2) =  Real(CYvTpYv(i2,i2),dp)
 CYvTpTv = Matmul2(Conjg(Yv),Transpose(Tv),OnlyDiagonal)
 ClamNmv2 = Matmul2(adjlamN,mv2,OnlyDiagonal)
 ClamNYv = Matmul2(adjlamN,Yv,OnlyDiagonal)
 ClamNlamN = Matmul2(adjlamN,lamN,OnlyDiagonal)
 ClamNTv = Matmul2(adjlamN,Tv,OnlyDiagonal)
 ClamNTLN = Matmul2(adjlamN,TLN,OnlyDiagonal)
 CTdTpTd = Matmul2(Conjg(Td),Transpose(Td),OnlyDiagonal)
Forall(i2=1:3)  CTdTpTd(i2,i2) =  Real(CTdTpTd(i2,i2),dp)
 CTeTpTe = Matmul2(Conjg(Te),Transpose(Te),OnlyDiagonal)
Forall(i2=1:3)  CTeTpTe(i2,i2) =  Real(CTeTpTe(i2,i2),dp)
 CTuTpTu = Matmul2(Conjg(Tu),Transpose(Tu),OnlyDiagonal)
Forall(i2=1:3)  CTuTpTu(i2,i2) =  Real(CTuTpTu(i2,i2),dp)
 CTvTpTv = Matmul2(Conjg(Tv),Transpose(Tv),OnlyDiagonal)
Forall(i2=1:3)  CTvTpTv(i2,i2) =  Real(CTvTpTv(i2,i2),dp)
 CTLNTLN = Matmul2(adjTLN,TLN,OnlyDiagonal)
 TdadjTd = Matmul2(Td,adjTd,OnlyDiagonal)
 TeadjTe = Matmul2(Te,adjTe,OnlyDiagonal)
 TuadjTu = Matmul2(Tu,adjTu,OnlyDiagonal)
 TvadjTv = Matmul2(Tv,adjTv,OnlyDiagonal)
 TLNCTLN = Matmul2(TLN,adjTLN,OnlyDiagonal)
 md2YdadjYd = Matmul2(md2,YdadjYd,OnlyDiagonal)
 me2YeadjYe = Matmul2(me2,YeadjYe,OnlyDiagonal)
 ml2adjYeYe = Matmul2(ml2,adjYeYe,OnlyDiagonal)
 ml2adjYvYv = Matmul2(ml2,adjYvYv,OnlyDiagonal)
 mq2adjYdYd = Matmul2(mq2,adjYdYd,OnlyDiagonal)
 mq2adjYuYu = Matmul2(mq2,adjYuYu,OnlyDiagonal)
 mu2YuadjYu = Matmul2(mu2,YuadjYu,OnlyDiagonal)
 mv2YvadjYv = Matmul2(mv2,YvadjYv,OnlyDiagonal)
 mv2lamNClamN = Matmul2(mv2,lamNClamN,OnlyDiagonal)
 Ydmq2adjYd = Matmul2(Yd,mq2adjYd,OnlyDiagonal)
Forall(i2=1:3)  Ydmq2adjYd(i2,i2) =  Real(Ydmq2adjYd(i2,i2),dp)
 YdadjYdmd2 = Matmul2(Yd,adjYdmd2,OnlyDiagonal)
 YdadjYdYd = Matmul2(Yd,adjYdYd,OnlyDiagonal)
 YdadjYdTd = Matmul2(Yd,adjYdTd,OnlyDiagonal)
 YdadjYuYu = Matmul2(Yd,adjYuYu,OnlyDiagonal)
 YdadjYuTu = Matmul2(Yd,adjYuTu,OnlyDiagonal)
 Yeml2adjYe = Matmul2(Ye,ml2adjYe,OnlyDiagonal)
Forall(i2=1:3)  Yeml2adjYe(i2,i2) =  Real(Yeml2adjYe(i2,i2),dp)
 YeadjYeme2 = Matmul2(Ye,adjYeme2,OnlyDiagonal)
 YeadjYeYe = Matmul2(Ye,adjYeYe,OnlyDiagonal)
 YeadjYeTe = Matmul2(Ye,adjYeTe,OnlyDiagonal)
 YeadjYvYv = Matmul2(Ye,adjYvYv,OnlyDiagonal)
 YeadjYvTv = Matmul2(Ye,adjYvTv,OnlyDiagonal)
 Yumq2adjYu = Matmul2(Yu,mq2adjYu,OnlyDiagonal)
Forall(i2=1:3)  Yumq2adjYu(i2,i2) =  Real(Yumq2adjYu(i2,i2),dp)
 YuadjYdYd = Matmul2(Yu,adjYdYd,OnlyDiagonal)
 YuadjYdTd = Matmul2(Yu,adjYdTd,OnlyDiagonal)
 YuadjYumu2 = Matmul2(Yu,adjYumu2,OnlyDiagonal)
 YuadjYuYu = Matmul2(Yu,adjYuYu,OnlyDiagonal)
 YuadjYuTu = Matmul2(Yu,adjYuTu,OnlyDiagonal)
 Yvml2adjYv = Matmul2(Yv,ml2adjYv,OnlyDiagonal)
Forall(i2=1:3)  Yvml2adjYv(i2,i2) =  Real(Yvml2adjYv(i2,i2),dp)
 YvadjYeYe = Matmul2(Yv,adjYeYe,OnlyDiagonal)
 YvadjYeTe = Matmul2(Yv,adjYeTe,OnlyDiagonal)
 YvadjYvmv2 = Matmul2(Yv,adjYvmv2,OnlyDiagonal)
 YvadjYvYv = Matmul2(Yv,adjYvYv,OnlyDiagonal)
 YvadjYvlamN = Matmul2(Yv,adjYvlamN,OnlyDiagonal)
 YvadjYvTv = Matmul2(Yv,adjYvTv,OnlyDiagonal)
 YvadjYvTLN = Matmul2(Yv,adjYvTLN,OnlyDiagonal)
 lamNCmv2ClamN = Matmul2(lamN,Cmv2ClamN,OnlyDiagonal)
 lamNCYvTpYv = Matmul2(lamN,CYvTpYv,OnlyDiagonal)
 lamNCYvTpTv = Matmul2(lamN,CYvTpTv,OnlyDiagonal)
 lamNClamNmv2 = Matmul2(lamN,ClamNmv2,OnlyDiagonal)
 lamNClamNYv = Matmul2(lamN,ClamNYv,OnlyDiagonal)
 lamNClamNlamN = Matmul2(lamN,ClamNlamN,OnlyDiagonal)
 lamNClamNTv = Matmul2(lamN,ClamNTv,OnlyDiagonal)
 lamNClamNTLN = Matmul2(lamN,ClamNTLN,OnlyDiagonal)
 adjYdmd2Yd = Matmul2(adjYd,md2Yd,OnlyDiagonal)
Forall(i2=1:3)  adjYdmd2Yd(i2,i2) =  Real(adjYdmd2Yd(i2,i2),dp)
 adjYdYdmq2 = Matmul2(adjYd,Ydmq2,OnlyDiagonal)
 adjYeme2Ye = Matmul2(adjYe,me2Ye,OnlyDiagonal)
Forall(i2=1:3)  adjYeme2Ye(i2,i2) =  Real(adjYeme2Ye(i2,i2),dp)
 adjYeYeml2 = Matmul2(adjYe,Yeml2,OnlyDiagonal)
 adjYumu2Yu = Matmul2(adjYu,mu2Yu,OnlyDiagonal)
Forall(i2=1:3)  adjYumu2Yu(i2,i2) =  Real(adjYumu2Yu(i2,i2),dp)
 adjYuYumq2 = Matmul2(adjYu,Yumq2,OnlyDiagonal)
 adjYvmv2Yv = Matmul2(adjYv,mv2Yv,OnlyDiagonal)
Forall(i2=1:3)  adjYvmv2Yv(i2,i2) =  Real(adjYvmv2Yv(i2,i2),dp)
 adjYvYvml2 = Matmul2(adjYv,Yvml2,OnlyDiagonal)
 TdadjYdYd = Matmul2(Td,adjYdYd,OnlyDiagonal)
 TdadjYuYu = Matmul2(Td,adjYuYu,OnlyDiagonal)
 TeadjYeYe = Matmul2(Te,adjYeYe,OnlyDiagonal)
 TeadjYvYv = Matmul2(Te,adjYvYv,OnlyDiagonal)
 TuadjYdYd = Matmul2(Tu,adjYdYd,OnlyDiagonal)
 TuadjYuYu = Matmul2(Tu,adjYuYu,OnlyDiagonal)
 TvadjYeYe = Matmul2(Tv,adjYeYe,OnlyDiagonal)
 TvadjYvYv = Matmul2(Tv,adjYvYv,OnlyDiagonal)
 TvadjYvlamN = Matmul2(Tv,adjYvlamN,OnlyDiagonal)
 TLNCYvTpYv = Matmul2(TLN,CYvTpYv,OnlyDiagonal)
 TLNClamNYv = Matmul2(TLN,ClamNYv,OnlyDiagonal)
 TLNClamNlamN = Matmul2(TLN,ClamNlamN,OnlyDiagonal)
 Trmd2 = Real(cTrace(md2),dp)
 Trme2 = Real(cTrace(me2),dp)
 Trml2 = Real(cTrace(ml2),dp)
 Trmq2 = Real(cTrace(mq2),dp)
 Trmu2 = Real(cTrace(mu2),dp)
 TrYdadjYd = Real(cTrace(YdadjYd),dp)
 TrYeadjYe = Real(cTrace(YeadjYe),dp)
 TrYuadjYu = Real(cTrace(YuadjYu),dp)
 TrYvadjYv = Real(cTrace(YvadjYv),dp)
 TrlamNClamN = cTrace(lamNClamN)
 TradjYdTd = cTrace(adjYdTd)
 TradjYeTe = cTrace(adjYeTe)
 TradjYuTu = cTrace(adjYuTu)
 TradjYvTv = cTrace(adjYvTv)
 TrClamNTLN = cTrace(ClamNTLN)
 TrCTdTpTd = Real(cTrace(CTdTpTd),dp)
 TrCTeTpTe = Real(cTrace(CTeTpTe),dp)
 TrCTuTpTu = Real(cTrace(CTuTpTu),dp)
 TrCTvTpTv = Real(cTrace(CTvTpTv),dp)
 TrCTLNTLN = cTrace(CTLNTLN)
 Trmd2YdadjYd = cTrace(md2YdadjYd)
 Trme2YeadjYe = cTrace(me2YeadjYe)
 Trml2adjYeYe = cTrace(ml2adjYeYe)
 Trml2adjYvYv = cTrace(ml2adjYvYv)
 Trmq2adjYdYd = cTrace(mq2adjYdYd)
 Trmq2adjYuYu = cTrace(mq2adjYuYu)
 Trmu2YuadjYu = cTrace(mu2YuadjYu)
 Trmv2YvadjYv = cTrace(mv2YvadjYv)
 Trmv2lamNClamN = cTrace(mv2lamNClamN)
 sqrt3ov5 =Sqrt(3._dp/5._dp)
 ooSqrt15 =1._dp/sqrt(15._dp)
 g1p2 =g1**2
 g1p3 =g1**3
 g2p2 =g2**2
 g2p3 =g2**3
 g3p2 =g3**2
 g3p3 =g3**3
 lamp2 =lam**2

If (TwoLoopRGE) Then
End If

Tr1(1) = g1*sqrt3ov5*(-1._dp*(mHd2) + mHu2 + Trmd2 + Trme2 - Trml2 + Trmq2 -          &
&  2._dp*(Trmu2))

If (TwoLoopRGE) Then
End If

!--------------------
! g1
!--------------------

betag11  = 33._dp*(g1p3)/5._dp

If (TwoLoopRGE) Then
betag12 = 0

Dg1 = oo16pi2*( betag11 + oo16pi2 * betag12 )

Else
Dg1 = oo16pi2* betag11
End If

!--------------------
! g2
!--------------------

betag21  = g2p3

If (TwoLoopRGE) Then
betag22 = 0

Dg2 = oo16pi2*( betag21 + oo16pi2 * betag22 )

Else
Dg2 = oo16pi2* betag21
End If

!--------------------
! g3
!--------------------

betag31  = -3._dp*(g3p3)

If (TwoLoopRGE) Then
betag32 = 0

Dg3 = oo16pi2*( betag31 + oo16pi2 * betag32 )

Else
Dg3 = oo16pi2* betag31
End If

!--------------------
! Yd
!--------------------

betaYd1  = (Abslam - 7._dp*(g1p2)/15._dp - 3._dp*(g2p2) - 16._dp*(g3p2)               &
& /3._dp + 3._dp*(TrYdadjYd) + TrYeadjYe)*Yd + 3._dp*(YdadjYdYd) + YdadjYuYu

If (TwoLoopRGE) Then
betaYd2 = 0

DYd = oo16pi2*( betaYd1 + oo16pi2 * betaYd2 )

Else
DYd = oo16pi2* betaYd1
End If

Call Chop(DYd)

!--------------------
! Ye
!--------------------

betaYe1  = (Abslam - 9._dp*(g1p2)/5._dp - 3._dp*(g2p2) + 3._dp*(TrYdadjYd)            &
&  + TrYeadjYe)*Ye + 3._dp*(YeadjYeYe) + YeadjYvYv

If (TwoLoopRGE) Then
betaYe2 = 0

DYe = oo16pi2*( betaYe1 + oo16pi2 * betaYe2 )

Else
DYe = oo16pi2* betaYe1
End If

Call Chop(DYe)

!--------------------
! lam
!--------------------

betalam1  = 2*Abskap*lam - (3*g1p2*lam)/5._dp - 3*g2p2*lam + 2*TrlamNClamN*lam +      &
&  3*TrYdadjYd*lam + TrYeadjYe*lam + 3*TrYuadjYu*lam + TrYvadjYv*lam + 4*lamp2*Conjg(lam)

If (TwoLoopRGE) Then
betalam2 = 0

Dlam = oo16pi2*( betalam1 + oo16pi2 * betalam2 )

Else
Dlam = oo16pi2* betalam1
End If

Call Chop(Dlam)

!--------------------
! kap
!--------------------

betakap1  = 6*(Abskap + Abslam + TrlamNClamN)*kap

If (TwoLoopRGE) Then
betakap2 = 0

Dkap = oo16pi2*( betakap1 + oo16pi2 * betakap2 )

Else
Dkap = oo16pi2* betakap1
End If

Call Chop(Dkap)

!--------------------
! lamN
!--------------------

betalamN1  = 2*(4._dp*(lamNClamNlamN) + lamNCYvTpYv + YvadjYvlamN + Abskap*lamN +     &
&  Abslam*lamN + TrlamNClamN*lamN)

If (TwoLoopRGE) Then
betalamN2 = 0

DlamN = oo16pi2*( betalamN1 + oo16pi2 * betalamN2 )

Else
DlamN = oo16pi2* betalamN1
End If

Call Chop(DlamN)

!--------------------
! Yu
!--------------------

betaYu1  = (Abslam - 13._dp*(g1p2)/15._dp - 3._dp*(g2p2) - 16._dp*(g3p2)              &
& /3._dp + 3._dp*(TrYuadjYu) + TrYvadjYv)*Yu + YuadjYdYd + 3._dp*(YuadjYuYu)

If (TwoLoopRGE) Then
betaYu2 = 0

DYu = oo16pi2*( betaYu1 + oo16pi2 * betaYu2 )

Else
DYu = oo16pi2* betaYu1
End If

Call Chop(DYu)

!--------------------
! Yv
!--------------------

betaYv1  = 4._dp*(lamNClamNYv) + (Abslam - 3._dp*(g1p2)/5._dp - 3._dp*(g2p2)          &
&  + 3._dp*(TrYuadjYu) + TrYvadjYv)*Yv + YvadjYeYe + 3._dp*(YvadjYvYv)

If (TwoLoopRGE) Then
betaYv2 = 0

DYv = oo16pi2*( betaYv1 + oo16pi2 * betaYv2 )

Else
DYv = oo16pi2* betaYv1
End If

Call Chop(DYv)

!--------------------
! Td
!--------------------

betaTd1  = 5._dp*(TdadjYdYd) + TdadjYuYu + 4._dp*(YdadjYdTd) + 2._dp*(YdadjYuTu)      &
&  + Abslam*Td - (7*g1p2*Td)/15._dp - 3*g2p2*Td - (16*g3p2*Td)/3._dp + 3*TrYdadjYd*Td +  &
&  TrYeadjYe*Td + Yd*((14*g1p2*M1)/15._dp + (32*g3p2*M3)/3._dp + 6*g2p2*M2 +             &
&  6._dp*(TradjYdTd) + 2._dp*(TradjYeTe) + 2*Conjg(lam)*Tlam)

If (TwoLoopRGE) Then
betaTd2 = 0

DTd = oo16pi2*( betaTd1 + oo16pi2 * betaTd2 )

Else
DTd = oo16pi2* betaTd1
End If

Call Chop(DTd)

!--------------------
! Te
!--------------------

betaTe1  = 5._dp*(TeadjYeYe) + TeadjYvYv + 4._dp*(YeadjYeTe) + 2._dp*(YeadjYvTv)      &
&  + Abslam*Te - (9*g1p2*Te)/5._dp - 3*g2p2*Te + 3*TrYdadjYd*Te + TrYeadjYe*Te +         &
&  Ye*((18*g1p2*M1)/5._dp + 6*g2p2*M2 + 6._dp*(TradjYdTd) + 2._dp*(TradjYeTe)            &
&  + 2*Conjg(lam)*Tlam)

If (TwoLoopRGE) Then
betaTe2 = 0

DTe = oo16pi2*( betaTe1 + oo16pi2 * betaTe2 )

Else
DTe = oo16pi2* betaTe1
End If

Call Chop(DTe)

!--------------------
! Tlam
!--------------------

betaTlam1  = (2*(3*g1p2*M1 + 15*g2p2*M2 + 15._dp*(TradjYdTd) + 5._dp*(TradjYeTe)      &
&  + 15._dp*(TradjYuTu) + 5._dp*(TradjYvTv) + 10._dp*(TrClamNTLN))*lam)/5._dp +          &
&  (12._dp*(Abslam) - 3._dp*(g1p2)/5._dp - 3._dp*(g2p2) + 2._dp*(TrlamNClamN)            &
&  + 3._dp*(TrYdadjYd) + TrYeadjYe + 3._dp*(TrYuadjYu) + TrYvadjYv)*Tlam +               &
&  2*Conjg(kap)*(2*lam*Tk + kap*Tlam)

If (TwoLoopRGE) Then
betaTlam2 = 0

DTlam = oo16pi2*( betaTlam1 + oo16pi2 * betaTlam2 )

Else
DTlam = oo16pi2* betaTlam1
End If

Call Chop(DTlam)

!--------------------
! Tk
!--------------------

betaTk1  = 6*(2*TrClamNTLN*kap + 3*Abskap*Tk + TrlamNClamN*Tk + Conjg(lam)            &
& *(lam*Tk + 2*kap*Tlam))

If (TwoLoopRGE) Then
betaTk2 = 0

DTk = oo16pi2*( betaTk1 + oo16pi2 * betaTk2 )

Else
DTk = oo16pi2* betaTk1
End If

Call Chop(DTk)

!--------------------
! TLN
!--------------------

betaTLN1  = 2*(6._dp*(lamNClamNTLN) + 2._dp*(lamNCYvTpTv) + 6._dp*(TLNClamNlamN)      &
&  + TLNCYvTpYv + 2._dp*(TvadjYvlamN) + YvadjYvTLN + 2*TrClamNTLN*lamN + TrlamNClamN*TLN +&
&  Conjg(kap)*(2*lamN*Tk + kap*TLN) + Conjg(lam)*(2*lamN*Tlam + lam*TLN))

If (TwoLoopRGE) Then
betaTLN2 = 0

DTLN = oo16pi2*( betaTLN1 + oo16pi2 * betaTLN2 )

Else
DTLN = oo16pi2* betaTLN1
End If

Call Chop(DTLN)

!--------------------
! Tu
!--------------------

betaTu1  = TuadjYdYd + 5._dp*(TuadjYuYu) + 2._dp*(YuadjYdTd) + 4._dp*(YuadjYuTu)      &
&  + Abslam*Tu - (13*g1p2*Tu)/15._dp - 3*g2p2*Tu - (16*g3p2*Tu)/3._dp + 3*TrYuadjYu*Tu + &
&  TrYvadjYv*Tu + Yu*((26*g1p2*M1)/15._dp + (32*g3p2*M3)/3._dp + 6*g2p2*M2 +             &
&  6._dp*(TradjYuTu) + 2._dp*(TradjYvTv) + 2*Conjg(lam)*Tlam)

If (TwoLoopRGE) Then
betaTu2 = 0

DTu = oo16pi2*( betaTu1 + oo16pi2 * betaTu2 )

Else
DTu = oo16pi2* betaTu1
End If

Call Chop(DTu)

!--------------------
! Tv
!--------------------

betaTv1  = 4._dp*(lamNClamNTv) + 8._dp*(TLNClamNYv) + TvadjYeYe + 5._dp*(TvadjYvYv)   &
&  + 2._dp*(YvadjYeTe) + 4._dp*(YvadjYvTv) + Abslam*Tv - (3*g1p2*Tv)/5._dp -             &
&  3*g2p2*Tv + 3*TrYuadjYu*Tv + TrYvadjYv*Tv + Yv*((6*g1p2*M1)/5._dp + 6*g2p2*M2 +       &
&  6._dp*(TradjYuTu) + 2._dp*(TradjYvTv) + 2*Conjg(lam)*Tlam)

If (TwoLoopRGE) Then
betaTv2 = 0

DTv = oo16pi2*( betaTv1 + oo16pi2 * betaTv2 )

Else
DTv = oo16pi2* betaTv1
End If

Call Chop(DTv)

!--------------------
! mq2
!--------------------

betamq21  = 2._dp*(adjTdTd) + 2._dp*(adjTuTu) + 2._dp*(adjYdmd2Yd) + adjYdYdmq2 +     &
&  2._dp*(adjYumu2Yu) + adjYuYumq2 - (2*AbsM1*g1p2*id3R)/15._dp - 6*AbsM2*g2p2*id3R -    &
&  (32*AbsM3*g3p2*id3R)/3._dp + 2*adjYdYd*mHd2 + 2*adjYuYu*mHu2 + mq2adjYdYd +           &
&  mq2adjYuYu + g1*id3R*ooSqrt15*Tr1(1)

If (TwoLoopRGE) Then
betamq22 = 0

Dmq2 = oo16pi2*( betamq21 + oo16pi2 * betamq22 )

Else
Dmq2 = oo16pi2* betamq21
End If

Call Chop(Dmq2)

Forall(i1=1:3) Dmq2(i1,i1) =  Real(Dmq2(i1,i1),dp)
Dmq2 = 0.5_dp*(Dmq2+ Conjg(Transpose(Dmq2)) )
!--------------------
! ml2
!--------------------

betaml21  = 2._dp*(adjTeTe) + 2._dp*(adjTvTv) + 2._dp*(adjYeme2Ye) + adjYeYeml2 +     &
&  2._dp*(adjYvmv2Yv) + adjYvYvml2 - (6*AbsM1*g1p2*id3R)/5._dp - 6*AbsM2*g2p2*id3R +     &
&  2*adjYeYe*mHd2 + 2*adjYvYv*mHu2 + ml2adjYeYe + ml2adjYvYv - g1*id3R*sqrt3ov5*Tr1(1)

If (TwoLoopRGE) Then
betaml22 = 0

Dml2 = oo16pi2*( betaml21 + oo16pi2 * betaml22 )

Else
Dml2 = oo16pi2* betaml21
End If

Call Chop(Dml2)

Forall(i1=1:3) Dml2(i1,i1) =  Real(Dml2(i1,i1),dp)
Dml2 = 0.5_dp*(Dml2+ Conjg(Transpose(Dml2)) )
!--------------------
! mHd2
!--------------------

betamHd21  = 2._dp*(AbsTlam) - (6*AbsM1*g1p2)/5._dp - 6*AbsM2*g2p2 + 2*Abslam*mHd2 +  &
&  2*Abslam*mHu2 + 2*Abslam*ms2 + 6._dp*(TrCTdTpTd) + 2._dp*(TrCTeTpTe) + 6._dp*(Trmd2YdadjYd)&
&  + 2._dp*(Trme2YeadjYe) + 2._dp*(Trml2adjYeYe) + 6._dp*(Trmq2adjYdYd) + 6*mHd2*TrYdadjYd +&
&  2*mHd2*TrYeadjYe - g1*sqrt3ov5*Tr1(1)

If (TwoLoopRGE) Then
betamHd22 = 0

DmHd2 = oo16pi2*( betamHd21 + oo16pi2 * betamHd22 )

Else
DmHd2 = oo16pi2* betamHd21
End If

!--------------------
! mHu2
!--------------------

betamHu21  = 2._dp*(AbsTlam) - (6*AbsM1*g1p2)/5._dp - 6*AbsM2*g2p2 + 2*Abslam*mHd2 +  &
&  2*Abslam*mHu2 + 2*Abslam*ms2 + 6._dp*(TrCTuTpTu) + 2._dp*(TrCTvTpTv) + 2._dp*(Trml2adjYvYv)&
&  + 6._dp*(Trmq2adjYuYu) + 6._dp*(Trmu2YuadjYu) + 2._dp*(Trmv2YvadjYv) + 6*mHu2*TrYuadjYu +&
&  2*mHu2*TrYvadjYv + g1*sqrt3ov5*Tr1(1)

If (TwoLoopRGE) Then
betamHu22 = 0

DmHu2 = oo16pi2*( betamHu21 + oo16pi2 * betamHu22 )

Else
DmHu2 = oo16pi2* betamHu21
End If

!--------------------
! md2
!--------------------

betamd21  = (-8*AbsM1*g1p2*id3R)/15._dp - (32*AbsM3*g3p2*id3R)/3._dp + 2._dp*(md2YdadjYd)&
&  + 4._dp*(TdadjTd) + 4*mHd2*YdadjYd + 2._dp*(YdadjYdmd2) + 4._dp*(Ydmq2adjYd)          &
&  + 2*g1*id3R*ooSqrt15*Tr1(1)

If (TwoLoopRGE) Then
betamd22 = 0

Dmd2 = oo16pi2*( betamd21 + oo16pi2 * betamd22 )

Else
Dmd2 = oo16pi2* betamd21
End If

Call Chop(Dmd2)

Forall(i1=1:3) Dmd2(i1,i1) =  Real(Dmd2(i1,i1),dp)
Dmd2 = 0.5_dp*(Dmd2+ Conjg(Transpose(Dmd2)) )
!--------------------
! mu2
!--------------------

betamu21  = (-32*AbsM1*g1p2*id3R)/15._dp - (32*AbsM3*g3p2*id3R)/3._dp +               &
&  2._dp*(mu2YuadjYu) + 4._dp*(TuadjTu) + 4*mHu2*YuadjYu + 2._dp*(YuadjYumu2)            &
&  + 4._dp*(Yumq2adjYu) - 4*g1*id3R*ooSqrt15*Tr1(1)

If (TwoLoopRGE) Then
betamu22 = 0

Dmu2 = oo16pi2*( betamu21 + oo16pi2 * betamu22 )

Else
Dmu2 = oo16pi2* betamu21
End If

Call Chop(Dmu2)

Forall(i1=1:3) Dmu2(i1,i1) =  Real(Dmu2(i1,i1),dp)
Dmu2 = 0.5_dp*(Dmu2+ Conjg(Transpose(Dmu2)) )
!--------------------
! me2
!--------------------

betame21  = (-24*AbsM1*g1p2*id3R)/5._dp + 2*(me2YeadjYe + 2._dp*(TeadjTe)             &
&  + 2*mHd2*YeadjYe + YeadjYeme2 + 2._dp*(Yeml2adjYe)) + 2*g1*id3R*sqrt3ov5*Tr1(1)

If (TwoLoopRGE) Then
betame22 = 0

Dme2 = oo16pi2*( betame21 + oo16pi2 * betame22 )

Else
Dme2 = oo16pi2* betame21
End If

Call Chop(Dme2)

Forall(i1=1:3) Dme2(i1,i1) =  Real(Dme2(i1,i1),dp)
Dme2 = 0.5_dp*(Dme2+ Conjg(Transpose(Dme2)) )
!--------------------
! mv2
!--------------------

betamv21  = 2*(2._dp*(lamNClamNmv2) + 4._dp*(lamNCmv2ClamN) + 4*lamNClamN*ms2 +       &
&  2._dp*(mv2lamNClamN) + mv2YvadjYv + 4._dp*(TLNCTLN) + 2._dp*(TvadjTv) +               &
&  2*mHu2*YvadjYv + YvadjYvmv2 + 2._dp*(Yvml2adjYv))

If (TwoLoopRGE) Then
betamv22 = 0

Dmv2 = oo16pi2*( betamv21 + oo16pi2 * betamv22 )

Else
Dmv2 = oo16pi2* betamv21
End If

Call Chop(Dmv2)

Forall(i1=1:3) Dmv2(i1,i1) =  Real(Dmv2(i1,i1),dp)
Dmv2 = 0.5_dp*(Dmv2+ Conjg(Transpose(Dmv2)) )
!--------------------
! ms2
!--------------------

betams21  = 4*(AbsTk + AbsTlam + 3*Abskap*ms2 + Abslam*(mHd2 + mHu2 + ms2)            &
&  + TrCTLNTLN + ms2*TrlamNClamN + 2._dp*(Trmv2lamNClamN))

If (TwoLoopRGE) Then
betams22 = 0

Dms2 = oo16pi2*( betams21 + oo16pi2 * betams22 )

Else
Dms2 = oo16pi2* betams21
End If

!--------------------
! M1
!--------------------

betaM11  = (66*g1p2*M1)/5._dp

If (TwoLoopRGE) Then
betaM12 = 0

DM1 = oo16pi2*( betaM11 + oo16pi2 * betaM12 )

Else
DM1 = oo16pi2* betaM11
End If

Call Chop(DM1)

!--------------------
! M2
!--------------------

betaM21  = 2*g2p2*M2

If (TwoLoopRGE) Then
betaM22 = 0

DM2 = oo16pi2*( betaM21 + oo16pi2 * betaM22 )

Else
DM2 = oo16pi2* betaM21
End If

Call Chop(DM2)

!--------------------
! M3
!--------------------

betaM31  = -6*g3p2*M3

If (TwoLoopRGE) Then
betaM32 = 0

DM3 = oo16pi2*( betaM31 + oo16pi2 * betaM32 )

Else
DM3 = oo16pi2* betaM31
End If

Call Chop(DM3)

!--------------------
! vd
!--------------------

betavd1  = (vd*(-20._dp*(Abslam) + 3._dp*(g1p2) + 15._dp*(g2p2) - 60._dp*(TrYdadjYd)  &
&  - 20._dp*(TrYeadjYe) + 3*g1p2*Xi + 15*g2p2*Xi))/20._dp

If (TwoLoopRGE) Then
betavd2 = 0

Dvd = oo16pi2*( betavd1 + oo16pi2 * betavd2 )

Else
Dvd = oo16pi2* betavd1
End If

!--------------------
! vu
!--------------------

betavu1  = (vu*(-20._dp*(Abslam) + 3._dp*(g1p2) + 15._dp*(g2p2) - 60._dp*(TrYuadjYu)  &
&  - 20._dp*(TrYvadjYv) + 3*g1p2*Xi + 15*g2p2*Xi))/20._dp

If (TwoLoopRGE) Then
betavu2 = 0

Dvu = oo16pi2*( betavu1 + oo16pi2 * betavu2 )

Else
Dvu = oo16pi2* betavu1
End If

!--------------------
! vS
!--------------------

betavS1  = -2*(Abskap + Abslam + TrlamNClamN)*vS

If (TwoLoopRGE) Then
betavS2 = 0

DvS = oo16pi2*( betavS1 + oo16pi2 * betavS2 )

Else
DvS = oo16pi2* betavS1
End If

Call ParametersToG311(Dg1,Dg2,Dg3,DYd,DYe,Dlam,Dkap,DlamN,DYu,DYv,DTd,DTe,            &
& DTlam,DTk,DTLN,DTu,DTv,Dmq2,Dml2,DmHd2,DmHu2,Dmd2,Dmu2,Dme2,Dmv2,Dms2,DM1,             &
& DM2,DM3,Dvd,Dvu,DvS,f)

Iname = Iname - 1

End Subroutine rge311

End Module RGEs_seesaw1nmssm


module ufsLandNoahDriverModule

implicit none

contains

subroutine ufsLandNoahDriverInit(namelist, static, forcing, noah)

  use NamelistRead
  use ufsLandNoahType
  use ufsLandStaticModule
  use ufsLandInitialModule
  use ufsLandForcingModule
  use ufsLandNoahRestartModule

  implicit none

  type (namelist_type)     :: namelist
  type (noah_type)         :: noah
  type (static_type)       :: static
  type (initial_type)      :: initial
  type (forcing_type)      :: forcing
  type (noah_restart_type) :: restart

  call static%ReadStatic(namelist)

  call noah%Init(namelist,namelist%lensub)

  if(namelist%restart_simulation) then
    call restart%ReadRestartNoah(namelist, noah)
  else
    call initial%ReadInitial(namelist)
    call initial%TransferInitialNoah(namelist, noah)
  end if

  call static%TransferStaticNoah(noah)

  call noah%TransferNamelist(namelist)

  call forcing%ReadForcingInit(namelist)

end subroutine ufsLandNoahDriverInit

subroutine ufsLandNoahDriverRun(namelist, static, forcing, noah)

use machine , only : kind_phys
use lsm_noah
use sfc_diff
use set_soilveg_mod
use funcphys
use namelist_soilveg, only : z0_data
use physcons, only : grav   => con_g,    cp   => con_cp,          &
                     hvap   => con_hvap, rd   => con_rd,          &
                     eps    => con_eps, epsm1 => con_epsm1,       &
                     rvrdm1 => con_fvirt,                         &
		     tfreeze=> con_t0c

use interpolation_utilities
use NamelistRead, only         : namelist_type
use ufsLandNoahType, only      : noah_type
use ufsLandStaticModule, only  : static_type
use ufsLandForcingModule
use ufsLandIOModule
use ufsLandNoahRestartModule

type (namelist_type)  :: namelist
type (noah_type)      :: noah
type (forcing_type)   :: forcing
type (static_type)    :: static
type (output_type)    :: output
type (noah_restart_type)    :: restart

integer          :: timestep
double precision :: now_time
real, allocatable, dimension(:) :: rho
real(kind=kind_phys), allocatable, dimension(:) :: prsik1,prslk1,ustar,rb,stress,fm,fh,fm10,fh2,z0pert,ztpert,fake  ! some fields needed for sfc_diff
logical, allocatable, dimension(:) :: lfake

real(kind=kind_phys), parameter :: one     = 1.0_kind_phys
real(kind=kind_phys)            :: cpinv, hvapi

associate (                             &
   ps         => forcing%surface_pressure    ,&
   t1         => forcing%temperature         ,&
   q1         => forcing%specific_humidity   ,&
   dlwflx     => forcing%downward_longwave   ,&
   dswsfc     => forcing%downward_shortwave  ,&
   wind       => forcing%wind_speed          ,&
   tprcp      => forcing%precipitation       ,&
   im         => noah%static%im        ,&
   km         => noah%static%km        ,&
   delt       => noah%static%delt      ,&
   isot       => noah%static%isot      ,&
   ivegsrc    => noah%static%ivegsrc   ,&
   pertvegf   => noah%static%pertvegf  ,&
   lheatstrg  => noah%static%lheatstrg ,&
   errmsg     => noah%static%errmsg    ,&
   errflg     => noah%static%errflg    ,&
   soiltyp    => noah%model%soiltyp    ,&
   vegtype    => noah%model%vegtype    ,&
   slopetyp   => noah%model%slopetyp   ,&
   sigmaf     => noah%model%sigmaf     ,&
   sfcemis    => noah%model%sfcemis    ,&
   snet       => noah%model%snet       ,&
   tg3        => noah%model%tg3        ,&
   cm         => noah%model%cm         ,&
   ch         => noah%model%ch         ,&
   prsl1      => noah%model%prsl1      ,&
   shdmin     => noah%model%shdmin     ,&
   shdmax     => noah%model%shdmax     ,&
   snoalb     => noah%model%snoalb     ,&
   sfalb      => noah%model%sfalb      ,&
   zf         => noah%model%zf         ,&
   bexppert   => noah%model%bexppert   ,&
   xlaipert   => noah%model%xlaipert   ,&
   vegfpert   => noah%model%vegfpert   ,&
   flag_iter  => noah%model%flag_iter  ,&
   flag_guess => noah%model%flag_guess ,&
   land       => noah%model%land       ,&
   prslki     => noah%model%prslki     ,&
   weasd      => noah%model%weasd      ,&
   snwdph     => noah%model%snwdph     ,&
   tskin      => noah%model%tskin      ,&
   srflag     => noah%model%srflag     ,&
   canopy     => noah%model%canopy     ,&
   trans      => noah%model%trans      ,&
   tsurf      => noah%model%tsurf      ,&
   zorl       => noah%model%zorl       ,&
   smc        => noah%model%smc        ,&
   stc        => noah%model%stc        ,&
   slc        => noah%model%slc        ,&
   sncovr1    => noah%model%sncovr1    ,&
   qsurf      => noah%model%qsurf      ,&
   gflux      => noah%model%gflux      ,&
   drain      => noah%model%drain      ,&
   evap       => noah%model%evap       ,&
   hflx       => noah%model%hflx       ,&
   ep         => noah%model%ep         ,&
   runoff     => noah%model%runoff     ,&
   cmm        => noah%model%cmm        ,&
   chh        => noah%model%chh        ,&
   evbs       => noah%model%evbs       ,&
   evcw       => noah%model%evcw       ,&
   sbsno      => noah%model%sbsno      ,&
   snowc      => noah%model%snowc      ,&
   stm        => noah%model%stm        ,&
   snohf      => noah%model%snohf      ,&
   smcwlt2    => noah%model%smcwlt2    ,&
   smcref2    => noah%model%smcref2    ,&
   wet1       => noah%model%wet1        &
   )

allocate(prsik1(im))
allocate(prslk1(im))
allocate( ustar(im))
allocate(    rb(im))
allocate(stress(im))
allocate(    fm(im))
allocate(    fh(im))
allocate(  fm10(im))
allocate(   fh2(im))
allocate(z0pert(im))
allocate(ztpert(im))
allocate(  fake(im))
allocate( lfake(im))
allocate(   rho(im))

pertvegf = 0.d0
bexppert = 0.d0
xlaipert = 0.d0
vegfpert = 0.d0
z0pert   = 0.d0
ztpert   = 0.d0
fake     = -999._kind_phys
lfake    = .false.
ustar    =  0.1
rb       =  0.1
stress   =  0.1
fm       =  1.0
fh       =  1.0
fm10     =  1.0
fh2      =  1.0

flag_iter  = .true.
flag_guess = .false.

call set_soilveg(0,isot,ivegsrc,0)
call gpvs()

zorl     = z0_data(vegtype) * 100.0   ! at driver level, roughness length in cm

time_loop : do timestep = 1, namelist%run_timesteps

  now_time = namelist%initial_time + timestep * namelist%timestep_seconds

  call forcing%ReadForcing(namelist, static, now_time)

  call interpolate_monthly(now_time, im, static%gvf_monthly, sigmaf)
  call interpolate_monthly(now_time, im, static%albedo_monthly, sfalb)

  snet   = dswsfc * (1.0_kind_phys - sfalb)
  prsl1  = ps * exp(-1.d0*zf/29.25d0/t1)
  srflag = 0.0d0
  where(t1 < tfreeze) srflag = 1.d0
  prslki = (exp(zf/29.25d0/t1))**(2.d0/7.d0)
  prsik1 = prslki
  prslk1 = prslki

      call sfc_diff_run (im,rvrdm1,eps,epsm1,grav,                 &  !intent(in)
                         ps,t1,q1,zf,wind,                         &  !intent(in)
                         prsl1,prslki,prsik1,prslk1,               &  !intent(in)
                         sigmaf,vegtype,shdmax,ivegsrc,            &  !intent(in)
                         z0pert,ztpert,                            &  ! mg, sfc-perts !intent(in)
                         flag_iter,.false.,                        &  !intent(in)
                         fake,fake,-999,                           &  !hafs,z0 type !intent(in)
                         lfake,land,lfake,                         &  !intent(in)
                         fake, tskin,fake,                         &  !intent(in)
                         fake, tsurf,fake,                         &  !intent(in)
                         fake,snwdph,fake,                         &  !intent(in)
                         fake,  zorl,fake,                         &  !intent(inout)
                         fake,                                     &  !intent(inout)
                         fake, ustar,fake,                         &  !intent(inout)
                         fake,    cm,fake,                         &  !intent(inout)
                         fake,    ch,fake,                         &  !intent(inout)
                         fake,    rb,fake,                         &  !intent(inout)
                         fake,stress,fake,                         &  !intent(inout)
                         fake,    fm,fake,                         &  !intent(inout)
                         fake,    fh,fake,                         &  !intent(inout)
                         fake,  fm10,fake,                         &  !intent(inout)
                         fake,   fh2,fake,                         &  !intent(inout)
                         errmsg, errflg)                                  !intent(out)

      call lsm_noah_run                                               &
         ( im, km, grav, cp, hvap, rd, eps, epsm1, rvrdm1, ps,        &  !  ---  inputs:
           t1, q1, soiltyp, vegtype, sigmaf,                          &
           sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch,          &
           prsl1, prslki, zf, land, wind, slopetyp,                   &
           shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess,      &
           lheatstrg, isot, ivegsrc,                                  &
           bexppert, xlaipert, vegfpert,pertvegf,                     &  !  ---  in/outs:
           weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc,        &
           canopy, trans, tsurf, zorl,                                &  !  ---  outputs:
           sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff,      &
           cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf,            &
           smcwlt2, smcref2, wet1, errmsg, errflg                     &
         )

  rho = prsl1 / (rd*t1*(one+rvrdm1*q1))
  hflx = hflx * rho * cp
  evap = evap * rho * hvap

  call output%WriteOutputNoah(namelist, noah, forcing, now_time)

  if(namelist%restart_timesteps > 0) then
    if(mod(timestep,namelist%restart_timesteps) == 0) then
      call restart%WriteRestartNoah(namelist, noah, now_time)
    end if
  end if

  if(errflg /= 0) then
    write(*,*) "noahmpdrv_run reporting an error"
    write(*,*) errmsg
    stop
  end if

end do time_loop

end associate

end subroutine ufsLandNoahDriverRun

subroutine ufsLandNoahDriverFinalize()
end subroutine ufsLandNoahDriverFinalize

end module ufsLandNoahDriverModule


subroutine fuvflux
  include 'globals.h'
  integer p,i,j,nterms,nedge,nnonedge,totalsearches
  real :: time1,time2,mintime,maxtime,tottime,utime1,utime2
  integer, parameter :: nbuf=32
  integer :: omp_get_max_threads
  integer :: maxthread, nchunk,k,imin,imax,ib, buf(nbuf),todo(nbuf),ntodo
  integer :: niter

  if(nstar.LE.0.OR.nsphact.LE.0) return
  if(.NOT.directsum.AND.nstar.GT.ntreemin) call startree

  nttotfuv=0; ntminfuv=nbodies; ntmaxfuv=0
  mintime=1.e10; maxtime=0.; tottime=0
  totalsearches=0

  maxthread=1
  nchunk=1
  niter=0
!$  maxthread=omp_get_max_threads()
!$  nchunk=MAX(MIN(10*maxthread,nsphact/nbuf),maxthread)

!$omp parallel &
!$omp shared(root,nchunk) &
!$omp private(p,nterms,time1,time2, &
!$omp imin,imax,ib,i,k,buf,todo,ntodo) &
!$omp reduction( + : nttotfuv,tottime,totalsearches,niter) &
!$omp reduction( MIN : ntminfuv, mintime) &
!$omp reduction( MAX : ntmaxfuv, maxtime)
  call wall_time(time1)
  ncalls=0;nsearches=0
!$omp do schedule(guided,1)
  do k=1,nchunk
    buf=0
    imin=int(nsphact*float(k-1)/nchunk)+1
    imax=int(nsphact*float(k)/nchunk)
    reuseflag=1; searchreuse=0
    do i=imin,imax
      call prefuvwalk(i,imax,nbuf,buf,ntodo,todo)
      do ib=1,ntodo
        niter=niter+1
        p=todo(ib)
        if(.NOT.directsum.AND.nstar.GT.ntreemin) then
          call pcond_fuvwalk(root,p,nterms)
        else
          nterms=nstar
          do j=1,nstar
            bodlist(j)=j+nbodies-nstar
          enddo
        endif

        if(.not.periodic) then
          call pfuvsum(p,nterms)
        else
! check that periodic treewalk gives only nearest image
          call terror('periodic broken at the moment..')
        endif
        nttotfuv=nttotfuv+nterms
        ntminfuv=MIN(ntminfuv,nterms)
        ntmaxfuv=MAX(ntmaxfuv,nterms)
      enddo
    enddo
  enddo
!$omp enddo nowait
  call wall_time(time2)
  mintime=MIN(mintime,time2-time1)
  maxtime=MAX(maxtime,time2-time1)
  tottime=tottime+time2-time1
  totalsearches=totalsearches+nsearches
!$omp end parallel
  ntavgfuv=nttotfuv/nsphact
  if(verbosity.GT.0) then
    print*,'<fuvflux> parts,searches:', nsphact,totalsearches
    write(*,'(" <fuvflux> time:", 3f8.2)') maxtime,mintime,tottime
    print*,'<fuvflux> mn,av,mx:',ntminfuv,ntavgfuv,ntmaxfuv
  endif
  if(niter.NE.nsphact) call terror("fuvflux inconsistent iter count")
end subroutine

subroutine zerofuv
  include 'globals.h'
  fuvheat(pactive(1:nsphact))=0.
end subroutine