!******************** START FILE MFALSI.FOR ; GROUP MFALSI ******************
!
!	THIS PROGRAM USES A MODIFIED MFALSI METHOD TO FIND
!	A ROOT OF THE FUNCTION F(X), GIVEN TWO GUESSES, X1 AND
!	X2. THE REQUIRED ACCURACY IN X IS GIVEN AS DX
!	THE ATTAINED ACCURACY IN OUTPUT AS ERR
!	IF A SPECIFIED NUMBER OF LOOPS IS EXCEEDED, THE PROGRAM
!	OUTPUTS WHAT IT HAS, AND TYPES THE ESTIMATED ERROR
!
!	NOTE THAT X1 AND X2 COME BACK AS THE LAST TWO GUESSES, WHICH
!	MAY BE USEFUL FOR REPEATED CALLS TO MFALSI WITH ONLY SLIGHTLY
!	CHANGED VERSIONS OF F
!
!	ROB GOLDSTON    AUG. 22, 1983
!
!  MODIF D. MC CUNE 21 DEC 1983
!    ADOPTED AS A SUBROUTINE OF THE TRANSP MAGDIF SYSTEM
!  FOR FINDING THE ZEFF WHICH PRODUCES
!  A SURFACE VOLTAGE MATCHING THE MEASURED DATA.
!    DIFFERENCES FROM THE ORIGINAL [GOLD]FALSI.FOR:
!  ONLY ONE INITIAL GUESS IS REQUIRED.  THE EXTERNAL SUBROUTINE F
!  SUPPLIES INFORMATION NEEDED TO GENERATE THE NEXT GUESS, OR DECIDE
!  THAT THE FIRST GUESS WAS SUFFICIENTLY ACCURATE.
!
!  COMMENT DMC 3 JAN 1984--
!    MFALSI IS ALSO USED BY THE EFIELD ROUTINES TO FIND THE ZEFF WHICH
!  RESULTS IN THE CORRECT PLASMA CURRENT, GIVEN A GUESS AT THE VOLTAGE
!  PROFILE
!
!  dmc Jun 1997:  EXPERT calls removed.  TRCOM has been removed.
!
!    ADDITIONAL ARGUMENTS XMIN,XMAX,LUN1,LUN2,DF
!
!    ARGUMENTS ROOT AND ICNT ARE DELETED (THE EXTERNAL SUBROUTINE
!  STORES THE FINAL ROOT IN TRANSP COMMON)
!
!    THE ERRORS "TOO MANY ITERATIONS" AND "ROOT HEADED TO INFINITY"
!  ARE MADE FATAL; THE WARNING ERROR THAT THE ROOT WANTS TO BE OUTSIDE
!  THE RANGE XMIN TO XMAX IS ADDED
!    THE REQUIRED ACCURACY DX IS MADE RELATIVE-- THE X'S (ZEFF'S) ARE
!  ALWAYS .GT. ZERO  (XMIN HAD BETTER BE .GT. 0)
!    THE ABSOLUTE ERROR DF IS ADDED-- SINCE F IS AN "ERROR" FUNCTION,
!  IF ABS(F).LT.DF THEN SKIP THE FALSI LOOP
!
SUBROUTINE scrMFALSI(F,X1,DF,DX,XMIN,XMAX,LPMAX,LUN1,LUN2,ZSTAT)
  use iso_c_binding, only: fp => c_double
  use physconst_mod, only: zero, one, two
  implicit none
  real(fp) :: dx
  real(fp) :: root
  real(fp) :: err
  integer :: lun2
  integer :: lun1
  integer :: lpmax
  real(fp) :: zsign
  real(fp) :: f2
  real(fp) :: x2
  real(fp) :: zinc
  real(fp) :: zinc2
  real(fp) :: zinc1
  real(fp) :: df
  real(fp) :: fmeas
  real(fp) :: f
  real(fp) :: f1
  real(fp) :: xmaxm
  real(fp) :: xminp
  real(fp) :: xmin
  real(fp) :: xmax
  real(fp) :: xrange
  real(fp) :: x1
  real(fp) :: xsave
  real(fp) :: zstat
  integer :: iminc
  integer :: imaxc
  integer :: icnt
  EXTERNAL F
  !
  !  INPUT THROUGH SUBROUTINE ARGUMENT
  !  =================================
  !
  !	F		NAME OF SUBFUNCTION WHOSE ROOT IS TO BE FOUND
  !			  IT MUST BE DECLARED EXTERNAL IN MAIN PROG
  !	DF		IF ABS(F).LT.DF SKIP THE FALSI LOOP
  !
  !	X1		ONE GUESS AS CLOSE TO ROOT AS POSSIBLE
  ! DELETED	X2		ANOTHER GUESS
  !	DX		REQUIRED RELATIVE ACCURACY IN THE ROOT FOUND
  !	XMIN		MINIMUM ALLOWED ROOT (WARNING IF HIT)
  !	XMAX		MAXIMUM ALLOWED ROOT (WARNING IF HIT)
  !	LPMAX		MAXIMUM NUMBER OF PERMITTED ITERATIONS
  !	LUN1		ERROR OUTPUT CHANNEL
  !	LUN2		2nd ERROR OUTPUT CHANNEL (optional, 0 to disable)
  !
  !  OUTPUT THROUGH SUBROUTINE CALLING ARGUMENT
  !  ==========================================
  !
  !               ZSTAT           FLOATING PT ERROR CODE (FOR TRANSP
  !                               PLOTTING OUTPUT)
  !                   =0.0 IS NORMAL-- ROOT FOUND
  !                   =1.0 MEANS A ROOT LIMIT (MIN OR MAX) WAS HIT
  !                   =2.0 MEANS A SINGULARITY (FLAT SPOT OR LOCAL
  !                        MIN- OR MAXIMUM) WAS ENCOUNTERED, AND THE
  !                        1ST GUESS PASSED TO THIS ROUTINE IS RETURNED
  !                        AS THE "ROOT".
  !
  ! DELETED	ROOT		THE ROOT WHICH HAS BEEN FOUND
  ! DELETED	ERR		ABSOLUTE DIFFERENCE BETWEEN LAST TWO GUESSES
  !
  !
  ICNT=0
  !
  !  EXCEEDED-LIMIT COUNTERS
  !
  IMAXC=0
  IMINC=0
  !
  !  SET DEFAULT STATUS = OK
  !
  ZSTAT=zero
  !
  !  SAVE INITIAL GUESS IN CASE OF PROBLEMS ...
  !
  XSAVE=X1
  !
  !  TO AVOID SOME ARCANE BUGS IT IS NECESSARY TO BIND THE INITIAL
  !  GUESSES AWAY FROM THE ROOT EXTREMA
  !
  XRANGE=XMAX-XMIN
  XMINP=XMIN+.01_fp*XRANGE
  XMAXM=XMAX-.01_fp*XRANGE
  X1=MAX(XMINP,MIN(XMAXM,X1))
  !
  !  PROCESS INITIAL GUESS
  !
  F1=F(X1,FMEAS)
  !
  IF(ABS(F1).LT.DF) THEN
    RETURN
  ENDIF
  !
  !  INITIAL GUESS NOT GOOD ENOUGH, TRY ANOTHER GUESS.
  !   F GIVES (MEASURED VOLTAGE - CALCULATED VOLTAGE)
  !   FMEAS GIVES MEASURED VOLTAGE
  !
  !   IF F IS SAME SIGN AS FMEAS TRY A 5% HIGHER VALUE FOR ZEFF (X)
  !   IF F IS OPPOSITE SIGN TRY A 5% LOWER VALUE FOR ZEFF (X)
  !     BUT TRY THE OTHER WAY IF A LIMIT IS ENCOUNTERED
  !
  ZINC1=.1_fp*XRANGE
  ZINC2=.05_fp*ABS(X1)
  ZINC=MIN(ZINC1,ZINC2)
  IF(ZINC.EQ.zero) ZINC=ZINC1
  IF((F1*FMEAS).GE.zero) THEN
    X2=X1+ZINC
    IF(X2.GT.XMAXM) X2=X1-ZINC
  ELSE
    X2=X1-ZINC
    IF(X2.LT.XMINP) X2=X1+ZINC
  ENDIF
  !
  IF(ABS(X2).LT.1.e-30_fp) X2=one
  !  2ND GUESS...
  F2=F(X2,FMEAS)
  !
  !  RECORD SIGN OF SLOPE
  !
  ZSIGN=SIGN(one,((F2-F1)/(X2-X1)))
  !
  !  ITERATIONS
  !
