text:
! w-rtf-cre-editor v0.0.60
! (c) 2017-2018 Renee Waverly Sonntag
! Licensed under Apache 2.0, see LICENSE file.
! Maximum dictionary size: 300000 entries, each with a max length of 320 chars.

module universal
        ! This module has the core subroutines, independent of terminal REPL interface.

        !---------------------------------------------------------------------------------------------------------------------------
        ! Definition - "Statics"
        !---------------------------------------------------------------------------------------------------------------------------

        character (len=38), parameter :: corev = "w-rtf-cre-editor v0.0.60 (2018-apr-10)"
        integer, parameter :: maxCLen = 320
        integer, parameter :: maxDSize = 300000

        !---------------------------------------------------------------------------------------------------------------------------
        ! Definition - "Globals"
        !---------------------------------------------------------------------------------------------------------------------------

        character (len=320) :: dictionaryfile ! The filename of the main dictionary.
        integer :: numberoflines ! Largest possible number of entries. (Disregarding deletions and metadata.)

        !---------------------------------------------------------------------------------------------------------------------------
        ! Subroutines
        !---------------------------------------------------------------------------------------------------------------------------

        contains

        function finder(collection,word,errlog) RESULT(resultant)
                ! Normal operation returns an array of all entries containing the search word.
                ! `errlog` argument of "match" returns all entries with the search word as a stroke.  This is mainly to present
                ! entries that may exist based on a full stroke provided.
                implicit none

                character(len=maxCLen), dimension(maxDSize), intent(in) :: collection
                character(len=maxCLen), intent(in) :: word
                character(len=maxCLen), intent(out) :: errlog

                character(len=maxCLen), dimension(maxDSize) :: resultant

                integer :: l ! loop variable
                integer :: indexofword
                character :: endchar
                logical :: entryfound

                resultant = ""
                entryfound = .false.
                ! errlog = ""

                do l=1,numberoflines

                        indexofword = index(collection(l), trim(word))
                        if (indexofword > 0) then
                                resultant(l) = collection(l)
                                entryfound = .true.
                        end if
                end do

                if (entryfound .eqv. .false.) then
                        errlog = "No entries matched search criteria."
                else
                        errlog = ""
                end if
                return
        end function finder

        function global_replace(collection, find, replace) RESULT(resultant)
                implicit none
                character(len=maxCLen), dimension(maxDSize), intent(inout) :: collection
                character(len=*), intent(in) :: find
                character(len=*), intent(in) :: replace

                character(len=maxCLen) :: resultant
                integer :: l
                integer :: numreplaced

                numreplaced = 0

                do l=1,numberoflines
                        if (collection(l) == find) then
                                collection(l) = replace
                                numreplaced = numreplaced + 1
                        end if
                end do

                write(resultant,*) numreplaced
                resultant = trim(resultant)//" entries replaced."
                return
        end function global_replace

        function match(dictsteno,dicttrans,stroke) RESULT(resultant)
                character(len=maxCLen), dimension(maxDSize), intent(in) :: dictsteno
                character(len=maxCLen), dimension(maxDSize), intent(in) :: dicttrans
                character(len=maxCLen), intent(in) :: stroke

                character(len=maxCLen) :: resultant
                character(len=maxCLen) :: swp ! Temporary storage of translation.
                integer :: numberof

                resultant = ""
                swp = ""
                numberof = 1

                do l=1,numberoflines
                        if (dictsteno(l) == stroke) then
                                ! just `stroke` so that we don't get any trailing characters.
                                swp = dicttrans(l)
                        else if (index(dictsteno(l),trim(stroke)//"/") == 1) then
                                ! `trim(stroke)` so that we get all chars after it.
                                numberof = numberof + 1
                        end if
                end do

                write(resultant,*) numberof-1
                resultant = trim(swp)//achar(10)//trim(resultant)//" possible successive entries"

                return
        end function match

        subroutine saver(dictsteno,dicttrans,filenumber,creheader)
                ! Writes the steno and translations to the provided file number.

                character(len=maxCLen), dimension(maxDSize), intent(in) :: dictsteno
                character(len=maxCLen), dimension(maxDSize), intent(in) :: dicttrans
                integer, intent(in) :: filenumber
                character(len=maxCLen*5), optional :: creheader

                integer :: l, m, n ! loop variables
                integer :: lengthofsteno
                integer :: lengthoftrans
                logical :: stenoexists
                logical :: transexists

                character(len=maxCLen) :: thissteno
                character(len=maxCLen) :: thistrans

                character(len=maxCLen) :: cresystem
                integer :: cresyscount

                if (present(creheader)) then
                        if (len(trim(creheader)) > 0) then
                                ! Time to isolate the system that created the RTF file, then replace it.
                                do m=(index(creheader,"{\*\cxsystem")+13),len(trim(creheader))
                                        cresystem = creheader(index(creheader,"{\*\cxsystem"):m)
                                        cresyscount = 1
                                        do n=13,len(trim(cresystem))
                                                if (cresystem(n:n) == "{") then
                                                        cresyscount = cresyscount + 1
                                                else if (cresystem(n:n) == "}") then
                                                        cresyscount = cresyscount - 1
                                                end if
                                        end do
                                        if (cresyscount == 0) then
                                                ! When we hit this we have the system tag, and should be able to replace the
                                                ! provider with our own.  If the system tag doesn't exist, this wont be hit.
                                                creheader = creheader(1:index(creheader,"{\*\cxsystem")+12)//"w-rtf-cre-editor"//&
                                                        &creheader(m:len(trim(creheader)))
                                                exit
                                        end if
                                end do
                                write (filenumber,'(a)') trim(creheader)
                        else
                                ! This is redundant of the below overwrite, but the program crashes if we test for length and it's
                                ! not defined.
                                write (filenumber,'(a)') "{\rtf1\ansi{\*\cxrev100}"//&
                                        &"\cxdict{\*\cxsystem w-rtf-cre-editor}{\stylesheet{\s0 Normal;}}"
                        end if
                else
                        write (filenumber,'(a)') "{\rtf1\ansi{\*\cxrev100}"//&
                                &"\cxdict{\*\cxsystem w-rtf-cre-editor}{\stylesheet{\s0 Normal;}}"
                end if

                do l=1,numberoflines
                        thissteno = dictsteno(l)
                        thistrans = dicttrans(l)
                        lengthofsteno = len(trim(thissteno))
                        lengthoftrans = len(trim(thistrans))
                        stenoexists = (lengthofsteno > 0)
                        transexists = (lengthoftrans > 0)

                        if (stenoexists .and. transexists) then
                                do
                                        if (index(thistrans,"{\cxwrtfecr}") /= 0) then
                                                thistrans(index(thistrans,"{\cxwrtfecr}"):index(thistrans,"{\cxwrtfecr}")) = &
                                                        &achar(10)
                                                thistrans = thistrans(1:index(thistrans,"\cxwrtfecr}")-1)&
                                                        &//thistrans(index(thistrans,"\cxwrtfecr}")+11:maxCLen)
                                        else
                                                exit
                                        end if
                                end do
                                write (filenumber,'(a)') '{\*\cxs '//trim(thissteno)//'}'//trim(thistrans)
                        end if
                end do

                write (filenumber,'(a)') "}"
        end subroutine saver

        character(len=maxCLen) function steno_validation(strokes)
                ! Verifies validity of the strokes by ensuring there are no "non-steno" characters.
                ! Validation of characters based on: STKPWHRAO*EUFRPBLGTSDZ #-/ 1234567890
                ! Returns error text.

                character(len=maxCLen),intent(in) :: strokes

                character(len=20) :: swp ! Holds k as character array.

                integer :: k ! loop var

                steno_validation = ""

                ! RTF specification -> 7-bit ASCII.
                ! Extended ASCII -> 8-bit.
                ! I'll just use EASCII to be safe. 256 characters is a terminal standard (CP437 and the like)
                ! TODO: does gfortran support unicode/utf-8?  This would be useful for international dictionaries.
                do k=1,256
                        if (index(strokes,achar(k)) > 0) then
                                ! ASCII not allowed:
                                ! >90 (lowercase and misc symbols)
                                ! <48!32,35,42,45,47 (other symbols, but allow " ","#","*","-","/")
                                ! 58,59,60,61,62,63,64 (":",";","<","=",">","?","@")
                                ! 67,73,74,77,81,86,88,89 (C,I,J,M,Q,V,X,Y)
                                ! 78 (N)
                                if (k > 90 &
                                        & .or. (k < 48 .and. (k /= 32 .and. k /= 35 .and. k /= 42 .and. k /= 45 .and. k /= 47))&
                                        & .or. k==58 .or. k==59 .or. k==60 .or. k==61 .or. k==62 .or. k==63 .or. k==64&
                                        & .or. k==67 .or. k==73 .or. k==74 .or. k==77 .or. k==81 .or. k==86 .or. k==88 .or. k==89&
                                        & .or. k==78&
                                        &) then
                                        write (swp,*) k
                                        steno_validation = trim(steno_validation)&
                                                &//"The character "//achar(k)//" ("//trim(adjustl(swp))//") at position: "
                                        swp = ""
                                        write (swp,*) index(strokes,achar(k))
                                        steno_validation = trim(steno_validation)&
                                                &//trim(adjustl(swp))//" might not be valid in steno."//achar(10)
                                end if
                        end if

                end do
                if (len(trim(steno_validation)) == 0) steno_validation = mech_validation(strokes)
                return
        end function steno_validation

        character(len=maxCLen) function mech_validation(steno_)
                ! Verifies validity of the strokes by ensuring they're mechanically possible.
                ! This function is a visual mess, and I should probably make a flowchart for it.
                ! Returns error text.

                character(len=maxCLen), intent(in) :: steno_
                character(len=maxCLen) :: steno
                character(len=maxCLen) :: swp ! Error text holder.
                character :: k_ ! current char
                character :: m_ ! following char

                character (len=maxCLen) :: a ! loop char
                integer :: k ! loop var

                steno = steno_
                ! TODO steno should be strokes, but I'll let it slide this time.

                ! Numbers are positionally the same as the letter they replace, so let's make them letters.
                do
                        a = steno
                        if (index(steno,'1') > 0) steno(index(steno,'1'):index(steno,'1')) = 'S'
                        if (index(steno,'2') > 0) steno(index(steno,'2'):index(steno,'2')) = 'T'
                        if (index(steno,'3') > 0) steno(index(steno,'3'):index(steno,'3')) = 'P'
                        if (index(steno,'4') > 0) steno(index(steno,'4'):index(steno,'4')) = 'H'
                        if (index(steno,'5') > 0) steno(index(steno,'5'):index(steno,'5')) = 'A'
                        if (index(steno,'6') > 0) steno(index(steno,'6'):index(steno,'6')) = 'F'
                        if (index(steno,'7') > 0) steno(index(steno,'7'):index(steno,'7')) = 'P'
                        if (index(steno,'8') > 0) steno(index(steno,'8'):index(steno,'8')) = 'L'
                        if (index(steno,'9') > 0) steno(index(steno,'9'):index(steno,'9')) = 'T'
                        if (index(steno,'0') > 0) steno(index(steno,'0'):index(steno,'0')) = 'O'
                        if (steno == a) exit
                end do

                swp = "Warning: That entry's steno might not be mechanically possible."
                mech_validation = ""
                !     STKPWHRAO*EUFRPBLGTSDZ
                !     *$ %  ^      ^%   $*
                ! [x] Cannot follow S, T:
                !     FBLG
                ! [x] Cannot follow K:
                !     ST FBLGDZ
                ! [x] Cannot follow P:
                !     TK F
                ! [x] Cannot follow W:
                !     STKP FBLGDZ
                ! [x] Cannot follow H:
                !     STKPW FBLGDZ
                ! [x] Cannot follow R:
                !     STKWH F
                ! [x] Cannot follow A, O, E, U, *:
                !     KWH -
                ! [x] Cannot follow F:
                !     KWH AO*EU -
                ! [x] Cannot follow B:
                !     KPWHRAO*EUF -
                ! [x] Cannot follow L:
                !     KPWHRAO*EUFB -
                ! [x] Cannot follow G:
                !     KPWHRAO*EUFBL -
                ! [x] Cannot follow D:
                !     STKPWHRAO*EUFBLG -
                ! [x] Cannot follow Z:
                !     Literally everything except EOL or /
                do k=1,(len(trim(steno)))
                        k_ = steno(k:k)
                        m_ = steno(k+1:k+1)
                        if (k_ == m_) then ! Letters should neve be back-to-back: always S-S, T-T, R-R, P-P.
                                mech_validation = swp
                                exit
                        end if

                        if (k_ == "K" .or. k_ == "P" .or. k_ == "W" .or. k_ == "H") then
                                if (m_ == "T" .or. m_ == "K" .or. m_ == "F") then
                                        mech_validation = swp
                                        exit
                                end if
                        end if

                        if (k_ == "K" .or. k_ == "W" .or. k_ == "H") then
                                if (m_ == "B" .or. m_ == "L" .or. m_ == "G" .or. m_ == "D" .or. m_ == "Z" .or. m_ == "S") then
                                        mech_validation = swp
                                        exit
                                end if
                        end if

                        if (k_ == "W" .or. k_ == "H" .or. k_ == "R") then
                                if ((k_ /= "R" .and. m_ == "P") .or. m_ == "W") then
                                        mech_validation = swp
                                        exit
                                end if
                        end if

                        if (k_ == "R" .and. m_ == "H") then
                                mech_validation = swp
                                exit
                        end if

                        if (k_ == "R" .and. (m_ == "K" .or. m_ == "F")) then
                                mech_validation = swp
                                exit
                        end if

                        ! Vowel order

                        if ((k_ == "O" .or. k_ == "*" .or. k_ == "E" .or. k_ == "U") .and. m_ == "A") then
                                mech_validation = swp
                                exit
                        end if

                        if ((k_ == "*" .or. k_ == "E" .or. k_ == "U") .and. m_ == "O") then
                                mech_validation = swp
                                exit
                        end if

                        if ((k_ == "E" .or. k_ == "U") .and. m_ == "*") then
                                mech_validation = swp
                                exit
                        end if

                        if (k_ == "U" .and. m_ == "E") then
                                mech_validation = swp
                                exit
                        end if

                        ! Second half

                        if (k_ == "A" .or. k_ == "O" .or. k_ == "E" .or. k_ == "U" .or. k_ == "*"&
                                &.or. k_ == "F" .or. k_ == "B" .or. k_ == "L" .or. k_ == "G" .or. k_ == "D") then
                                if (m_ == "-" .or. m_ == "K" .or. m_ == "W" .or. m_ == "H") then
                                        mech_validation = swp
                                        exit
                                end if
                        end if

                        if (k_ == "F" .or. k_ == "B" .or. k_ == "L" .or. k_ == "G" .or. k_ == "D") then
                                if (m_ == "A" .or. m_ == "O" .or. m_ == "*" .or. m_ == "E" .or. m_ == "U") then
                                        mech_validation = swp
                                        exit
                                end if
                        end if

                        if (k_ == "S" .or. k_ == "T") then
                                if (m_ == "F" .or. m_ == "B" .or. m_ == "L" .or. m_ == "G") then
                                        mech_validation = swp
                                        exit
                                end if
                        end if

                        if (k_ == "B" .or. k_ == "L" .or. k_ == "G" .or. k_ == "D") then
                                if (m_ == "P" .or. m_ == "R" .or. m_ == "F" .or. m_ == "B") then
                                        mech_validation = swp
                                        exit
                                end if
                        end if

                        if (k_ == "Z" .and. (m_ /= "/" .and. m_ /= achar(32))) then
                                mech_validation = swp
                                exit
                        end if

                        if (k_ == "G" .or. k_ == "D") then
                                if (m_ == "L" .or. m_ == "G") then
                                        mech_validation = swp
                                        exit
                                end if
                        end if

                        if (k_ == "D") then
                                if (m_ == "S" .or. m_ == "T") then
                                        mech_validation = swp
                                        exit
                                end if
                        end if

                end do
                return
        end function mech_validation

end module universal
module terminal
        ! REPL IO & CLI access, subroutines should be terminal specific - TUI, GUI implementations in another module.

        use universal
        use ansicolors

        !---------------------------------------------------------------------------------------------------------------------------
        ! Subroutines
        !---------------------------------------------------------------------------------------------------------------------------

        contains

        subroutine repl(dictsteno,dicttrans,ploverfix)
                implicit none

                character(len=maxCLen), dimension(maxDSize), intent(inout) :: dictsteno
                character(len=maxCLen), dimension(maxDSize), intent(inout) :: dicttrans
                logical, intent(inout) :: ploverfix

                character(len=maxCLen) :: command

                command = ""

                print *, "Welcome to the command REPL, type"//c_yellow//" help "//c_reset//"for command list."
                print *, "All metadata will be lost/replaced."
                print *, "NO CHANGES WILL BE SAVED UNTIL YOU QUIT."

                do while (.true.)
                        command = ""
                        write(*,"(a)",advance='no') "wrtfe >> "
                        read (*,'(a)') command

                        if (index(command,"save") == 1) then
                                exit
                        else if (index(command,"cancel") == 1) then
                                stop
                        else if (index(command,"quit") == 1) then
                                print *, "Would you like to save before exiting? (Y/n) + enter"
                                ! Fortran doesn't have a "get single char" function, so we'll make do with the general read().
                                read (*,'(a)') command
                                if (index(command,"Y") == 1) then
                                        exit
                                else if (index(command,"n") == 1) then
                                        stop
                                else
                                        print *, "Response did not meet criteria."
                                end if
                        else
                                call perform(dictsteno,dicttrans,ploverfix,command)
                        end if
                end do
        end subroutine repl

        subroutine perform(dictsteno,dicttrans,ploverfix,command)
                implicit none

                character(len=maxCLen), dimension(maxDSize), intent(inout) :: dictsteno
                character(len=maxCLen), dimension(maxDSize), intent(inout) :: dicttrans
                logical, intent(inout) :: ploverfix

                character(len=maxCLen), intent(inout) :: command

                character(len=maxCLen) :: arguments
                character(len=maxCLen), dimension(maxDSize) :: swapspace ! multiple use variable: used in `finds`, `findt`.

                integer :: dswap ! multiple use variable: used in `del`, `fixs`, `fixt`.

                character(len=maxCLen) :: asteno ! added strokes
                character(len=maxCLen) :: atrans ! added translation

                character(len=maxCLen) :: errlog ! multiple use error text dump.
                integer :: iostaterr ! read commands require a variable to dump into for error handling.

                arguments = ""
                dswap = 0

                if (index(command,"finds") == 1) then
                        arguments = command(7:maxCLen)
                        !print *, command
                        if (arguments(1:1) == "'") arguments = arguments(2:maxCLen)
                        swapspace = finder(dictsteno,arguments,errlog)
                        if (numberoflines == 0) print*, "There are no entries in the dictionary."
                        if (len(trim(errlog)) > 12) print*, trim(errlog)
                        call printer(swapspace,dicttrans)
                else if (index(command,"findt") == 1) then
                        arguments = command(7:maxCLen)
                        swapspace = finder(dicttrans,arguments,errlog)
                        if (numberoflines == 0) print*, "There are no entries in the dictionary."
                        if (len(trim(errlog)) > 12) print*, trim(errlog)
                        call printer(dictsteno,swapspace)
                else if (index(command,"del") == 1) then
                        arguments = command(5:maxCLen)
                        read(arguments,*,iostat=iostaterr) dswap
                        if (iostaterr > 0 .or. dswap > numberoflines .or. dswap == 0) then
                                print *, c_red//"No valid entry number was provided."//c_reset
                        else
                                print *, c_yellow//"Deleted entry:"
                                print '(a,I12,a,a,a,a)', &
                                        &c_red, dswap, " "//c_cyan, trim(dictsteno(dswap)), &
                                        & c_red//" -> "//c_reset, trim(dicttrans(dswap))
                                dictsteno(dswap) = ""
                                dicttrans(dswap) = ""
                        end if
                        if (dswap == numberoflines) then
                                numberoflines = numberoflines - 1
                        end if
                else if (index(command,"add") == 1) then
                        arguments = command(5:maxCLen)
                        asteno = arguments(1:index(arguments," ")-1)
                        atrans = arguments(index(arguments," ")+1:maxCLen)
                        if (atrans /= "") then
                                numberoflines = numberoflines + 1
                                dictsteno(numberoflines) = asteno
                                dicttrans(numberoflines) = atrans
                                errlog = steno_validation(asteno)
                                print *, "Added entry:"
                                print '(a,I12,a,a,a,a)', &
                                        &c_green, numberoflines, " "//c_cyan, trim(dictsteno(numberoflines)), &
                                        & c_green//" -> "//c_reset, trim(dicttrans(numberoflines))
                        else
                                errlog = c_red//"Cancelled add: translation not provided."//c_reset
                        end if

                        print *, c_yellow//trim(errlog)//c_reset !Error log for validation.
                else if (index(command,"fixs") == 1) then
                        arguments = command(6:maxCLen)
                        if (arguments(1:1) == "'") arguments = arguments(2:maxCLen)
                        asteno = arguments(index(arguments," ")+1:maxCLen)
                        read(arguments(1:index(arguments," ")-1),*,iostat=iostaterr) dswap
                        if (iostaterr > 0 .or. dswap > numberoflines .or. len(trim(arguments)) == 0) then
                                print *, c_red//"No valid entry number was provided."//c_reset
                        else
                                print *, c_yellow//"Replaced entry:"//c_reset
                                print '(a,I12,a,a,a,a)', &
                                        &c_red, dswap, " "//c_cyan, trim(dictsteno(dswap)), &
                                        & c_red//" -> "//c_reset, trim(dicttrans(dswap))
                                print '(a,I12,a,a,a,a)', &
                                        &c_green, dswap, " "//c_cyan, trim(asteno), &
                                        & c_green//" -> "//c_reset, trim(dicttrans(dswap))
                                !print *, "Replacing Entry ", dswap, ": [", trim(dictsteno(dswap)), " ", trim(dicttrans(dswap)),&
                                !        &"] with [", trim(asteno), " ", trim(dicttrans(dswap)), "]"
                                dictsteno(dswap) = asteno
                        end if
                else if (index(command,"fixt") == 1) then
                        arguments = command(6:maxCLen)
                        atrans = arguments(index(arguments," ")+1:maxCLen)
                        read(arguments(1:index(arguments," ")-1),*,iostat=iostaterr) dswap
                        if (iostaterr > 0 .or. dswap > numberoflines .or. len(trim(arguments)) == 0) then
                                print *, c_red//"No valid entry number was provided."//c_reset
                        else
                                print *, c_yellow//"Replaced entry:"//c_reset
                                print '(a,I12,a,a,a,a)', &
                                        &c_red, dswap, " "//c_cyan, trim(dictsteno(dswap)), &
                                        & c_red//" -> "//c_reset, trim(dicttrans(dswap))
                                print '(a,I12,a,a,a,a)', &
                                        &c_green, dswap, " "//c_cyan, trim(dictsteno(dswap)), &
                                        & c_green//" -> "//c_reset, trim(atrans)
                                !print *, "Replacing Entry ", dswap, ": [", trim(dictsteno(dswap)), " ", trim(dicttrans(dswap)),&
                                !        & "] with [", trim(dictsteno(dswap)), " ", trim(atrans), "]"
                                dicttrans(dswap) = atrans
                        end if
                else if (index(command,"match") == 1) then
                        arguments = command(7:maxCLen)
                        if (arguments(1:1) == "'") arguments = arguments(2:maxCLen)
                        print *, trim(match(dictsteno,dicttrans,arguments))
                else if (index(command,"test") == 1) then
                        call find_duplicates(dictsteno,dicttrans)
                else if (index(command,"count") == 1) then
                        print *, numberoflines
                else if (index(command,"to") == 1) then
                        dictionaryfile = trim(command(4:maxCLen))
                else if (index(command,"colors") == 1) then
                        if (len(c_reset) == 0) then
                                call usecolors(.true.)
                        else
                                call usecolors(.false.)
                        end if
                else if (index(command,"greplaces") > 0) then
                        arguments = command(11:maxCLen)
                        errlog = global_replace(dictsteno,arguments(1:index(arguments," ")-1),&
                                &arguments(index(arguments," ")+1:maxCLen))
                        print *, c_red//arguments(1:index(arguments," ")-1)
                        print *, c_green//trim(arguments(index(arguments," ")+1:maxCLen))//c_reset
                        if (len_trim(errlog) > 1) then
                                write (*,'(a)') trim(errlog)
                        end if
                else if (index(command,"greplacet") > 0) then
                        arguments = command(11:maxCLen)
                        errlog = global_replace(dicttrans,arguments(1:index(arguments," ")-1),&
                                &arguments(index(arguments," ")+1:maxCLen))
                        print *, c_red//arguments(1:index(arguments," ")-1)
                        print *, c_green//trim(arguments(index(arguments," ")+1:maxCLen))//c_reset
                        if (len_trim(errlog) > 1) then
                                write (*,'(a)') trim(errlog)
                        end if
                else if (index(command,"help") > 0) then
                        print *, "Command list:"
                        print *, c_yellow//"add"//c_cyan//" [STROKES] [string] "&
                                &//c_reset//"- Adds the entry (No spaces in steno)."
                        print *, c_yellow//"del"//c_cyan//" [number] "&
                                &//c_reset//"- Deletes the entry from both arrays."
                        print *, c_yellow//"finds"//c_cyan//" [string] "&
                                &//c_reset//"- Finds [string] in the steno array."
                        print *, c_yellow//"findt"//c_cyan//" [string] "&
                                &//c_reset//"- Finds [string] in the translation array."
                        print *, c_yellow//"fixs"//c_cyan//" [number] [STROKES] "&
                                &//c_reset//"- Replaces the given enrty's steno."
                        print *, c_yellow//"fixt"//c_cyan//" [number] [string] "&
                                &//c_reset//"- Replaces the given entry's translation."
                        print *, c_yellow//"match"//c_cyan//" [STROKES] "&
                                &//c_reset//"- Returns translation of direct match, and number of further translations."
                        print *, c_yellow//"greplaces"//c_cyan//" [STROKES] [STROKES]"&
                                &//c_reset//"- Replaces (exact match) first stroke with second across all entries."
                        print *, c_yellow//"greplacet"//c_cyan//" [string] [string]"&
                                &//c_reset//"- Replaces (exact match) first translation with second across all entries."
                        print *, c_yellow//"test "&
                                &//c_reset//"- Alerts you to any duplicate entries in the dictionary."
                        print *, c_yellow//"count "&
                                &//c_reset//"- Prints the number of entries in the dictionary."
                        print *, c_yellow//"colors "&
                                &//c_reset//"- Toggles colors on/off in REPL interface."
                        print *, c_yellow//"to"//c_cyan//" [file path] "&
                                &//c_reset//"- Changes the destination for exit/save."
                        print *, c_yellow//"plover "&
                                &//c_reset//"- also saves a plover-specific (But RTF) dictionary (fixes \line)."
                        print *, c_yellow//"save "&
                                &//c_reset//"- Saves RTF/CRE file, then exits."
                        print *, c_yellow//"quit "&
                                &//c_reset//"- prompt for save or cancel"
                        print *, c_yellow//"cancel "&
                                &//c_reset//"- exits without saving."
                else if (index(command,"plover") > 0) then
                        ploverfix = .true.
                else
                        print *, "Command not found, try help."
                end if
        end subroutine perform

        subroutine printer(steno,trans)
                ! Prints out the contents of the two arrays side-by-side prefixed by row number.
                implicit none

                character(len=maxCLen), dimension(maxDSize), intent(in) :: steno
                character(len=maxCLen), dimension(maxDSize), intent(in) :: trans

                integer :: l
                integer :: lengthofsteno
                integer :: lengthoftrans
                logical :: stenoexists
                logical :: transexists

                do l=1,numberoflines
                        lengthofsteno = len(trim(steno(l)))
                        lengthoftrans = len(trim(trans(l)))
                        stenoexists = (lengthofsteno > 0)
                        transexists = (lengthoftrans > 0)
                        if (stenoexists .and. transexists) then
                                print '(a,I12,a,a,a,a)', &
                                        &c_yellow, l, c_cyan//" ", trim(steno(l)), c_yellow//" -> "//c_reset, trim(trans(l))
                        end if
                end do
        end subroutine

        subroutine all_arguments(cmd,filename)
                ! Removes the filename from `cmd`.

                character(len=maxCLen), intent(out) :: cmd
                character(len=maxCLen), intent(in) :: filename

                character(len=maxCLen) :: arguments

                integer :: afterfile
                integer :: lenfile

                arguments = ""

                afterfile = 0
                lenfile = 0

                call get_command(cmd)

                afterfile = index(cmd,trim(filename))
                lenfile = len(trim(filename))

                arguments = cmd(afterfile+lenfile+1:maxCLen)

                cmd = arguments
        end subroutine all_arguments

        subroutine find_duplicates(dictsteno, dicttrans)
                character(len=maxCLen), dimension(maxDSize), intent(inout) :: dictsteno
                character(len=maxCLen), dimension(maxDSize), intent(inout) :: dicttrans

                ! Fill these with entires known to be duplicates, then crosscheck.
                character(len=maxCLen), dimension(maxDSize) :: nopesteno
                character(len=maxCLen), dimension(maxDSize) :: nopetrans

                integer :: dentry ! outer loop var
                integer :: dtest ! inner loop var

                integer :: nsteno ! number of duplicate strokes of core
                integer :: ntrans ! number of duplicate translations of core

                character(len=maxCLen) :: csteno ! core strokes
                character(len=maxCLen) :: ctrans ! core translation

                character(len=maxCLen) :: osteno ! list of duplicate strokes of core
                character(len=maxCLen) :: otrans ! list of duplicate translations of core

                character(len=7) :: tempchar

                integer :: iostator
                integer :: dsteno ! number of strokes already deemed duplicates.
                integer :: dtrans ! number of translations already deemed duplicates.

                !real :: start,finish
                !call cpu_time(start)

                nsteno = 0
                ntrans = 0

                dsteno = 0
                dtrans = 0

                osteno = ""
                otrans = ""

                do dentry=1,numberoflines-1
                        csteno = dictsteno(dentry)
                        ctrans = dicttrans(dentry)

                        ! If strokes and translation exist, it's an entry.  Then make sure it's not a duplicate.
                        if (len(trim(csteno)) > 0 .and. len(trim(ctrans)) > 0) then

                                do dtest = dentry+1,numberoflines
                                        if (csteno == dictsteno(dtest) .and. ctrans ==&
                                                &dicttrans(dtest)) then

                                                print *, "Duplicate entry detected:"
                                                print '(a,I12,a,a,a,a)', &
                                                        &c_yellow, dentry, " "//c_cyan, trim(csteno), &
                                                        & c_yellow//" -> "//c_reset, trim(ctrans)
                                                print '(a,I12,a,a,a,a)', &
                                                        &c_red, dtest, " "//c_cyan, trim(dictsteno(dtest)), &
                                                        & c_red//" -> "//c_reset, trim(dicttrans(dtest))
                                                !print *, dentry, " ", trim(csteno), " ", trim(ctrans)
                                                !print *, dtest, " ", trim(dictsteno(dtest)), " ", trim(dicttrans(dtest))
                                                dictsteno(dtest) = ""
                                                dicttrans(dtest) = ""
                                                print *, c_yellow//"Second entry deleted."//c_reset

                                        else if (csteno == dictsteno(dtest)&
                                &.and. .not. indexarr(nopetrans,ctrans,dtrans)&
                                &.and. .not. indexarr(nopesteno,csteno,dsteno)) then
                                                write(tempchar, "(I0)") dtest

                                                osteno = trim(osteno)//trim(tempchar)//", "
                                                nsteno = nsteno + 1

                                        else if (ctrans == dicttrans(dtest)&
                                &.and. .not. indexarr(nopetrans,ctrans,dtrans)&
                                &.and. .not. indexarr(nopesteno,csteno,dsteno)) then
                                                write(tempchar, "(I0)") dtest

                                                otrans = trim(otrans)//trim(tempchar)//", "
                                                ntrans = ntrans + 1

                                        end if
                                end do
                                if (nsteno > 0) then
                                        print *, "Entries ", trim(osteno), " and ", dentry
                                        print *, "Share steno ''", trim(csteno), "''"
                                        nsteno = 0
                                        dsteno = dsteno + 1
                                        nopesteno(dsteno) = csteno
                                        osteno = ""
                                end if
                                if (ntrans > 0) then
                                        print *, "Entries ", trim(otrans), " and ", dentry
                                        print *, "share translation ''", trim(ctrans), "''"
                                        ntrans = 0
                                        dtrans = dtrans + 1
                                        nopetrans(dtrans) = ctrans
                                        otrans = ""
                                end if
                        end if
                end do
                !call cpu_time(finish)
                !print '("Executed in ", f6.3, " seconds.")', finish-start
        end subroutine find_duplicates

        logical function indexarr(carray,cfind,length)
                character(len=maxCLen) :: cfind
                character(len=maxCLen), dimension(maxDSize) :: carray

                integer :: length
                indexarr = .false.

                do k=1,length
                        if (trim(carray(k)) == trim(cfind)) then
                                indexarr = .true.
                                exit
                        end if
                end do
                return
        end function indexarr

        subroutine printform()
        end subroutine printform

end module terminal

program waffleRTFEditor
        use universal
        use terminal
        use ansicolors
        implicit none

        !---------------------------------------------------------------------------------------------------------------------------
        ! Definition
        !---------------------------------------------------------------------------------------------------------------------------

        integer :: i, j, k, l ! loop var.

        character(len=maxCLen) :: arg
        logical :: dictpresent
        integer :: iostaterror

        character(len=maxCLen), dimension(maxDSize) :: dictionarycontent ! Fortran arrays start at 1.
        character(len=maxCLen), dimension(maxDSize) :: dictentry
        character(len=maxCLen), dimension(maxDSize) :: dictsteno

        logical :: isentry

        integer :: lengthofsteno

        logical :: ploverfix ! used as flag for whether or not to create a plover-specific copy.

        character(len=maxCLen*5) :: creheader ! Following the CRE spec, the header metadata.
        integer :: creheaderrows ! The number of rows taken up by header metadata.

        integer :: multilines

        !---------------------------------------------------------------------------------------------------------------------------
        ! Initialization
        !---------------------------------------------------------------------------------------------------------------------------

        i = 0
        j = 0
        k = 0
        l = 0

        arg = ""
        dictpresent = .false.
        iostaterror = 0

        ! Array initialization takes a VERY long time...
        ! We'll just assume the indices that matter get initialized during execution.
        ! dictionarycontent = ""
        ! dictentry = ""
        ! dictsteno = ""

        isentry = .false.

        lengthofsteno = 0

        ploverfix = .false.

        creheader = ""
        creheaderrows = 0

        multilines = 0

        !---------------------------------------------------------------------------------------------------------------------------
        ! Globals - from universal module
        !---------------------------------------------------------------------------------------------------------------------------

        dictionaryfile = ""
        numberoflines = 0

        !---------------------------------------------------------------------------------------------------------------------------
        ! Execution - Arguments and Validation
        !---------------------------------------------------------------------------------------------------------------------------

        ! Get command Arguments first.
        if (command_argument_count()==0) then
                print *, "No argument detected, try --help (-h, --h, -help)."
                stop
        end if

        do j = 1,1
                call get_command_argument(j, arg)

                select case(trim(arg))
                case ('-v', '--version', '-version', '--v')
                        print *, corev
                        stop
                case ('-h', '--help', '-help', '--h')
                        print *, "Usage: ./wrtfe filename.rtf [options]"
                        print *, "    Options not necessary, can be found by typing ''help'' in REPL."
                        print *, " -h Displays this help text."
                        print *, " -v Displays version number."
                        stop
                case default
                        ! Temporarily use dictionaryfile as the extension validator.
                        dictionaryfile = arg(len(trim(arg))-3:len(trim(arg)))
                        if ((dictionaryfile /= ".rtf" .and. dictionaryfile /= ".RTF") .or. len(trim(arg)) < 5) then
                                print *, "The provided file: "//trim(arg)
                                print *, "Your file does not appear to be an rtf/cre dictionary."
                                stop
                        end if
                        ! It's good, let's proceed.
                        dictionaryfile = arg
                end select

                inquire (file=dictionaryfile, exist=dictpresent)
                if (.not. dictpresent) then
                        print *, "The provided file does not exist."
                        stop
                end if
                open(1, file=dictionaryfile, iostat = iostaterror)
                if (iostaterror /= 0) then
                        print *, "Error opening provided file: IOSTAT error ", iostaterror, "."
                        stop
                end if
        end do

        !---------------------------------------------------------------------------------------------------------------------------
        ! Execution - Read dictionary and split into two arrays.
        !---------------------------------------------------------------------------------------------------------------------------

        do k=1,maxDSize
                ! Reads each line into an array, until an exception is thrown.
                ! I'd set it up to alert the user if it's not an EOF error, but I haven't been able to get a consistent value for
                ! EOF; IOSTAT 5001 is not the listed as EOF, but OPTION_CONFLICT.  Perhaps my implementation is wrong but it seems
                ! to work perfectly aside from the odd IOSTAT exit code.
                read(1,'(a)',iostat = iostaterror) dictionarycontent(k)
                if (iostaterror > 0) exit

                ! Splits dictionarycontent into two seperate arrays - but only if the values exist.
                isentry = (index(dictionarycontent(k),"{\*\cxs ") == 1)
                if (isentry .and. index(dictionarycontent(k),"}") > 9) then
                        lengthofsteno = index(dictionarycontent(k),"}")

                        ! We need to be aware of possible metadata and how this could affect the number of entries.
                        ! This is a better solution that the previous one, but is still restricted to only correcting "on open"
                        ! count issues.  REMEMBER that the repl ADDS 1 to numberoflines before adding an entry.
                        numberoflines = k-creheaderrows-multilines

                        dictsteno(numberoflines) = dictionarycontent(k)(9:lengthofsteno-1)
                        dictentry(numberoflines) = dictionarycontent(k)(lengthofsteno+1:maxCLen)

                else if (numberoflines == 0) then
                        creheader = trim(creheader)//trim(dictionarycontent(k))//achar(10)
                        creheaderrows = creheaderrows + 1
                else if (index(dictionarycontent(k),"}") /= 1 .and. ichar(dictionarycontent(k)(1:1)) /= 0) then
                        ! I'm assuming the second line is a translation because splitting the steno group makes no sense.
                        dictentry(numberoflines+creheaderrows-1) = &
                                &trim(dictentry(numberoflines+creheaderrows-1))//"{\cxwrtfecr}"//trim(dictionarycontent(k))
                        ! I suppose maintaining the return would be nice, so let's do that.
                        multilines = multilines + 1
                end if
        end do
        ! This removes the trailing achar(10).
        creheader = creheader(1:len(trim(creheader))-1)

        !---------------------------------------------------------------------------------------------------------------------------
        ! Execution - Manipulation.
        !---------------------------------------------------------------------------------------------------------------------------

        call all_arguments(arg,dictionaryfile)
        ! Get all text after the filename.
        if (len(trim(arg)) > 0) then
                ! print *, arg
                call usecolors(.false.)
                call perform(dictsteno,dictentry,ploverfix,arg)
        else
                ! REPL loop, exiting the subroutine means quit has been called.
                call platformcolors()
                call repl(dictsteno,dictentry,ploverfix)
        end if

        ! Save the file:
        close (1)
        open(1, file=dictionaryfile, iostat = iostaterror, status="replace")

        call saver(dictsteno,dictentry,1,creheader)

        close (1)

        !---------------------------------------------------------------------------------------------------------------------------
        ! Execution - Other dictionary outputs
        !---------------------------------------------------------------------------------------------------------------------------
        ! Plover /line converter
        if (ploverfix) then
                open(2, file=dictionaryfile(1:len(trim(dictionaryfile))-4)//".plover.rtf", iostat = iostaterror, status="replace")
                do k=1,numberoflines
                        if (index(dictentry(k),"\line") == 1) then
                                ! Interesting note here:
                                ! Plover glitches up unless this CR is 10.  Normally, GFORTRAN detects the operating system and
                                ! outputs the appropriate CRs - windows uses 13&10.  Since this is a manual CR it does not agree
                                ! with the automatic CRs and this can cause some weird issues when opened in some windows text
                                ! editors.
                                ! TODO Instead of outputing non-standard RTF, let's try outputing a JSON dictionary for plover
                                ! instead.
                                dictentry(k) = "{^"//achar(10)//"^}{-|}"
                        end if
                end do

                call saver(dictsteno,dictentry,2)

                close (2)
        end if

        stop
end program waffleRTFEditor

max_stars_repo_name: waffleston/wrtfe

max_issues_repo_name: waffleston/wrtfe

max_forks_repo_name: waffleston/wrtfe


!___________________________________________________________________________________________________
! Double precision complex error function
! Adapted from the Naval Surface Warfare Center Mathematics Library
! by Alan.Miller @ vic.cmis.csiro.au
! http://www.ozemail.com.au/~milleraj
! Adaptation made by Aleksandar Donev
!___________________________________________________________________________________________________
MODULE Error_Function
   USE Erf_Auxilliary
   IMPLICIT NONE
   PRIVATE
   PUBLIC :: Erf, InvErf

   ! INTEGER, PARAMETER  :: dp = KIND(0.0D0)

   INTERFACE Erf
     MODULE PROCEDURE ErfReal_sp
     MODULE PROCEDURE ErfReal_dp
   END INTERFACE

   INTERFACE InvErf
     MODULE PROCEDURE InvErfReal_sp
     MODULE PROCEDURE InvErfReal_dp
   END INTERFACE

CONTAINS

FUNCTION ErfReal_sp(x) RESULT(fn_val)
!-----------------------------------------------------------------------
!             EVALUATION OF THE REAL ERROR FUNCTION
!-----------------------------------------------------------------------
REAL, INTENT(IN) :: x
REAL             :: fn_val

REAL :: a(5) = (/ .771058495001320E-04, -.133733772997339E-02,   &
                  .323076579225834E-01,  .479137145607681E-01,   &
                  .128379167095513E+00 /),   &
        b(3) = (/ .301048631703895E-02,  .538971687740286E-01,   &
                  .375795757275549E+00 /),   &
        p(8) = (/-1.36864857382717E-07,  5.64195517478974E-01, &
                  7.21175825088309E+00,  4.31622272220567E+01, &
                  1.52989285046940E+02,  3.39320816734344E+02, &
                  4.51918953711873E+02,  3.00459261020162E+02 /),  &
        q(8) = (/ 1.00000000000000E+00,  1.27827273196294E+01, &
                  7.70001529352295E+01,  2.77585444743988E+02, &
                  6.38980264465631E+02,  9.31354094850610E+02, &
                  7.90950925327898E+02,  3.00459260956983E+02 /),  &
        r(5) = (/ 2.10144126479064E+00,  2.62370141675169E+01, &
                  2.13688200555087E+01,  4.65807828718470E+00, &
                  2.82094791773523E-01 /),   &
        s(4) = (/ 9.41537750555460E+01,  1.87114811799590E+02, &
                  9.90191814623914E+01,  1.80124575948747E+01 /)
!-------------------------
REAL :: ax, bot, c = .564189583547756, t, top, x2
!-------------------------
ax = ABS(x)
IF (ax < 0.5) THEN
  t = x*x
  top = ((((a(1)*t + a(2))*t + a(3))*t + a(4))*t + a(5)) + 1.0
  bot = ((b(1)*t + b(2))*t + b(3))*t + 1.0
  fn_val = x*(top/bot)
  RETURN

ELSE IF (ax < 4.0_dp) THEN
  top = ((((((p(1)*ax + p(2))*ax + p(3))*ax + p(4))*ax + p(5))*ax  &
        + p(6))*ax + p(7))*ax + p(8)
  bot = ((((((q(1)*ax + q(2))*ax + q(3))*ax + q(4))*ax + q(5))*ax  &
        + q(6))*ax + q(7))*ax + q(8)
  fn_val = 0.5 + (0.5 - EXP(-x*x)*top/bot)
  IF (x < 0.0_dp) fn_val = -fn_val
  RETURN

ELSE IF (ax < 5.8) THEN
  x2 = x*x
  t = 1.0/x2
  top = (((r(1)*t + r(2))*t + r(3))*t + r(4))*t + r(5)
  bot = (((s(1)*t + s(2))*t + s(3))*t + s(4))*t + 1.0
  fn_val = (c - top/(x2*bot)) / ax
  fn_val = 0.5 + (0.5 - EXP(-x2)*fn_val)
  IF (x < 0.0) fn_val = -fn_val
  RETURN

ELSE
  fn_val = SIGN(1.0,x)
END IF

RETURN
END FUNCTION ErfReal_sp

FUNCTION ErfReal_dp(x) RESULT(fn_val)
!-----------------------------------------------------------------------
!             EVALUATION OF THE REAL ERROR FUNCTION
! Based upon a Fortran 66 routine in the Naval Surface Warfare Center's
! Mathematics Library (1993 version).
! Adapted by Alan.Miller @ vic.cmis.csiro.au
!-----------------------------------------------------------------------
! IMPLICIT NONE
! INTEGER, PARAMETER :: dp = wp ! g77 does not support double precision SELECTED_REAL_KIND(14, 60)      ! `Double precision'

REAL (dp), INTENT(IN) :: x
REAL (dp)             :: fn_val

! Local variables

REAL (dp), PARAMETER :: c = .564189583547756_dp, one = 1.0_dp, half = 0.5_dp, &
                        zero = 0.0_dp
REAL (dp), PARAMETER ::  &
           a(5) = (/ .771058495001320D-04, -.133733772997339D-02, &
                     .323076579225834D-01,  .479137145607681D-01, &
                     .128379167095513D+00 /),  &
           b(3) = (/ .301048631703895D-02,  .538971687740286D-01,  &
                     .375795757275549D+00 /),  &
           p(8) = (/ -1.36864857382717D-07, 5.64195517478974D-01,  &
                      7.21175825088309D+00, 4.31622272220567D+01,  &
                      1.52989285046940D+02, 3.39320816734344D+02,  &
                      4.51918953711873D+02, 3.00459261020162D+02 /), &
           q(8) = (/  1.00000000000000D+00, 1.27827273196294D+01,  &
                      7.70001529352295D+01, 2.77585444743988D+02,  &
                      6.38980264465631D+02, 9.31354094850610D+02,  &
                      7.90950925327898D+02, 3.00459260956983D+02 /), &
           r(5) = (/  2.10144126479064D+00, 2.62370141675169D+01,  &
                      2.13688200555087D+01, 4.65807828718470D+00,  &
                      2.82094791773523D-01 /),  &
           s(4) = (/  9.41537750555460D+01, 1.87114811799590D+02,  &
                      9.90191814623914D+01, 1.80124575948747D+01 /)
REAL (dp) :: ax, bot, t, top, x2
!-------------------------
ax = ABS(x)

IF (ax <= half) THEN
  t = x*x
  top = ((((a(1)*t + a(2))*t + a(3))*t + a(4))*t + a(5)) + one
  bot = ((b(1)*t + b(2))*t + b(3))*t + one
  fn_val = x*(top/bot)
  RETURN
END IF

IF (ax <= 4.0_dp) THEN
  top = ((((((p(1)*ax + p(2))*ax + p(3))*ax + p(4))*ax + p(5))*ax  &
        + p(6))*ax + p(7))*ax + p(8)
  bot = ((((((q(1)*ax + q(2))*ax + q(3))*ax + q(4))*ax + q(5))*ax  &
        + q(6))*ax + q(7))*ax + q(8)
  fn_val = half + (half - EXP(-x*x)*top/bot)
  IF (x < zero) fn_val = -fn_val
  RETURN
END IF

IF (ax < 5.8_dp) THEN
  x2 = x*x
  t = one / x2
  top = (((r(1)*t + r(2))*t + r(3))*t + r(4))*t + r(5)
  bot = (((s(1)*t + s(2))*t + s(3))*t + s(4))*t + one
  fn_val = (c - top/(x2*bot)) / ax
  fn_val = half + (half - EXP(-x2)*fn_val)
  IF (x < zero) fn_val = -fn_val
  RETURN
END IF

fn_val = SIGN(one, x)
RETURN
END FUNCTION ErfReal_dp

FUNCTION InvErfReal_sp(p) RESULT(fn_val)
!-----------------------------------------------------------------------

!              EVALUATION OF THE INVERSE ERROR FUNCTION

!                        ---------------

!     FOR 0 <= P < 1,  W = ERFI(P,Q) WHERE ERF(W) = P. IT IS
!     ASSUMED THAT Q = 1 - P.  IF P < 0, Q <= 0, OR P + Q IS
!     NOT 1, THEN ERFI(P,Q) IS SET TO A NEGATIVE VALUE.

!-----------------------------------------------------------------------
!     REFERENCE. MATHEMATICS OF COMPUTATION,OCT.1976,PP.827-830.
!                  J.M.BLAIR,C.A.EDWARDS,J.H.JOHNSON
!-----------------------------------------------------------------------
REAL, INTENT(IN) :: p
REAL             :: fn_val

! Local variables
REAL :: q
REAL, PARAMETER :: a(6) = (/ .1400216916161353E+03, -.7204275515686407E+03,  &
                             .1296708621660511E+04, -.9697932901514031E+03,  &
                             .2762427049269425E+03, -.2012940180552054E+02 /),  &
                   b(6) = (/ .1291046303114685E+03, -.7312308064260973E+03,  &
                             .1494970492915789E+04, -.1337793793683419E+04,  &
                             .5033747142783567E+03, -.6220205554529216E+02 /),  &
                 a1(7)  = (/ -.1690478046781745E+00, .3524374318100228E+0,  &
                             -.2698143370550352E+02, .9340783041018743E+02,  &
                             -.1455364428646732E+03, .8805852004723659E+02,  &
                             -.1349018591231947E+02 /),  &
                  b1(7) = (/ -.1203221171313429E+00, .2684812231556632E+00,  &
                             -.2242485268704865E+02, .8723495028643494E+02,  &
                             -.1604352408444319E+03, .1259117982101525E+03,  &
                             -.3184861786248824E+02 /),   &
                  a2(9) = (/ .3100808562552958E-04, .4097487603011940E-02,  &
                             .1214902662897276E+00, .1109167694639028E+01,  &
                             .3228379855663924E+01, .2881691815651599E+01,  &
                             .2047972087262996E+01, .8545922081972148E+00,  &
                             .3551095884622383E-02 /),   &
                  b2(8) = (/ .3100809298564522E-04, .4097528678663915E-02,  &
                             .1215907800748757E+00, .1118627167631696E+01,  &
                             .3432363984305290E+01, .4140284677116202E+01,  &
                             .4119797271272204E+01, .2162961962641435E+01 /), &
                  a3(9) = (/ .3205405422062050E-08, .1899479322632128E-05,  &
                             .2814223189858532E-03, .1370504879067817E-01,  &
                             .2268143542005976E+00, .1098421959892340E+01,  &
                             .6791143397056208E+00, -.834334189167721E+00,  &
                             .3421951267240343E+00 /),   &
                  b3(6) = (/ .3205405053282398E-08, .1899480592260143E-05,  &
                             .2814349691098940E-03, .1371092249602266E-01,  &
                             .2275172815174473E+00, .1125348514036959E+01 /), &
                      c = .5625, c1 = .87890625, c2 = -.2302585092994046E+03
REAL :: eps, s, t, v, v1
!-----------------------------------------------------------------------
!     C2 = LN(1.E-100)
!-----------------------------------------------------------------------
IF (p >= 0.0 ) THEN
  q=1.0-p
  eps = MAX(EPSILON(1.0), 1.e-15)

!                      0 <= P <= 0.75

  IF (p <= 0.75) THEN
    v = p * p - c
    t = p * (((((a(6)*v + a(5))*v + a(4))*v + a(3))*v + a(2))*v + a(1))
    s = (((((v + b(6))*v + b(5))*v + b(4))*v + b(3))*v + b(2)) * v + b(1)
  ELSE

!                    0.75 < P <= 0.9375

    IF (p <= 0.9375) THEN
      v = p * p - c1
      t = p * ((((((a1(7)*v + a1(6))*v + a1(5))*v + a1(4))*v + a1(3))*v + a1(2))*v + a1(1))
      s = ((((((v + b1(7))*v + b1(6))*v + b1(5))*v + b1(4))*v + b1(3))*v +  &
          b1(2)) * v + b1(1)
    ELSE

!                  1.E-100 <= Q < 0.0625

      v1 = LOG(q)
      v = 1.0 / SQRT(-v1)
      IF (v1 >= c2) THEN
        t = (((((((a2(9)*v + a2(8))*v + a2(7))*v + a2(6))*v + a2(5))*v +  &
            a2(4))*v + a2(3))*v + a2(2)) * v + a2(1)
        s = v * ((((((((v + b2(8))*v + b2(7))*v + b2(6))*v + b2(5))*v +  &
            b2(4))*v + b2(3))*v + b2(2))*v + b2(1))
      ELSE

!                 1.E-10000 <= Q < 1.E-100

        t = (((((((a3(9)*v + a3(8))*v + a3(7))*v + a3(6))*v + a3(5))*v +  &
            a3(4))*v + a3(3))*v + a3(2)) * v + a3(1)
        s = v * ((((((v + b3(6))*v + b3(5))*v + b3(4))*v + b3(3))*v +  &
                b3(2))*v + b3(1))
      END IF
    END IF
  END IF
  fn_val = t / s
  RETURN
END IF

!                         ERROR RETURN

fn_val = -1.0
RETURN

END FUNCTION InvErfReal_sp

FUNCTION InvErfReal_dp(p) RESULT(fn_val)
!-----------------------------------------------------------------------
REAL (dp), INTENT(IN) :: p
REAL (dp)             :: fn_val

!                  REAL (dp) COMPUTATION OF
!                    THE INVERSE ERROR FUNCTION

!                         ----------------

!     FOR 0 <= P <= 1,  W = DERFI(P,Q) WHERE ERF(W) = P. IT
!     IS ASSUMED THAT Q = 1 - P. IF P < 0, Q <= 0, OR P + Q
!     IS NOT 1, THEN DERFI(P,Q) IS SET TO A NEGATIVE VALUE.

!-----------------------------------------------------------------------
!     REFERENCE. MATHEMATICS OF COMPUTATION,OCT.1976,PP.827-830.
!                  J.M.BLAIR,C.A.EDWARDS,J.H.JOHNSON
!-----------------------------------------------------------------------
REAL (dp) :: q
REAL (dp) :: c = .5625_dp, c1 = .87890625_dp, c2  &
        = -.2302585092994045684017991454684364D+03, r  &
        = .8862269254527580136490837416705726D+00, eps, f, lnq, s, t, x
REAL (dp) :: a(7) = (/ .841467547194693616D-01,  &
        .160499904248262200D+01, .809451641478547505D+01,  &
        .164273396973002581D+02, .154297507839223692D+02,  &
        .669584134660994039D+01, .108455979679682472D+01 /), a1(7)  &
        = (/ .552755110179178015D+2, .657347545992519152D+3,  &
        .124276851197202733D+4, .818859792456464820D+3,  &
        .234425632359410093D+3, .299942187305427917D+2,  &
        .140496035731853946D+1 /), a2(7) = (/ .500926197430588206D+1,  &
        .111349802614499199D+3, .353872732756132161D+3,  &
        .356000407341490731D+3, .143264457509959760D+3,  &
        .240823237485307567D+2, .140496035273226366D+1 /), a3(11)  &
        = (/ .237121026548776092D4, .732899958728969905D6,  &
        .182063754893444775D7, .269191299062422172D7, .304817224671614253D7  &
       , .130643103351072345D7, .296799076241952125D6,  &
        .457006532030955554D5, .373449801680687213D4, .118062255483596543D3  &
       , .100000329157954960D1 /), a4(9) = (/ .154269429680540807D12,  &
        .430207405012067454D12, .182623446525965017D12,  &
        .248740194409838713D11, .133506080294978121D10,  &
        .302446226073105850D08, .285909602878724425D06,  &
        .101789226017835707D04, .100000004821118676D01 /),  &
        b(7) = (/ .352281538790042405D-02, .293409069065309557D+00,  &
        .326709873508963100D+01, .123611641257633210D+02,  &
        .207984023857547070D+02, .170791197367677668D+02,  &
        .669253523595376683D+01 /), b1(6) = (/ .179209835890172156D+3,  &
        .991315839349539886D+3, .138271033653003487D+4, .764020340925985926D+3,  &
        .194354053300991923D+3, .228139510050586581D+2 /),  &
        b2(6) = (/ .209004294324106981D+2, .198607335199741185D+3,  &
        .439311287748524270D+3, .355415991280861051D+3, .123303672628828521D+3,  &
        .186060775181898848D+2 /), b3(10) = (/ .851911109952055378D6,  &
        .194746720192729966D7, .373640079258593694D7, .397271370110424145D7,  &
        .339457682064283712D7 , .136888294898155938D7, .303357770911491406D6,  &
        .459721480357533823D5, .373762573565814355D4, .118064334590001264D3 /),  &
        b4(9) = (/ .220533001293836387D12, .347822938010402687D12,  &
        .468373326975152250D12, .185251723580351631D12,  &
        .249464490520921771D11, .133587491840784926D10,  &
        .302480682561295591D08, .285913799407861384D06,  &
        .101789250893050230D04 /)
!-----------------------------------------------------------------------
!     C2 = LN(1.E-100)
!     R  = SQRT(PI)/2
!-----------------------------------------------------------------------
IF (p >= 0._dp ) THEN
  eps = EPSILON(1.0_dp)
  q=1.0_dp-p

!                      0 <= P <= 0.75

  IF (p <= 0.75_dp) THEN
    x = c - p * p
    s = (((((a(1)*x+a(2))*x+a(3))*x+a(4))*x+a(5))*x+a(6)) * x +a(7)
    t = ((((((b(1)*x+b(2))*x+b(3))*x+b(4))*x+b(5))*x+b(6))*x+b(7)) * x + 1._dp
    fn_val = p * (s/t)
    IF (eps > 1.d-19) RETURN

    x = fn_val
    f = Erf(x) - p
    fn_val = x - r * EXP(x*x) * f
    RETURN
  END IF

!                    0.75 < P <= 0.9375

  IF (p <= 0.9375_dp) THEN
    x = c1 - p * p
    IF (x <= 0.1_dp) THEN
      s = ((((((a1(1)*x+a1(2))*x+a1(3))*x+a1(4))*x+a1(5))*x+a1(6))*x+a1(7))
      t = ((((((b1(1)*x+b1(2))*x+b1(3))*x+b1(4))*x+b1(5))*x+b1(6))*x+1._dp)
    ELSE

      s = ((((((a2(1)*x+a2(2))*x+a2(3))*x+a2(4))*x+a2(5))*x+a2(6))*x+a2(7))
      t = ((((((b2(1)*x+b2(2))*x+b2(3))*x+b2(4))*x+b2(5))*x+b2(6))*x+1._dp)
    END IF

    fn_val = p * (s/t)
    IF (eps > 1.d-19) RETURN

    x = fn_val
    t = derfc1(1,x) - EXP(x*x) * q
    fn_val = x + r * t
    RETURN
  END IF

!                  1.E-100 <= Q < 0.0625

  lnq = LOG(q)
  x = 1._dp / SQRT(-lnq)
  IF (lnq >= c2) THEN
    s = (((((((((a3(1)*x+a3(2))*x+a3(3))*x+a3(4))*x+a3(5))*x+  &
    a3(6))*x+a3(7))*x+a3(8))*x+a3(9))*x+a3(10)) * x + a3(11)
    t = (((((((((b3(1)*x+b3(2))*x+b3(3))*x+b3(4))*x+b3(5))*x+  &
    b3(6))*x+b3(7))*x+b3(8))*x+b3(9))*x+b3(10)) * x + 1._dp
  ELSE

!                 1.E-10000 <= Q < 1.E-100

    s = (((((((a4(1)*x+a4(2))*x+a4(3))*x+a4(4))*x+a4(5))*x+a4(6))*  &
    x+a4(7))*x+a4(8)) * x + a4(9)
    t = ((((((((b4(1)*x+b4(2))*x+b4(3))*x+b4(4))*x+b4(5))*x+  &
    b4(6))*x+b4(7))*x+b4(8))*x+b4(9)) * x + 1._dp
  END IF

  fn_val = s / (x*t)
  IF (eps > 5.d-20) RETURN

  x = fn_val
  t = derfc1(1,x)
  f = (LOG(t)-lnq) - x * x
  fn_val = x + r * t * f
  RETURN
END IF

!                         ERROR RETURN

fn_val = -1._dp
RETURN

END FUNCTION InvErfReal_dp

END MODULE Error_Function
!


text:
C----------------------------------------------------------------------
        subroutine ftc2ll(cval,lval,status)
C       convert a character string to a logical value
C       (assumes that the input string is left justified)
        integer status
        logical lval
        character*(*) cval

        if (status .gt. 0)return

C       convert character string to logical
        if (cval(1:1) .eq.'T')then
                lval=.true.
        else
C               any other character is considered false
                lval=.false.
        end if
        end

ext: f

max_stars_repo_name: iraf-community/stsdas

max_issues_repo_name: kirxkirx/iraf

max_forks_repo_name: kirxkirx/iraf


text:
SUBROUTINE WQSKE0

  !**********************************************************************C
  !
  !  Solve Kinetic Eq from K=KC (surface layer) to K=1 (bottom).
  !  Simplified version that only updates:
  !     IPARAM: 09 Dissolved Organic Phosphorus,
  !             14 Ammonia Nitrogen
  !             19 Dissolved Oxygen
  !    After computing new values, store WQVO+WQV into WQVO(L,K,NWQV) exce
  !    NWQV=15,19,21.
  !
  !  ORGINALLY CODED BY K.-Y. PARK
  !
  !  CHANGE RECORD
  !
  !**********************************************************************C

  USE GLOBAL

  INTEGER :: L,K,IZ,NS
  REAL    :: CNS1,TIMTMP,WQOBT0T,XMRM,WQKD0C,O2WQ_,WQTT1,WQKHN,RNH4NO3_,WQTTC,WQTTD,WQTTG,WQTTM
  REAL    :: TVAL1,TVAL2,TVAL3,TVAL4,RLNSAT1,RLNSAT2,WINDREA,WQWREA,UMRM,VMRM,YMRM,WQD6,WQR6,WQVREA

  CNS1=2.718
  NS=1
  DO L=2,LA
    WQI0BOT(L)=WQI0
  ENDDO
  !
  DO K=KC,1,-1
  !
    DO L=2,LA
      TWQ(L)=TEM(L,K)
      SWQ(L)=MAX(SAL(L,K), 0.0)
      DZWQ(L) = 1.0 / (HPK(L,K))
      VOLWQ(L) = DZWQ(L) / DXYP(L)
      IMWQZT(L)=IWQZMAP(L,K)
    ENDDO
  !
  ! FIND AN INDEX FOR LOOK-UP TABLE FOR TEMPERATURE DEPENDENCY
  !
    DO L=2,LA
  !          IWQT(L) = NINT( 4.*TWQ(L)+121.)
      IWQT(L)=NINT((TWQ(L)-WQTDMIN)/WQTDINC)  ! *** DS-INTL SINGLE L!INE
      IF( IWQT(L) < 1 .OR. IWQT(L) > NWQTD )THEN
        IF( ISDYNSTP == 0 )THEN
          TIMTMP=(DT*FLOAT(N)+TCON*TBEGIN)/86400.
        ELSE
          TIMTMP=TIMESEC/86400.
        ENDIF
        OPEN(2,FILE=OUTDIR//'ERROR.LOG',POSITION='APPEND' &
              ,STATUS='UNKNOWN')
        WRITE(2,*)' *** ERROR IN WATER QUALITY'
        WRITE(2,911) TIMTMP, L, IL(L), JL(L), K, TWQ(L)
        CLOSE(2)
        WRITE(6,600)IL(L),JL(L),K,TWQ(L)
        IWQT(L)=MAX(IWQT(L),1)
        IWQT(L)=MIN(IWQT(L),NWQTD)
  !           STOP 'ERROR!! INVALID WATER TEMPERATURE'
      ENDIF
    ENDDO
    600 FORMAT(' I,J,K,TEM = ',3I5,E13.4)
    911 FORMAT(/,'ERROR: TIME, L, I, J, K, TWQ(L) = ', F10.5, 4I4, F10.4)
  !
    DO L=2,LA
      IZ=IWQZMAP(L,K)
  !
  ! UPDATE SOLAR RADIATION AT BOTTOM OF THIS LAYER
  !
      !WQF2IM = WQF2IM * PSHADE(L)      PMC
  !
  ! ALGAL BASAL METABOLISM & PREDATION
  !
      WQBMC(L) = WQBMRC(IMWQZT(L)) * WQTDRC(IWQT(L))
      WQPRC(L) = WQPRRC(IMWQZT(L)) * WQTDRC(IWQT(L))
  !
  ! THE VARIABLE WQTDGP ADJUSTS PREDATION AND BASAL METABOLISM BASED ON A
  ! LOWER/UPPER OPTIMUM TEMPERATURE FUNCTION.  THIS WILL ALLOW DIATOMS TO
  ! BLOOM IN WINTER IF WQTDGP IS CLOSE TO ZERO.
  !
      WQOBT0T = WQVO(L,K,1)+WQVO(L,K,2)+WQVO(L,K,3)
      WQKRPC(L) = (WQKRC + WQKRCALG*WQOBT0T) * WQTDHDR(IWQT(L))
      WQKLPC(L) = (WQKLC + WQKLCALG*WQOBT0T) * WQTDHDR(IWQT(L))
      XMRM = 0.0
      IF( IDNOTRVA > 0 .AND. K == KSZ(L) )THEN
        XMRM = WQKDCALM(IZ) * WQVO(L,K,IDNOTRVA)
      ENDIF
  !
  ! M. MORTON 08/28/99: ADDED SPATIALLY VARIABLE DOC HYDROLYSIS RATE WQKDC
  !    TO ACHIEVE BETTER CONTROL IN SYSTEMS WITH A COMBINATION OF FRESHWAT
  !    STREAMS AND TIDAL RIVERS WITH DIFFERENT CHARACTERISTICS.
  !
      WQKD0C = (WQKDC(1) + WQKDCALG*WQOBT0T + XMRM)*WQTDMNL(IWQT(L))
      O2WQ_ = MAX(WQVO(L,K,19), 0.0)
      WQTT1 = WQKD0C / (WQKHORDO + O2WQ_+ 1.E-18)
      WQKHR(L) = WQTT1 * O2WQ_
      WQDENIT(L) = 0.0
  !
  ! 7-10 PHOSPHORUS
  ! 11-15 NITROGEN
  !
      WQKHN = (WQKHNC+WQKHND+WQKHNG) / 3.0
      RNH4WQ_ = MAX (WQVO(L,K,14), 0.0)
      RNO3WQ_ = MAX (WQVO(L,K,15), 0.0)
      RNH4NO3_ = RNH4WQ_ + RNO3WQ_
      WQTT1 = WQKHN / (WQKHN+RNH4NO3_+ 1.E-18) * WQOBT0T
      IF( RNH4NO3_ == 0.0 )THEN
        WQPNC(L)=0.0
        WQPND(L)=0.0
        WQPNG(L)=0.0
        WQPNM(L)=0.0
      ELSE
        WQTTC = RNH4WQ_/(WQKHNC+RNO3WQ_+ 1.E-18)
        WQTTD = RNH4WQ_/(WQKHND+RNO3WQ_+ 1.E-18)
        WQTTG = RNH4WQ_/(WQKHNG+RNO3WQ_+ 1.E-18)
        WQTTM = RNH4WQ_/(WQKHNM+RNO3WQ_+ 1.E-18)
        WQPNC(L) = (RNO3WQ_/(WQKHNC+RNH4WQ_+ 1.E-18) &
            + WQKHNC/(RNH4NO3_+ 1.E-18)) * WQTTC
        WQPND(L) = (RNO3WQ_/(WQKHND+RNH4WQ_+ 1.E-18) &
            + WQKHND/(RNH4NO3_+ 1.E-18)) * WQTTD
        WQPNG(L) = (RNO3WQ_/(WQKHNG+RNH4WQ_+ 1.E-18) &
            + WQKHNG/(RNH4NO3_+ 1.E-18)) * WQTTG
        WQPNM(L) = (RNO3WQ_/(WQKHNM+RNH4WQ_+ 1.E-18) &
            + WQKHNM/(RNH4NO3_+ 1.E-18)) * WQTTM
      ENDIF
      WQNIT(L) = WQTDNIT(IWQT(L)) * O2WQ(L) / (WQKHNDO + O2WQ(L) + 1.E-18) * RNH4WQ(L) / (WQKHNN + RNH4WQ(L) + 1.E-18)

  ! TT THE FOLLOWING MODIFICATION TO THE D.O. SATURATION CALCULATION MADE
  ! TT BY J.M. HAMRICK / M.R. MORTON ON 03/08/97.  SEE CHAPRA (1997) PG. 3
  !
      TVAL1=1./(TWQ(L)+273.15)
      TVAL2=TVAL1*TVAL1
      TVAL3=TVAL1*TVAL2
      TVAL4=TVAL2*TVAL2
      RLNSAT1=-139.3441+(1.575701E+5*TVAL1)-(6.642308E+7*TVAL2) &
          +(1.2438E+10*TVAL3)-(8.621949E+11*TVAL4)
      RLNSAT2=RLNSAT1-SWQ(L)*( 1.7674E-2-(1.0754E+1*TVAL1) &
          +(2.1407E+3*TVAL2) )
      WQDOS(L) = EXP(RLNSAT2)
      XDOSAT(L,K) = XDOSAT(L,K) + WQDOS(L)*DTWQ*HPK(L,K)
      IF( K == KC )THEN
  !
  ! DO NOT ALLOW WIND SPEEDS ABOVE 11 M/SEC IN THE FOLLOWING EQUATION:
  !
        WINDREA = WINDST(L)
        WQWREA=0.728*SQRT(WINDREA)+(0.0372*WINDREA-0.317)*WINDREA
  !
  !        WQWREA = 0.728*SQRT(WINDST(L))
  !
        IF( IWQKA(IZ)  ==  0 )THEN
          WQVREA = WQKRO(IZ)
          WQWREA = 0.0
        ENDIF
  !
  !                 WIND VELOCITY COMPUTED ABOVE:
  !
        IF( IWQKA(IZ)  ==  1 )THEN
          WQVREA = WQKRO(IZ)
        ENDIF
  !
  !    WQKRO = 3.933 TYPICALLY
  !
        IF( IWQKA(IZ)  ==  2 )THEN
          UMRM = 0.5*(U(L,K)+U(LEC(L),K))
          VMRM = 0.5*(V(L,K)+V(LNC(L),K))
          XMRM = SQRT(UMRM*UMRM + VMRM*VMRM)
          WQVREA = WQKRO(IZ) * XMRM**0.5 / HP(L)**0.5
        ENDIF
  !
  !    WQKRO = 5.32 TYPICALLY
  !
        IF( IWQKA(IZ)  ==  3 )THEN
          UMRM = MAX(U(L,K), U(LEC(L),K))
          VMRM = MAX(V(L,K), V(LNC(L),K))
          XMRM = SQRT(UMRM*UMRM + VMRM*VMRM)
          WQVREA = WQKRO(IZ) * XMRM**0.67 / HP(L)**1.85
        ENDIF
  !
  ! MODIFIED OWENS AND GIBBS REAERATION EQUATION:
  ! NOTE: NORMALIZED TO A DEPTH OF 1.0 FT, I.E., THIS EQUATION GIVES THE
  !       SAME REAERATION AS OWENS & GIBBS AT 1.0 FT DEPTH; AT HIGHER
  !       DEPTHS IT GIVES LARGER REAERATION THAN OWENS & GIBBS.
  ! WQKRO = 5.32 TYPICALLY
  !
        IF( IWQKA(IZ)  ==  4 )THEN
          UMRM = MAX(U(L,K), U(LEC(L),K))
          VMRM = MAX(V(L,K), V(LNC(L),K))
          XMRM = SQRT(UMRM*UMRM + VMRM*VMRM)
          YMRM = HP(L)*3.0*(1.0 - HP(L)/(HP(L)+0.1524))
          WQVREA = WQKRO(IZ) * XMRM**0.67 / YMRM**1.85
        ENDIF
        IF( IWQKA(IZ)  ==  5 )THEN
          UMRM = MAX(U(L,K), U(LEC(L),K))
          VMRM = MAX(V(L,K), V(LNC(L),K))
          XMRM = SQRT(UMRM*UMRM + VMRM*VMRM)
          WQVREA = 3.7*XMRM
        ENDIF
  !
  ! NOW COMBINE REAERATION DUE TO WATER VELOCITY AND WIND STRESS:
  !
        WQVREA = WQVREA * REAC(IZ)
        WQWREA = WQWREA * REAC(IZ)
        WQP19(L) = - (WQVREA + WQWREA) * DZWQ(L)* WQTDKR(IWQT(L),IZ)
        WQKRDOS(L) = - WQP19(L)*WQDOS(L)
      ELSE
        WQP19(L) = 0.0
      ENDIF
    666 FORMAT(' K,IWQ,IZ,WQTDKR = ',3I5,E12.4)
  ENDDO
  !
  ! TRAPEZOIDAL SOLUTION OF KINETIC EQS: AFTER COMPUTING NEW VALUES, STORE
  ! WQVO+WQV INTO WQVO(L,K,NWQV)
  !
    DO L=2,LA
      IZ=IWQZMAP(L,K)
      WQD6 = - WQKHR(L)
      WQKK(L) = 1.0 / (1.0 - DTWQO2*WQD6)
      WQR6 = (WQWDSL(L,K,6) + WQWPSL(L,K,6)) * VOLWQ(L)
      WQRR(L) = WQVO(L,K,6) + DTWQ*WQR6 +  DTWQO2*WQD6*WQVO(L,K,6)
      WQV(L,K,6)=SCB(L)*( WQRR(L)*WQKK(L) )+(1.-SCB(L))*WQVO(L,K,6)
      WQVO(L,K,6) = WQVO(L,K,6)+WQV(L,K,6)
    ENDDO
    DO L=2,LA
      WQRR(L) = (WQWDSL(L,K,14)+WQWPSL(L,K,14)) * VOLWQ(L)
    ENDDO
    DO L=2,LA
      WQKK(L) = 1.0 / (1.0 + DTWQO2*WQNIT(L))
      WQRR(L) = WQVO(L,K,14) + DTWQ*WQRR(L) &
          - DTWQO2*( WQNIT(L)*WQVO(L,K,14) )
      WQV(L,K,14)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L))*WQVO(L,K,14)
      WQVO(L,K,14) = WQVO(L,K,14)+WQV(L,K,14)
    ENDDO
    DO L=2,LA
      WQKK(L) = 1.0 / (1.0 - DTWQO2*WQP19(L))
      WQRR(L) = (WQWDSL(L,K,19)+WQWPSL(L,K,19)) * VOLWQ(L)
    ENDDO
    IF( K == KC )THEN
      DO L=2,LA
        WQRR(L) = WQRR(L) + WQKRDOS(L)
      ENDDO
    ENDIF
    IF( K == 1 )THEN
      DO L=2,LA
        WQRR(L) = WQRR(L) + WQBFO2(L)*DZWQ(L)
      ENDDO
    ENDIF
    DO L=2,LA
  !
  ! MODIFIED BY MRM 05/23/99 TO ALLOW DIFFERENT AOCR CONSTANTS TO BE APPLI
  !   TO PHOTOSYNTHESIS AND RESPIRATION TERMS FOR MACROALGAE:
  !
      WQRR(L) = WQVO(L,K,19) + DTWQ*WQRR(L) + DTWQO2*( &
          -WQAOCR*WQKHR(L)*WQVO(L,K,6)-WQAONT*WQNIT(L)*WQVO(L,K,14) &
          + WQP19(L)*WQVO(L,K,19) )
  !
  !          RZERO=0.
  !
      WQV(L,K,19)=SCB(L)*(WQRR(L)*WQKK(L))+(1.-SCB(L))*WQVO(L,K,19)
      WQV(L,K,19) = MAX (WQV(L,K,19), 0.0)
      WQVO(L,K,19) = WQVO(L,K,19)+WQV(L,K,19)
    ENDDO
  !
  ! WQTD1FCB=1+DTWQO2*WQS21,WQTD2FCB=1/(1-DTWQO2*S21)
  !
  ENDDO
  !
  ! INCREMENT COUNTER FOR LIMITATION AND XDOXXX DO COMPONENT ARRAYS:
  !
  IF( ISDYNSTP == 0 )THEN
    TIMTMP=DT*FLOAT(N)+TCON*TBEGIN
    TIMTMP=TIMTMP/TCTMSR
  ELSE
    TIMTMP=TIMESEC/TCTMSR
  ENDIF
  TIMESUM3 = TIMESUM3 + TIMTMP

  ! COMPUTE WQCHL,WQTAMP,WQPO4D,WQSAD AT A NEW TIME STEP: WQCHLX=1/WQCHLX
  ! COUPLING TO SEDIMENT MODEL
  !: EVALUATE DEP. FLUX USING NEW VALUES CAUSE IMPLICIT SCHEME IS USED IN SPM

  ! DIURNAL DO ANALYSIS
  ! LIGHT EXTINCTION ANALYSIS

   1111 FORMAT(I12,F10.4)
   1112 FORMAT(2I5,12F7.2)
   1113 FORMAT(2I5,12E12.4)
   1414 FORMAT(I12,11E12.4)
  RETURN
END

max_stars_repo_name: dsi-llc/EFDCPlus

max_forks_repo_name: dsi-llc/EFDCPlus


text:
C
C	$Id: g01esc.f,v 1.6 2008-07-27 00:21:05 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE G01ESC
C
C  Process ESCAPE elements.
C
      include 'g01prm.h'
      include 'gksin.h'
      include 'g01ins.h'
C
      INTEGER  KALL, NBYTES, G01PBL
      SAVE KALL
      DATA KALL/0/
      KALL = KALL+1
C
C  Treat the first call -- put out the opcode, FCTID, and first data
C  record if there is one.
C
      IF (KALL .EQ. 1) THEN
        IF (STRL1 .GT. 0) THEN
          NBYTES = G01PBL(STRL1,1+(MINTFW-1)/8)
        ELSE
C
C  Two bytes for the function identifier and one for the string
C  count of the empty string.
C
          NBYTES = 3
        ENDIF
C
C  Put out class, id, length
C
        CALL GPUTNI (6, 1, NBYTES, RERR)
        IF (RERR .NE. 0)  RETURN
C
C  Put out function identifier (2-byte integer).
C
        CALL GPUTPR (ID(1),MINTFW,1,RERR)
        IF (RERR .NE. 0)  RETURN
C
C  Put out first data record if there is one.
C
        IF (STRL2 .EQ. 0) THEN
          CALL GPUTPS (STR, STRL1,  0, 0, RERR)
        ELSE IF (STRL2 .GT. 0) THEN
          CALL GPUTPS (STR, STRL1, 80, 0, RERR)
        ENDIF
        IF (RERR .NE. 0)  RETURN
C
C  If there is to be no continuation, check for consistency, and
C  reset the parameter "KALL".
C
        IF (CONT .EQ. 0) THEN
          IF (MOD(STRL1,80) .EQ. 0) THEN
            KALL = 0
            RETURN
          ELSE
            RERR = 325
            RETURN
          ENDIF
        ENDIF
      ENDIF
C
C  Treat the continuation calls.
C
      IF (KALL .GT. 1) THEN
        IF (CONT .EQ. 0) THEN
          CALL GPUTPS (STR, 80, 80, 1, RERR)
          IF (RERR .NE. 0)  RETURN
          KALL = 0
        ELSE
          CALL GPUTPS (STR, 80, 80, 1, RERR)
          IF (RERR .NE. 0)  RETURN
        ENDIF
      ENDIF
C
      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!subroutine Open_linearPk based on E. Komatsu's CRL routine which has been modified for use in CosmoSIS as we
!no longer read Pk from a file, all NR removed. EJ
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
MODULE LinearPk
  IMPLICIT none
  INTEGER :: jlo,ndata
  DOUBLE PRECISION, dimension(:), allocatable :: xa,ya,y2a
  DOUBLE PRECISION :: ak_min, ak_max
contains
  SUBROUTINE Open_LinearPk(aklin,pk_lin,n)
    IMPLICIT none
    integer, parameter :: dl=8
    real(dl),  dimension(:) :: aklin
    real(dl),  dimension(:) :: pk_lin
    integer n, ibcbeg,ibcend
    DOUBLE PRECISION :: ybcbeg,ybcend
    INTEGER :: i
    ndata=n
    ALLOCATE(xa(ndata),ya(ndata),y2a(ndata))
    xa=dlog(aklin)
    ya=dlog(pk_lin)
    !Natural spline settings
    ibcbeg = 2
    ybcbeg =0.0D+00
    ibcend = 2
    ybcend =0.0D+00
    CALL spline_cubic_set(ndata,xa,ya,ibcbeg,ybcbeg,ibcend,ybcend,y2a)
    ak_min=aklin(1)
    ak_max=aklin(ndata)
    return
  END SUBROUTINE Open_LinearPk
  SUBROUTINE Close_LinearPk
    DEALLOCATE(xa,ya,y2a)
    return
  END SUBROUTINE Close_LinearPk
END MODULE LinearPk
DOUBLE PRECISION FUNCTION Linear_Pk(ak)
  Use LinearPk
  IMPLICIT none
  DOUBLE PRECISION :: a,b,h,x,y,ak,ypval, yppval
  if (ak .le. ak_min .or. ak .ge. ak_max) then
        linear_pk = 0.0
        return
  endif
  x  = dlog(ak)
  CALL spline_cubic_val( ndata, xa, ya, y2a, x, y, ypval, yppval )
  Linear_Pk = dexp(y)
  return
END FUNCTION Linear_Pk


text:
C--------------------------------------------------------------------
C The user of the OPEN-ADAS system and data (hereinafter "the User")
C accepts the following terms and conditions:
C
C   1. The University of Strathclyde uses all reasonable endeavours
C      to ensure the accuracy of the data provided and any
C      information given, but the University makes no warranty,
C      expressed or implied as to its accuracy, integrity, fitness
C      for purpose and shall not be responsible for the use to
C      which the data is put by the User and/or any consequences
C      arising out of any inaccuracies or omissions.
C
C   2. Any downloaded OPEN-ADAS file is made available here for the
C      personal use of the User only.  It must not be used for any
C      commercial application, incorporated into any web site or in
C      any form re-distributed without express prior written
C      permission from the ADAS Project. In particular, but not by
C      way of limitation, it must not be:
C
C        * inserted into a managed database structure
C        * redistributed along with a modelling or analysis code
C        * made available on a public website.
C
C Permission for OPEN-ADAS data incorporation in non-commercial
C code/system development for scientific advance will not be
C unreasonably withheld, but will be subject to written agreement
C on a case by case basis.
C
C The User will indemnify the University of Strathclyde and keep
C it fully and effectively indemnified against each and every
C claim made against the University as a result of the User's
C use of the data.
C--------------------------------------------------------------------
      subroutine xxcase(input,output,type)

      IMPLICIT NONE

C-----------------------------------------------------------------------
C
C  ****************** FORTRAN77 SUBROUTINE: XXCASE *********************
C
C  PURPOSE: Change a string of arbitrary size into all upper case
C           or all lower case
C
C  CALLING PROGRAM: GENERAL USE.
C
C  INPUT    : (C*(*)) INPUT = Input String
C  INPUT    : (C*2)   TYPE = Type of case to convert to:
C                       'UC' -> Convert to Upper Case
C                       'LC' -> Convert to Lower Case
C                       Anything else -> No conversion
C
C  OUTPUT   : (C*(*)) OUTPUT = Output string in selected case
C
C  ROUTINES : NONE
C
C  AUTHOR   : Allan Whiteford,
C             University of Strathclyde
C
C  VERSION  : 1.1
C  DATE     : 05/09/2001
C  MODIFIED : Allan Whiteford
C             First version.
C
C  VERSION  : 1.2
C  DATE     : 05/05/2005
C  MODIFIED : Martin O'Mullane
C             The routine converted length-1 rather than the whole
C             input string.
C
C-----------------------------------------------------------------------
       integer i
       integer size
C----------------------------------------------------------------------
       character*(*) input
       character*(*) output
       character*2 type
C----------------------------------------------------------------------

       size=len(input)

       write(output(1:size),'(A)') input(1:size)
       i=1

       if (type.eq.'UC' .or. type.eq.'uc') then
10        if    ( ichar(input(i:i)) .ge. ichar('a')
     &    .and.   ichar(input(i:i)) .le. ichar('z')
     &          ) output(i:i)=char(ichar(input(i:i))+ichar('A')
     &                                              -ichar('a'))

          i=i+1
          if (i .le. size) goto 10
       endif

       if (type.eq.'LC' .or. type.eq.'lc') then
20        if    ( ichar(input(i:i)) .ge. ichar('A')
     &    .and.   ichar(input(i:i)) .le. ichar('Z')
     &          ) output(i:i)=char(ichar(input(i:i))+ichar('a')
     &                                              -ichar('A'))

          i=i+1
          if (i .le. size) goto 20
       endif

       end

ext: for


text:
module iterator_module
    use :: integer_range_module, only : integer_range
    use :: iterator_limit_module, only : iterator_limit
    implicit none
    private

    public :: iterator

    type :: iterator
        integer, dimension(:,:), allocatable :: internal_storage
    contains
        procedure :: get_size => get_size
        procedure :: get_items => get_items
        procedure :: get_all_items => get_all_items
        procedure :: get_max_rank => get_max_rank
        procedure :: is_equal => is_equal
        procedure :: is_not_equal => is_not_equal
        generic :: operator(.eq.) => is_equal
        generic :: operator(.ne.) => is_not_equal
        procedure :: cleanup => cleanup
    end type iterator

    interface iterator
        module procedure constructor
        module procedure constructor_from_data
        module procedure constructor_from_range
        module procedure constructor_from_vector
        module procedure constructor_from_limit
    end interface iterator

contains
    function constructor_from_range(rng) result(this)
        type(integer_range), intent(in) :: rng
        type(iterator) :: this

        this = iterator(reshape(rng%get_range(), [rng%get_size(), 1]))
    end function constructor_from_range

    function constructor(first, last, stride) result(this)
        integer, intent(in) :: first, last
        integer, intent(in), optional :: stride
        type(iterator) :: this

        type(integer_range) :: rng

        if (present(stride)) then
            rng = integer_range(first, last, stride)
        else
            rng = integer_range(first, last)
        end if
        this = iterator(rng)
    end function constructor

    function constructor_from_data(iterator_data, mask) result(this)
        integer, dimension(:,:), intent(in) :: iterator_data
        logical, dimension(:), intent(in), optional :: mask
        type(iterator) :: this

        integer :: idx

        if ( present(mask) ) then
            if (size(mask) /= size(iterator_data, 1)) stop
            this%internal_storage = iterator_data(pack([(idx, idx = 1, size(mask))], mask), :)
        else
            this%internal_storage = iterator_data
        end if
    end function constructor_from_data

    function constructor_from_vector(vector) result(this)
        integer, dimension(:), intent(in) :: vector
        type(iterator) :: this

        this = iterator(reshape(vector, [size(vector), 1]))
    end function constructor_from_vector

    function constructor_from_limit(ilim) result(this)
        type(iterator_limit), intent(in) :: ilim
        type(iterator) :: this

        this = iterator(ilim%first, ilim%last, ilim%stride)
    end function constructor_from_limit

    logical function is_equal(this, other)
        class(iterator), intent(in) :: this, other

        is_equal = allocated(this%internal_storage) .eqv. allocated(other%internal_storage)
        if (allocated(this%internal_storage) .and. allocated(other%internal_storage)) then
            is_equal = is_equal .and. &
                all(shape(this%internal_storage) == shape(other%internal_storage))
            if ( is_equal) is_equal = is_equal .and. &
                all(this%internal_storage == other%internal_storage)
        end if
    end function is_equal

    logical function is_not_equal(this, other)
        class(iterator), intent(in) :: this, other

        is_not_equal = .not. this == other
    end function is_not_equal

    pure integer function get_size(this)
        class(iterator), intent(in) :: this

        get_size = 0
        if (allocated(this%internal_storage)) get_size = size(this%internal_storage, 1)
    end function get_size

    pure integer function get_max_rank(this)
        class(iterator), intent(in) :: this

        get_max_rank = 0
        if (allocated(this%internal_storage)) get_max_rank = size(this%internal_storage, 2)
    end function get_max_rank

    pure function get_items(this, rank) result(items)
        class(iterator), intent(in) :: this
        integer, intent(in) :: rank
        integer, dimension(:), allocatable :: items

        allocate(items(this%get_size()))
        if (rank > 0 .and. rank <= this%get_max_rank() ) then
            items = this%internal_storage(:,rank)
        else
            items = 0
        end if
    end function get_items

    pure function get_all_items(this) result(items)
        class(iterator), intent(in) :: this
        integer, dimension(:,:), allocatable :: items

        items = this%internal_storage
    end function get_all_items

    subroutine cleanup(this)
        class(iterator), intent(inout) :: this

        if (allocated(this%internal_storage)) deallocate(this%internal_storage)
    end subroutine cleanup
end module iterator_module

max_stars_repo_name: cheshyre/ntcl-util

max_issues_repo_name: cheshyre/ntcl-util

max_forks_repo_name: cheshyre/ntcl-util