100 CONTINUE
  !
  ICNT=ICNT+1
  !
  !.......ESCAPE FROM INFINITE LOOP
  IF(ICNT.GT.LPMAX) THEN
    WRITE(LUN1,105) LPMAX
    if(lun2.gt.0) WRITE(LUN2,105) LPMAX
105 FORMAT(' MAXIMUM LOOP NUMBER =',I10,' EXCEEDED IN MFALSI')
    ERR=ABS(X1-X2)
    WRITE(LUN1,107) ERR,DX
    if(lun2.gt.0) WRITE(LUN2,107) ERR,DX
107 FORMAT(' ESTIMATED ERROR =',E8.3,' target error was: ',e8.3)
    zstat=3.0
    return
  ENDIF
  !
  !
  !.......ESCAPE FROM PROBLEM SITUATION
  !
  IF(F1.EQ.F2) THEN
    ZSTAT=two
  ELSE IF(SIGN(one,((F2-F1)/(X2-X1))).NE.ZSIGN) THEN
    ZSTAT=two
  ENDIF
  IF(ZSTAT.EQ.two) THEN
    WRITE(LUN1,110) ZSIGN,X1,F1,X2,F2
    if(lun2.gt.0) WRITE(LUN2,110) ZSIGN,X1,F1,X2,F2
110 FORMAT(' ? MFALSI ABORTED SEEKING ROOT OF FUNCTION F WITH ', &
         'SINGULARITY.  INITIAL 2 GUESSES GAVE SIGN(SLOPE)= ',1PE9.2, &
         'BUT:'/'   F(',1PE11.4,')=',1PE11.4/ &
         '   F(',1PE11.4,')=',1PE11.4)
    F1=F(XSAVE,FMEAS)
    RETURN
  ENDIF
  !
  ROOT=(F1*X2-F2*X1)/(F1-F2)
  !
  !  CHECK LIMITS
  !   A LIMIT MUST BE EXCEEDED TWICE CONSECUTIVELY FOR AN ABNORMAL EXIT
  !    (THIS ALLOWS MFALSI TO BOUNCE OFF THE WALL ONCE AND RECOVER)
  !
  IF(ROOT.GT.XMAX) THEN
    IMAXC=IMAXC+1
    IF(IMAXC.GE.2) GO TO 800
    ROOT=XMAX
  ELSE
    !  OK, CLEAR COUNTER
    IMAXC=0
  ENDIF
  !
  IF(ROOT.LT.XMIN) THEN
    IMINC=IMINC+1
    IF(IMINC.GE.2) GO TO 850
    ROOT=XMIN
  ELSE
    !  OK, CLEAR COUNTER
    IMINC=0
  ENDIF
  !
  IF(ABS(ROOT-X2).LT.ABS(ROOT-X1)) THEN
    X1=ROOT
    F1=F(X1,FMEAS)
  ELSE
    X2=ROOT
    F2=F(X2,FMEAS)
  ENDIF
  !
  !.......CHECK FOR CONVERGEANCE
  IF(ABS(X1-X2).GT.DX) GOTO 100
  !
  !  EXIT
  !
200 CONTINUE
  !
  RETURN
  !
  !  ABNORMAL EXITS (ROOT LIMITS EXCEEDED)--
  !
800 CONTINUE
  !
  !  EXCEEDED MAXIMUM
  !
  WRITE(LUN1,801) ROOT,XMAX
  if(lun2.gt.0) WRITE(LUN2,801) ROOT,XMAX
801 FORMAT(' % MFALSI WARNING-- MAXIMUM ROOT EXCEEDED:'/ &
         '  ROOT=',1PE11.4,'  MAX=',1PE11.4)
  F1=F(XMAX,FMEAS)
  ZSTAT=one
  RETURN
  !
  !  LESS THAN MINIMUM
  !
850 CONTINUE
  !
  WRITE(LUN1,851) ROOT,XMIN
  if(lun2.gt.0) WRITE(LUN2,851) ROOT,XMIN
851 FORMAT(' % MFALSI WARNING-- BELOW MINIMUM ROOT:'/ &
         '  ROOT=',1PE11.4,'  MIN=',1PE11.4)
  F1=F(XMIN,FMEAS)
  ZSTAT=one
  RETURN
!
END SUBROUTINE scrMFALSI
