text:
!
! LBLRTM_Panel_IO
!
! Module containing procedures to read and write LBLRTM Panel objects
!
!
! CREATION HISTORY:
!       Written by:   Paul van Delst, CIMSS/SSEC, 23-Jan-2000
!                     paul.vandelst@ssec.wisc.edu
!

MODULE LBLRTM_Panel_IO

  ! ------------------
  ! Environment setup
  ! -----------------
  ! Module usage
  USE Type_Kinds         , ONLY: FP, IP, DP => Double
  USE Message_Handler    , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message
  USE File_Utility       , ONLY: File_Open
  USE LBLRTM_Parameters  , ONLY: LBLRTM_FILE_EOF, &
                                 LBLRTM_FILE_EOL, &
                                 LBLRTM_FILE_OK , &
                                 LBLRTM_FILE_UNDEF
  USE LBLRTM_Panel_Define, ONLY: LBLRTM_Panel_type      , &
                                 LBLRTM_Panel_Associated, &
                                 LBLRTM_Panel_SetValid  , &
                                 LBLRTM_Panel_IsValid   , &
                                 LBLRTM_Panel_Destroy   , &
                                 LBLRTM_Panel_Create    , &
                                 LBLRTM_Panel_Inspect
  USE LBLRTM_Phdr_Define , ONLY: LBLRTM_Phdr_type
  USE LBLRTM_Phdr_IO     , ONLY: LBLRTM_Phdr_Read , &
                                 LBLRTM_Phdr_Write
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Procedures
  PUBLIC :: LBLRTM_Panel_Read
  PUBLIC :: LBLRTM_Panel_Write
  PUBLIC :: LBLRTM_Panel_IOVersion

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  ! Default message string length
  INTEGER, PARAMETER :: ML = 512

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       LBLRTM_Panel_Read
!
! PURPOSE:
!       Function to read an LBLRTM panel from an LBLRTM format
!       file.
!
! CALLING SEQUENCE:
!       Error_Status = LBLRTM_Panel_Read( &
!                        LBLRTM_Panel, &
!                        FileId      , &
!                        EOF         , &
!                        Double_Panel = Double_Panel, &
!                        Quiet        = Quiet         )
!
! OBJECTS:
!       LBLRTM_Panel:  LBLRTM panel object to hold the data.
!                      UNITS:      N/A
!                      TYPE:       LBLRTM_Panel_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
!       FileId:        The unit number for the already open LBLRTM file.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       EOF:           Integer flag indicating end-of-file status for the
!                      LBLRTM format file after the read. Valid return values
!                      are defined in the LBLRTM_Parameters module.
!                      If == LBLRTM_FILE_EOF:   End-Of-File has been reached.
!                                               The file is then closed.
!                         == LBLRTM_FILE_OK:    No EOF or EOL condition. The
!                                               next read should be the panel
!                                               data.
!                         == LBLRTM_FILE_UNDEF: An error occurred. The file is
!                                               closed.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       Double_Panel:  Set this logical flag to indicate a double-panel file.
!                      If == .FALSE., the file is assumed to be single panel. [DEFAULT]
!                         == .TRUE.,  the file is assumed to be double panel.
!                      If not specified, default is .FALSE.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN), OPTIONAL
!
!       Quiet:         Set this logical argument to suppress INFORMATION
!                      messages being printed to stdout
!                      If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT].
!                         == .TRUE.,  INFORMATION messages are SUPPRESSED.
!                      If not specified, default is .FALSE.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:  The return value is an integer defining the error status.
!                      The error codes are defined in the Message_Handler module.
!                      If == SUCCESS the LBLRTM panel read was successful
!                         == FAILURE an error occurred
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!
! SIDE EFFECTS:
!       If an error occurs or the end-of-file is encountered, the input file is
!       closed.
!
!:sdoc-:
!--------------------------------------------------------------------------------

  FUNCTION LBLRTM_Panel_Read( &
    Panel       , &  ! Output
    FileId      , &  ! Input
    EoF         , &  ! Output
    Double_Panel, &  ! Optional input
    Quiet       , &  ! Optional input
    Debug       ) &  ! Optional input
  RESULT( err_stat)
    ! Arguments
    TYPE(LBLRTM_Panel_type), INTENT(OUT) :: Panel
    INTEGER                , INTENT(IN)  :: FileId
    INTEGER                , INTENT(OUT) :: EoF
    LOGICAL,      OPTIONAL , INTENT(IN)  :: Double_Panel
    LOGICAL,      OPTIONAL , INTENT(IN)  :: Quiet
    LOGICAL,      OPTIONAL , INTENT(IN)  :: Debug
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'LBLRTM_Panel_IO::Read'
    ! Local variables
    CHARACTER(ML) :: msg
    CHARACTER(ML) :: io_msg
    CHARACTER(ML) :: err_msg
    INTEGER :: io_stat
    LOGICAL :: single_panel
    LOGICAL :: noisy
    LOGICAL :: debug_output
    INTEGER :: i, n_spectra
    TYPE(LBLRTM_Phdr_type) :: phdr

    ! Setup
    err_stat = SUCCESS
    ! ...Set panel count
    single_panel = .TRUE.
    IF ( PRESENT(Double_Panel) ) single_panel = .NOT. Double_Panel
    IF ( single_panel ) THEN
      n_spectra = 1
    ELSE
      n_spectra = 2
    END IF
    ! ...Set info output status
    noisy = .TRUE.
    IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet
    ! ...Set debug option
    debug_output = .FALSE.
    IF ( PRESENT(Debug) ) debug_output = Debug
    IF ( debug_output ) THEN
      CALL Display_Message(ROUTINE_NAME,'Entering...',INFORMATION)
      noisy = .TRUE.
    END IF

    ! Check if file is open
    IF ( .NOT. File_Open(FileId) ) THEN
      msg = 'LBLRTM file is not open'
      CALL Read_CleanUp(); RETURN
    END IF

    ! Read the panel header
    err_stat = LBLRTM_Phdr_Read( phdr,FileId,EoF,Debug=Debug )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error reading panel header'
      CALL Read_Cleanup(); RETURN
    END IF

    ! Check for End-of-Layer or End-of-File
    IF ( EoF == LBLRTM_FILE_EOL .OR. &
         EoF == LBLRTM_FILE_EOF      ) RETURN

    ! Allocate the panel object
    CALL LBLRTM_Panel_Create( Panel,phdr,n_spectra,Err_Msg=err_msg )
    IF ( .NOT. LBLRTM_Panel_Associated(Panel) ) THEN
      msg = 'Panel object allocation failed - '//TRIM(err_msg)
      CALL Read_Cleanup(); RETURN
    END IF

    ! Read the spectral data
    DO i = 1, n_spectra

      ! Progress info
      IF ( noisy ) THEN
        WRITE(msg,'(4x,"Reading spectrum #",i0,"...")') i
        CALL Display_Message(ROUTINE_NAME,msg,INFORMATION)
      END IF

      ! Read data and process result
      READ( FileId,IOSTAT=io_stat,IOMSG=io_msg ) Panel%Spectrum(:,i)
      SELECT CASE (io_stat)
        ! ...Error occurred in read
        CASE ( 1: )
          msg = 'Error reading LBLRTM panel data - '//TRIM(io_msg)
          CALL Read_CleanUp(); RETURN
        ! ...End of file has been reached
        CASE (:-1)
          EoF = LBLRTM_FILE_EOF
          CLOSE(FileId)
          RETURN
        ! ...Read was successful, no errors
        CASE DEFAULT
          EoF = LBLRTM_FILE_OK
      END SELECT
    END DO

    ! Tag object as valid
    CALL LBLRTM_Panel_SetValid(Panel)
    IF ( debug_output ) CALL LBLRTM_Panel_Inspect(Panel)

  CONTAINS

    SUBROUTINE Read_CleanUp()
      IF ( File_Open(FileId) ) THEN
        CLOSE( FileId,IOSTAT=io_stat,IOMSG=io_msg )
        IF ( io_stat /= 0 ) &
          msg = TRIM(msg)//'; Error closing input file during error cleanup - '//TRIM(io_msg)
      END IF
      CALL LBLRTM_Panel_Destroy(Panel)
      err_stat = FAILURE
      EoF      = LBLRTM_FILE_UNDEF
      CALL Display_Message( ROUTINE_NAME,msg,err_stat )
    END SUBROUTINE Read_CleanUp

  END FUNCTION LBLRTM_Panel_Read

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       LBLRTM_Panel_Write
!
! PURPOSE:
!       Function to write an LBLRTM panel to an LBLRTM format
!       file.
!
! CALLING SEQUENCE:
!       Error_Status = LBLRTM_Panel_Write( &
!                        LBLRTM_Panel, &
!                        FileId      , &
!                        Quiet = Quiet )
!
! OBJECTS:
!       LBLRTM_Panel:  LBLRTM panel object to write to file.
!                      UNITS:      N/A
!                      TYPE:       LBLRTM_Panel_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! INPUTS:
!       FileId:        The unit number for the already open LBLRTM file.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       Quiet:         Set this logical argument to suppress INFORMATION
!                      messages being printed to stdout
!                      If == .FALSE., INFORMATION messages are OUTPUT [DEFAULT].
!                         == .TRUE.,  INFORMATION messages are SUPPRESSED.
!                      If not specified, default is .FALSE.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:  The return value is an integer defining the error status.
!                      The error codes are defined in the Message_Handler module.
!                      If == SUCCESS the LBLRTM panel write was successful
!                         == FAILURE an error occurred
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!
! SIDE EFFECTS:
!       If an error occurs, the output file is closed.
!
!:sdoc-:
!--------------------------------------------------------------------------------

  FUNCTION LBLRTM_Panel_Write( &
    Panel , &  ! Input
    FileId, &  ! Input
    Quiet , &  ! Optional input
    Debug ) &  ! Optional input
  RESULT( err_stat)
    ! Arguments
    TYPE(LBLRTM_Panel_type), INTENT(IN) :: Panel
    INTEGER                , INTENT(IN) :: FileId
    LOGICAL,       OPTIONAL, INTENT(IN) :: Quiet
    LOGICAL,       OPTIONAL, INTENT(IN) :: Debug
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'LBLRTM_Panel_IO::Write'
    ! Local variables
    CHARACTER(ML) :: msg
    CHARACTER(ML) :: io_msg
    INTEGER :: io_stat
    LOGICAL :: noisy
    LOGICAL :: debug_output
    INTEGER :: i

    ! Setup
    err_stat = SUCCESS
    ! ...Set info output status
    noisy = .TRUE.
    IF ( PRESENT(Quiet) ) noisy = .NOT. Quiet
    ! ...Set debug option
    debug_output = .FALSE.
    IF ( PRESENT(Debug) ) debug_output = Debug
    IF ( debug_output ) THEN
      CALL Display_Message(ROUTINE_NAME,'Entering...',INFORMATION)
      noisy = .TRUE.
    END IF

    ! Check input
    IF ( .NOT. LBLRTM_Panel_IsValid(Panel) ) THEN
      msg = 'Input panel does not contain valid data'
      CALL Write_CleanUp(); RETURN
    END IF

    ! Check if file is open
    IF ( .NOT. File_Open(FileId) ) THEN
      msg = 'LBLRTM file is not open'
      CALL Write_CleanUp(); RETURN
    END IF

    ! Write the panel header
    err_stat = LBLRTM_Phdr_Write( Panel%Header,FileId,Debug=Debug )
    IF ( err_stat /= SUCCESS ) THEN
      msg = 'Error writing panel header'
      CALL Write_Cleanup(); RETURN
    END IF

    ! Write the spectral data
    DO i = 1, Panel%n_Spectra

      ! Progress info
      IF ( noisy ) THEN
        WRITE(msg,'(4x,"Writing spectrum #",i0,"...")') i
        CALL Display_Message(ROUTINE_NAME,msg,INFORMATION)
      END IF

      ! Write spectrum and process result
      WRITE( FileId,IOSTAT=io_stat,IOMSG=io_msg ) Panel%Spectrum(:,i)
      IF ( io_stat /= 0 ) THEN
        msg = 'Error writing LBLRTM panel data - '//TRIM(io_msg)
        CALL Write_CleanUp(); RETURN
      END IF
    END DO

  CONTAINS

    SUBROUTINE Write_CleanUp()
      IF ( File_Open(FileId) ) THEN
        CLOSE( FileId,IOSTAT=io_stat,IOMSG=io_msg )
        IF ( io_stat /= 0 ) &
          msg = TRIM(msg)//'; Error closing output file during error cleanup - '//TRIM(io_msg)
      END IF
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME,msg,err_stat )
    END SUBROUTINE Write_CleanUp

  END FUNCTION LBLRTM_Panel_Write

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       LBLRTM_Panel_IOVersion
!
! PURPOSE:
!       Subroutine to return the version information for the module.
!
! CALLING SEQUENCE:
!       CALL LBLRTM_Panel_IOVersion( Id )
!
! OUTPUTS:
!       Id:     Character string containing the version Id information for the
!               module.
!               UNITS:      N/A
!               TYPE:       CHARACTER(*)
!               DIMENSION:  Scalar
!               ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE LBLRTM_Panel_IOVersion( Id )
    CHARACTER(*), INTENT(OUT) :: Id
    Id = MODULE_VERSION_ID
  END SUBROUTINE LBLRTM_Panel_IOVersion

END MODULE LBLRTM_Panel_IO

max_stars_repo_name: hsbadr/crtm

max_issues_repo_name: hsbadr/crtm

max_forks_repo_name: hsbadr/crtm


! { dg-do run }
! { dg-additional-sources declare-target-2.f90 }

module declare_target_1_mod
  integer :: var_x
  !$omp declare target(var_x)
end module declare_target_1_mod

  interface
    subroutine foo ()
    end subroutine foo
  end interface

  call foo ()
end


text:
MODULE instancesets
  USE bitvectors
  USE options
  USE utilities
  USE parallel
  IMPLICIT NONE

  INTEGER, PARAMETER :: ignorevar = 0, contvar = 1, catvar = 2 ! and more
  INTEGER, PARAMETER :: parse_ok = 0, parse_comment = 1, &
    & parse_error = 2, parse_end = 3
  INTEGER, PARAMETER :: missing_cat = 0
  REAL :: missing_cont
  DATA missing_cont/B'11111111111111111111111111111111'/

  TYPE attribute
    CHARACTER(LEN=tokenlen) :: name
    INTEGER :: cat_count ! number of categories, or contvar or ignorevar
    INTEGER :: cat_start ! start index in categories, for catvars
    INTEGER :: mapping   ! index in the appropriate *vars array
    INTEGER :: usedcont  ! order in usedconts
  END TYPE attribute

  TYPE category
    CHARACTER(LEN=tokenlen) :: name
    INTEGER :: attribute
    REAL :: weight
  END TYPE

  TYPE instanceset
    INTEGER :: set_type
    CHARACTER(LEN=tokenlen) :: relation_name
    REAL, POINTER :: contvars(:,:)
    INTEGER, POINTER :: catvars(:,:)
    CHARACTER(LEN=tokenlen), POINTER :: ignorevars(:,:)
    TYPE (bitvector), POINTER :: missing_data
    INTEGER, POINTER :: missing_count(:)
    INTEGER, POINTER :: contvar_perms(:,:)
    INTEGER, POINTER :: contvar_ranks(:,:)
    REAL, POINTER :: contvar_5_percent(:)
    REAL, POINTER :: contvar_95_percent(:)
    INTEGER, POINTER :: class_populations(:)
    INTEGER, POINTER :: tagged_instances(:)
    REAL, POINTER :: prox(:, :)
    INTEGER, POINTER :: prox_index(:, :)
    REAL, POINTER :: outlying(:)
    INTEGER, POINTER :: leaf_id(:, :)
    REAL, POINTER :: scaling(:, :)
    TYPE (bitvector), POINTER :: constant_attr
    TYPE (datadescription), POINTER :: dd
    LOGICAL :: tagged
    INTEGER, POINTER :: estimated_class(:)
    REAL, POINTER :: votes(:, :)
    INTEGER, POINTER :: classes(:) ! not allocated, not deallocated
    INTEGER, POINTER :: par_stripes(:), par_offsets(:) ! instance distribution
    INTEGER :: lower, upper
  END TYPE instanceset

  TYPE datadescription
    TYPE (attribute), POINTER :: attributes(:)
    TYPE (category), POINTER :: categories(:)
    REAL, POINTER :: contfills(:)
    INTEGER, POINTER :: catfills(:)
    INTEGER, POINTER :: usedvars(:), usedconts(:)
    INTEGER :: contvar_count, catvar_count
  END TYPE datadescription

  TYPE (instanceset), POINTER :: trainset, testset, protoset
  TYPE (attribute), POINTER :: label
  INTEGER :: labelattr
CONTAINS
  FUNCTION new_datadescription() RESULT (ddptr)
    TYPE (datadescription), POINTER :: ddptr
    ALLOCATE (ddptr)
    NULLIFY (ddptr%attributes, ddptr%categories, &
      & ddptr%contfills, ddptr%catfills, ddptr%usedvars, ddptr%usedconts)
  END FUNCTION new_datadescription

  FUNCTION new_instanceset(set_type) RESULT (isptr)
    INTEGER :: set_type
    TYPE (instanceset), POINTER :: isptr

    ALLOCATE (isptr)
    NULLIFY (isptr%contvars, isptr%catvars, isptr%ignorevars, &
      & isptr%missing_data, isptr%contvar_perms, isptr%contvar_ranks, &
      & isptr%contvar_5_percent, isptr%contvar_95_percent, &
      & isptr%class_populations, isptr%tagged_instances, isptr%dd, &
      & isptr%constant_attr, isptr%missing_count, isptr%estimated_class, &
      & isptr%votes, isptr%prox, isptr%prox_index, isptr%outlying, &
      & isptr%leaf_id, isptr%scaling, isptr%par_stripes, isptr%par_offsets)
    isptr%set_type = set_type
  END FUNCTION new_instanceset

  SUBROUTINE free_datadescription(ddptr)
    TYPE (datadescription), POINTER :: ddptr
    IF (ASSOCIATED(ddptr)) THEN
      IF (ASSOCIATED(ddptr%categories)) DEALLOCATE (ddptr%categories)
      IF (ASSOCIATED(ddptr%attributes)) DEALLOCATE (ddptr%attributes)
      IF (ASSOCIATED(ddptr%contfills)) DEALLOCATE (ddptr%contfills)
      IF (ASSOCIATED(ddptr%catfills)) DEALLOCATE (ddptr%catfills)
      IF (ASSOCIATED(ddptr%usedvars)) DEALLOCATE (ddptr%usedvars)
      IF (ASSOCIATED(ddptr%usedconts)) DEALLOCATE (ddptr%usedconts)
      DEALLOCATE (ddptr)
    END IF
  END SUBROUTINE free_datadescription

  SUBROUTINE free_instanceset(isptr)
    TYPE (instanceset), POINTER :: isptr
    IF (ASSOCIATED(isptr)) THEN
      IF (ASSOCIATED(isptr%ignorevars)) DEALLOCATE (isptr%ignorevars)
      IF (ASSOCIATED(isptr%catvars)) DEALLOCATE (isptr%catvars)
      IF (ASSOCIATED(isptr%contvars)) DEALLOCATE (isptr%contvars)
      IF (ASSOCIATED(isptr%contvar_perms)) DEALLOCATE (isptr%contvar_perms)
      IF (ASSOCIATED(isptr%contvar_ranks)) DEALLOCATE (isptr%contvar_ranks)
      IF (ASSOCIATED(isptr%missing_count)) DEALLOCATE (isptr%missing_count)
      IF (ASSOCIATED(isptr%estimated_class)) DEALLOCATE (isptr%estimated_class)
      IF (ASSOCIATED(isptr%votes)) DEALLOCATE (isptr%votes)
      IF (ASSOCIATED(isptr%prox)) DEALLOCATE (isptr%prox)
      IF (ASSOCIATED(isptr%prox_index)) DEALLOCATE (isptr%prox_index)
      IF (ASSOCIATED(isptr%outlying)) DEALLOCATE (isptr%outlying)
      IF (ASSOCIATED(isptr%leaf_id)) DEALLOCATE (isptr%leaf_id)
      IF (ASSOCIATED(isptr%scaling)) DEALLOCATE (isptr%scaling)
      IF (ASSOCIATED(isptr%par_stripes)) DEALLOCATE (isptr%par_stripes)
      IF (ASSOCIATED(isptr%par_offsets)) DEALLOCATE (isptr%par_offsets)
      IF (ASSOCIATED(isptr%tagged_instances)) &
        & DEALLOCATE (isptr%tagged_instances)
      IF (ASSOCIATED(isptr%contvar_5_percent)) &
        & DEALLOCATE (isptr%contvar_5_percent)
      IF (ASSOCIATED(isptr%contvar_95_percent)) &
        & DEALLOCATE (isptr%contvar_95_percent)
      IF (ASSOCIATED(isptr%class_populations)) &
        & DEALLOCATE (isptr%class_populations)
      IF (ASSOCIATED(isptr%missing_data)) &
        & CALL free_bitvector(isptr%missing_data)
      IF (ASSOCIATED(isptr%constant_attr)) &
        & CALL free_bitvector(isptr%constant_attr)
      DEALLOCATE (isptr)
    END IF
  END SUBROUTINE free_instanceset

  FUNCTION skip_comma_and_spaces(string, pos) RESULT (ok)
    CHARACTER(*) :: string
    INTEGER :: pos, length
    LOGICAL :: ok
    LOGICAL :: comma_ok
    comma_ok = .TRUE.
    ok = .TRUE.
    length = LEN_TRIM(string)
    IF (pos.GT.length) THEN
      ok = .TRUE.
      string = ""
    ELSE
      DO
        ! Only one comma
        IF (string(pos:pos).EQ.",".AND.comma_ok) THEN
          comma_ok = .FALSE.
        ! End on a non-space
        ELSE IF (string(pos:pos).NE." ") THEN
          EXIT
        ELSE IF (pos.EQ.length) THEN
          ok = .FALSE.
          EXIT
        END IF
        pos = pos + 1
      END DO
      string = ADJUSTL(string(pos:))
    END IF
  END FUNCTION skip_comma_and_spaces

  FUNCTION parse_token(line, pos)
    CHARACTER(LEN=linelen) :: line
    INTEGER, INTENT(OUT) :: pos
    CHARACTER(LEN=tokenlen) :: parse_token
    CHARACTER :: delimiter

    ! Quoted?
    IF (line(1:1).EQ."'".OR.line(1:1).EQ.'"') THEN
      delimiter = line(1:1)
      line = line(2:)
      pos = SCAN(line, delimiter)
      parse_token = line(1:pos-1)
      pos = pos + 1

    ! Simple token.
    ELSE
      pos = SCAN(line, " ,")
      IF (pos.EQ.0) THEN
        parse_token = line
      ELSE
        parse_token = line(1:pos-1)
      END IF
    END IF
  END FUNCTION parse_token

  FUNCTION parse_line(handle, isptr, instance_no, line, pass, line_no, &
    & skip_attr, count_missing) RESULT (error)
    TYPE (instanceset), POINTER :: isptr
    INTEGER, INTENT(OUT) :: instance_no
    CHARACTER(LEN=*) :: line
    INTEGER :: handle, pass, line_no, skip_attr
    LOGICAL :: count_missing
    INTEGER :: error
    INTEGER :: i, j, pos, attribute_count
    LOGICAL :: eof, err
    CHARACTER(LEN=linelen) :: tmpline
    CHARACTER(LEN=tokenlen) :: cat_name

    tmpline = line
    tmpline = ADJUSTL(tmpline)

    ! Comment or a blank line? Ignore it.
    IF (tmpline(1:1).EQ."%".OR.LEN_TRIM(tmpline).EQ.0) THEN
      error = parse_comment
      RETURN
    END IF

    ! Real data?
    instance_no = instance_no + 1
    IF (pass.EQ.2) THEN
      error = parse_error ! We failed unless we reach the end successfully
      attribute_count = UBOUND(isptr%dd%attributes, 1)
      IF (opts%class_attribute_num.EQ.class_new) THEN
        isptr%catvars(instance_no, UBOUND(isptr%catvars, 2)) = 1
        attribute_count = attribute_count - 1
      END IF
      attribute_loop: DO i = 1, attribute_count
        IF (i.NE.skip_attr) THEN
          DO WHILE (tmpline(1:1).EQ.'&')
            CALL read_line(handle, tmpline, line, line_no, eof, err)
            IF (eof.OR.err) GO TO 7999
          END DO
          cat_name = parse_token(tmpline, pos)
          IF (pos.EQ.0) RETURN
          IF (.NOT.skip_comma_and_spaces(tmpline, pos)) GO TO 7999
        END IF

        ! Missing value?
        IF (i.EQ.skip_attr.OR.cat_name.EQ."?") THEN
          IF (count_missing) THEN
            isptr%missing_count(i) = isptr%missing_count(i) + 1
          END IF
          CALL setbit2(isptr%missing_data, instance_no, i, .TRUE.)

          SELECT CASE (isptr%dd%attributes(i)%cat_count)
            CASE (ignorevar)
              isptr%ignorevars(instance_no, isptr%dd%attributes(i)%mapping) &
                & = cat_name
            CASE (contvar)
              isptr%contvars(instance_no, isptr%dd%attributes(i)%mapping) &
                & = missing_cont
            CASE DEFAULT
              isptr%catvars(instance_no, isptr%dd%attributes(i)%mapping) &
                & = missing_cat
          END SELECT
        ! Real value.
        ELSE
          SELECT CASE (isptr%dd%attributes(i)%cat_count)
            CASE (ignorevar)
              isptr%ignorevars(instance_no, isptr%dd%attributes(i)%mapping) &
                & = cat_name
            CASE (contvar)
              READ (cat_name, *, ERR=7999) &
                & isptr%contvars(instance_no, isptr%dd%attributes(i)%mapping)
            CASE DEFAULT
              ! Recognise the category name
              DO j = isptr%dd%attributes(i)%cat_start, &
                & isptr%dd%attributes(i)%cat_start + &
                & isptr%dd%attributes(i)%cat_count - 1
                IF (isptr%dd%categories(j)%name.EQ.cat_name) THEN
                  isptr%catvars(instance_no, isptr%dd%attributes(i)%mapping) = &
                    & j - isptr%dd%attributes(i)%cat_start + 1
                  CYCLE attribute_loop
                END IF
              END DO
              WRITE(0, af) "Invalid category " // TRIM(cat_name) &
                & // " for attribute " // TRIM(isptr%dd%attributes(i)%name)
              RETURN
          END SELECT
        END IF
      END DO attribute_loop

      ! Success only if we reached the end of the line without incidents
      IF (LEN_TRIM(tmpline(pos:)).LE.0) error = parse_ok
    ELSE
      error = parse_ok
      DO
        pos = LEN_TRIM(tmpline)
        IF (tmpline(pos:pos).EQ."&") THEN
          CALL read_line(handle, tmpline, line, line_no, eof, err)
        ELSE
          EXIT
        END IF
      END DO
    END IF
    7999 CONTINUE
  END FUNCTION parse_line

  SUBROUTINE read_line(handle, line, origline, line_no, eof, err)
    CHARACTER(LEN=*) :: line, origline
    INTEGER :: handle, line_no
    LOGICAL :: eof, err
    INTEGER :: pos

    eof = .FALSE.
    err = .FALSE.
    DO
      IF (par_front) THEN
        line_no = line_no + 1
        READ(handle, "(A)", END=8010, ERR=8030) line
        origline = line
        DO
          pos = SCAN(line, CHAR(9))
          IF (pos.EQ.0) EXIT
          line(pos:pos) = " "
        END DO
        line = ADJUSTL(line)
      END IF

      GOTO 8020
8010  eof = .TRUE.
      line="%"

! Now distribute the clear text to all processes. The broadcast is in
! human readable form, and the comment sign (%) at line(1:1) is eof
! indication

8020  CONTINUE
      ! Comment? Skip it.
      IF (eof.OR.(line(1:1).NE."%".AND.LEN_TRIM(line).NE.0)) THEN
        CALL par_bcast_char(line)
        IF ((.NOT.par_front).AND.(line(1:1).EQ."%")) eof = .TRUE.
        RETURN
      END IF
    END DO
    RETURN

8030 err = .TRUE.
  END SUBROUTINE read_line

  FUNCTION parse_arff(isptr, filename)
    TYPE (instanceset), POINTER :: isptr
    CHARACTER(*) :: filename
    LOGICAL :: parse_arff
    CHARACTER(LEN=linelen) :: origline, line
    INTEGER :: line_no, attribute_count, cat_count, instance_count, cat_start
    INTEGER :: contvar_count, catvar_count, ignorevar_count
    INTEGER :: pos, pos2, pass, i, attr, attr2
    INTEGER :: handle
    CHARACTER(LEN=tokenlen) :: cat_name
    CHARACTER :: delimiter
    LOGICAL :: statement_attribute, statement_ignored
    LOGICAL :: eof, err
    INTEGER :: parse_line_result, constant_attrs
    LOGICAL :: loaddd ! load data description
    INTEGER :: skip_attr
    LOGICAL, ALLOCATABLE :: usedvars(:)

    parse_arff = .FALSE.
    loaddd = .NOT.ASSOCIATED(isptr%dd)
    IF (loaddd) isptr%dd => new_datadescription()

    IF (par_front) THEN
      handle = open_file(filename, .FALSE., err)
      IF (err) GO TO 9000
    END IF

    ! Two passes. In the first pass, get the structure.
    ! Then allocate arrays, and fill them in the second pass.
    pass_loop: DO pass = 1, 2
      line(1:1) = "!"  ! prevent an exceptional situation in parse_line
      IF (pass.EQ.2) THEN
        ! Start of pass 2.
        if (par_front) REWIND(handle)
        IF (loaddd) THEN
          IF (opts%class_attribute_num.EQ.class_new) THEN
            instance_count = instance_count * (1 + opts%new_class_quantity)
            attribute_count = attribute_count + 1
            catvar_count = catvar_count + 1
            cat_count = cat_count + 2
            isptr%tagged = .TRUE.
          END IF
          isptr%dd%contvar_count = contvar_count
          isptr%dd%catvar_count = catvar_count
          ALLOCATE (isptr%dd%attributes(attribute_count),&
            & isptr%dd%categories(cat_count),&
            & usedvars(attribute_count), isptr%missing_count(attribute_count))
          isptr%constant_attr => new_bitvector(attribute_count)
          usedvars = opts%used_default
          isptr%missing_count = 0
          skip_attr = attribute_count + 1 ! i.e. don't skip.
          IF (opts%split_node_size.LT.0) THEN
            opts%split_node_size = -opts%split_node_size * instance_count / 100
          END IF
          IF (opts%split_node_size.GT.instance_count) THEN
            opts%split_node_size = instance_count
          END IF
        ELSE
          ! TODO check compatibility
          i = attribute_count
          attribute_count = UBOUND(isptr%dd%attributes, 1)
          IF (i + 1.EQ.attribute_count) THEN
            skip_attr = opts%class_attribute_num ! skip the class attribute
            catvar_count = catvar_count + 1
            isptr%tagged = .FALSE.
          ELSE IF (i.EQ.attribute_count) THEN
            skip_attr = attribute_count + 1 ! i.e. don't skip.
            isptr%tagged = .TRUE.
          ELSE
            GO TO 9070 ! incompatible attribute schema sizes
          END IF
        END IF
        isptr%missing_data => new_bitvector2(instance_count, &
          & attribute_count)
        ALLOCATE (isptr%contvars(instance_count, contvar_count),&
          & isptr%catvars(instance_count, catvar_count),&
          & isptr%ignorevars(instance_count, ignorevar_count))
        IF (loaddd.AND.opts%class_attribute_num.EQ.class_new) THEN
          isptr%dd%attributes(attribute_count)%name = "class"
          isptr%dd%attributes(attribute_count)%cat_count = 2
          isptr%dd%attributes(attribute_count)%cat_start = cat_count - 1
          isptr%dd%attributes(attribute_count)%mapping = catvar_count
          isptr%dd%categories(cat_count - 1)%attribute = attribute_count
          isptr%dd%categories(cat_count)%attribute = attribute_count
          isptr%dd%categories(cat_count - 1)%name = "original"
          isptr%dd%categories(cat_count)%name = "constructed"
          isptr%dd%categories(cat_count - 1)%weight = 1
          isptr%dd%categories(cat_count)%weight = 1
        END IF
      END IF

      line_no = 0
      attribute_count = 0
      cat_count = 0
      instance_count = 0
      contvar_count = 0
      catvar_count = 0
      ignorevar_count = 0
      DO
        CALL read_line(handle, line, origline, line_no, eof, err)
        IF (eof) GO TO 9010
        IF (err) GO TO 9030
        statement_attribute = lcase(line(1:10)).EQ."@attribute"
        statement_ignored = lcase(line(1:8)).EQ."@ignored"

        ! Data block? Read data 'till EOF.
        IF (lcase(line(1:5)).EQ."@data") THEN
          DO
            CALL read_line(handle, line, origline, line_no, eof, err)

            IF (eof) GO TO 1000
            IF (err) GO TO 9030
            parse_line_result = parse_line(handle, isptr, instance_count, &
              & line, pass, line_no, skip_attr, pass.NE.1.AND.loaddd)
            SELECT CASE (parse_line_result)
              CASE (parse_ok)
              CASE (parse_comment)
              CASE (parse_error)
                GO TO 9020
            END SELECT
          END DO
          1000 CYCLE pass_loop

        ! Attribute specification?
        ELSE IF (statement_attribute.OR.statement_ignored) THEN
          attribute_count = attribute_count + 1
          line = ADJUSTL(line(SCAN(line, ' ')+1:))

          ! Get name
          cat_name = parse_token(line, pos)
          IF (pass.EQ.2) THEN
            IF (loaddd) THEN
              isptr%dd%attributes(attribute_count)%name = cat_name
              isptr%dd%attributes(attribute_count)%cat_count = 0
            ELSE
              ! TODO check compatibility
            END IF
          ELSE IF (loaddd.AND. &
            & lcase(TRIM(cat_name)).EQ.TRIM(opts%class_attribute)) THEN
            opts%class_attribute_num = attribute_count
          END IF
          line = ADJUSTL(line(pos+1:))

          ! Catvar?
          IF (line(1:1).EQ."{") THEN
            cat_start = cat_count + 1
            IF (pass.EQ.2) THEN
              IF (loaddd) THEN
                isptr%dd%attributes(attribute_count)%cat_start = cat_start
              ELSE
                ! TODO check compatibility
              END IF
            END IF
            pos = 2
            IF (.NOT.skip_comma_and_spaces(line, pos)) GO TO 9020
            DO WHILE (line(1:1).NE."}")
              DO WHILE (line(1:1).EQ."&")
                CALL read_line(handle, line, origline, line_no, eof, err)
                IF (eof) GO TO 9010
                IF (err) GO TO 9030
              END DO
              IF (line(1:1).EQ."'".OR.line(1:1).EQ.'"') THEN
                delimiter = line(1:1)
                line = line(2:)
                pos = SCAN(line, delimiter)
                cat_name = line(1:pos-1)
                pos = pos + 1
              ELSE
                pos = SCAN(line, " ,}(")
                cat_name = line(1:pos-1)
              END IF
              cat_count = cat_count + 1
              IF (pos.EQ.0) GO TO 9020
              IF (pass.EQ.2) THEN
                IF (loaddd) THEN
                  isptr%dd%categories(cat_count)%name = cat_name
                  isptr%dd%categories(cat_count)%attribute = attribute_count
                  isptr%dd%attributes(attribute_count)%cat_count = &
                    & isptr%dd%attributes(attribute_count)%cat_count + 1
                ELSE
                  ! TODO check compatibility
                END IF
              END IF
              IF (.NOT.skip_comma_and_spaces(line, pos)) GO TO 9020
              IF (line(1:1).EQ.'(') THEN ! category weight
                pos = SCAN(line, ')')
                IF (pos.EQ.0) GO TO 9020
                cat_name = line(2:pos-1)
                pos = pos + 1
                IF (.NOT.skip_comma_and_spaces(line, pos)) GO TO 9020
                IF (pass.EQ.2) THEN
                  IF (loaddd) THEN
                    READ(cat_name, *), isptr%dd%categories(cat_count)%weight
                  ELSE
                    ! TODO check compatibility
                  END IF
                END IF
              ELSE IF (pass.EQ.2) THEN
                IF (loaddd) THEN
                  isptr%dd%categories(cat_count)%weight = 1
                ELSE
                  ! TODO check compatibility
                END IF
              END IF
            END DO

            IF (cat_start.EQ.cat_count) THEN
              ! only 1 category - ignore this attribute
              cat_count = cat_count - 1
              ignorevar_count = ignorevar_count + 1
              IF (pass.EQ.2) THEN
                IF (loaddd) THEN
                  isptr%dd%attributes(attribute_count)%cat_count = ignorevar
                  isptr%dd%attributes(attribute_count)%mapping = ignorevar_count
                ELSE
                  ! TODO check compatibility
                END IF
              END IF
            ELSE
              catvar_count = catvar_count + 1
              IF (pass.EQ.2) THEN
                IF (loaddd) THEN
                  isptr%dd%attributes(attribute_count)%mapping = catvar_count
                ELSE
                  ! TODO check compatibility
                END IF
              END IF
            END IF

          ! Contvar?
          ELSE IF (lcase(line(1:7)).EQ."numeric" &
            & .OR.lcase(line(1:7)).EQ."integer" & ! We'll treat ints as conts
            & .OR.lcase(line(1:4)).EQ."real") THEN
            contvar_count = contvar_count + 1
            IF (pass.EQ.2) THEN
              IF (loaddd) THEN
                isptr%dd%attributes(attribute_count)%mapping = contvar_count
                isptr%dd%attributes(attribute_count)%cat_count = contvar
              ELSE
                ! TODO check compatibility
              END IF
            END IF

          ! Something else (presumably a string)
          ELSE
            ignorevar_count = ignorevar_count + 1
            IF (pass.EQ.2) THEN
              IF (loaddd) THEN
                isptr%dd%attributes(attribute_count)%mapping = ignorevar_count
                isptr%dd%attributes(attribute_count)%cat_count = ignorevar
              ELSE
                ! TODO check compatibility
              END IF
            END IF
          END IF

          ! Ignore the @ignored
          IF (pass.EQ.2) THEN
            IF (loaddd) THEN
              usedvars(attribute_count) = usedvars(attribute_count).AND.&
                & statement_attribute
            ELSE
              ! TODO check compatibility
            END IF
          END IF
        ELSE IF (pass.EQ.1) THEN
          CYCLE
        ELSE IF (lcase(line(1:9)).EQ."@relation") THEN
          pos = 1
          line = ADJUSTL(line(11:))
          isptr%relation_name = parse_token(line, pos)
        ELSE
          GO TO 9020
        END IF
      END DO
    END DO pass_loop

    IF (loaddd) THEN
      ! See which attribute is the classification attribute
      IF (opts%class_attribute_num.EQ.class_named) THEN
        opts%class_attribute_num = get_attribute_by_name(isptr, &
          & opts%class_attribute)
        IF (opts%class_attribute_num.EQ.0) GO TO 9040
      ELSE IF (opts%class_attribute_num.LT.class_named) THEN
        CALL generate_class(isptr, instance_count)
        opts%class_attribute_num = UBOUND(isptr%dd%attributes, 1)
      END IF
      cat_start = isptr%dd%attributes(opts%class_attribute_num)%cat_start
      cat_count = isptr%dd%attributes(opts%class_attribute_num)%cat_count
      IF (cat_count.LT.2) GO TO 9040

      ! Is there weight override?
      IF (LEN_TRIM(opts%class_weights).NE.0) THEN
        READ (opts%class_weights, *) &
          & isptr%dd%categories(cat_start:cat_start+cat_count-1)%weight
      END IF

      ! What is the positive category?
      IF (LEN_TRIM(opts%positive_category).NE.0) THEN
        opts%positive_category_num = &
          & get_category_by_name(isptr, opts%positive_category)
      END IF

      ! See which attribute is the label
      IF (LEN_TRIM(opts%label).NE.0) THEN
        labelattr = get_attribute_by_name(isptr, opts%label)
        IF (labelattr.EQ.0) GO TO 9080
        label => isptr%dd%attributes(labelattr)
      ELSE
        labelattr = 0
      END IF

      ! See which attributes are not used
      IF (LEN_TRIM(opts%unusedvars).NE.0) THEN
        line = TRIM(opts%unusedvars) // ','
        DO WHILE (LEN_TRIM(line).NE.0)
          pos = SCAN(line, ',')
          IF (pos.EQ.0) pos = LEN_TRIM(line) + 1
          cat_name = line(1:pos-1)
          attr = get_attribute_by_name(isptr, cat_name)
          IF (attr.EQ.0) THEN
            pos2 = SCAN(line, '-')
            cat_name = line(1:pos2-1)
            attr = get_attribute_by_name(isptr, cat_name)
            IF (attr.EQ.0) GO TO 9050
            cat_name = line(pos2+1:pos-1)
            attr2 = get_attribute_by_name(isptr, cat_name)
            IF (attr2.EQ.0) GO TO 9050
            usedvars(attr:attr2) = .FALSE.
          ELSE
            usedvars(attr) = .FALSE.
          END IF
          line = line(pos+1:)
        END DO
      END IF
      ! and which are:
      IF (LEN_TRIM(opts%usedvars).NE.0) THEN
        line = TRIM(opts%usedvars) // ','
        DO WHILE (LEN_TRIM(line).NE.0)
          pos = SCAN(line, ',')
          IF (pos.EQ.0) pos = LEN_TRIM(line) + 1
          cat_name = line(1:pos-1)
          attr = get_attribute_by_name(isptr, cat_name)
          IF (attr.EQ.0) THEN
            pos2 = SCAN(line, '-')
            cat_name = line(1:pos2-1)
            attr = get_attribute_by_name(isptr, cat_name)
            IF (attr.EQ.0) GO TO 9050
            cat_name = line(pos2+1:pos-1)
            attr2 = get_attribute_by_name(isptr, cat_name)
            IF (attr2.EQ.0) GO TO 9050
            usedvars(attr:attr2) = .TRUE.
          ELSE
            usedvars(attr) = .TRUE.
          END IF
          line = line(pos+1:)
        END DO
      END IF
      ! Ignorevars can't be used at all
      usedvars = usedvars.AND.(isptr%dd%attributes(:)%cat_count.NE.ignorevar)
      usedvars(opts%class_attribute_num) = .FALSE.

      ! See which attributes are constant (all present, or all missing)
      constant_attrs = 0
      DO i = 1, attribute_count
        IF (isptr%missing_count(i).EQ.0 &
          & .OR. isptr%missing_count(i).EQ.instance_count) THEN
          CALL setbit(isptr%constant_attr, i, .TRUE.)
          IF (isptr%missing_count(i).EQ.instance_count) usedvars(i) = .FALSE.
          constant_attrs = constant_attrs + 1
        END IF
      END DO
      IF (constant_attrs.EQ.attribute_count) opts%fill_passes = 0

      attr = 0
      pos = 0
      DO i = 1, attribute_count
        ! count used vars
        IF (.NOT.usedvars(i)) CYCLE
        attr = attr + 1
        ! count used contvars
        IF (isptr%dd%attributes(i)%cat_count.EQ.contvar) pos = pos + 1
      END DO
      IF (attr.EQ.0) GO TO 9060
      ALLOCATE (isptr%dd%usedvars(attr), isptr%dd%usedconts(pos))
      attr = 0
      pos = 0
      DO i = 1, attribute_count
        IF (usedvars(i)) THEN
          attr = attr + 1
          isptr%dd%usedvars(attr) = i
          IF (isptr%dd%attributes(i)%cat_count.EQ.contvar) THEN
            pos = pos + 1
            isptr%dd%usedconts(pos) = i
          END IF
        END IF
      END DO
      DEALLOCATE (usedvars)
      CALL index_usedconts(isptr%dd)
    END IF

    ! Success
    parse_arff = .TRUE.
    GO TO 9999

    ! Error situations
    9000 WRITE(*, *) "Error reading ", TRIM(filename), ": cannot open file"
    GO TO 9990

    9010 WRITE(*, *) "Error reading ", TRIM(filename), ": no data"
    GO TO 9990

    9020 WRITE(*, *) "Error reading ", TRIM(filename), &
      & ": syntax error on line", line_no
    WRITE (*, *) TRIM(origline)
    GO TO 9990

    9030 WRITE(*, *) "Error reading ", TRIM(filename), " on line", line_no
    GO TO 9990

    9040 WRITE(*, *) "Error: Invalid argument to -c"
    GO TO 9990

    9050 WRITE(*, *) "Error: Invalid argument to -u: ", TRIM(cat_name)
    GO TO 9990

    9060 WRITE(*, *) "Error: Must use at least one attribute"
    GO TO 9990

    9070 WRITE(*, *) "Error: The attribute schema are incompatible"
    GO TO 9990

    9080 WRITE(*, *) "Error: Invalid argument to -ri: ", TRIM(cat_name)
    GO TO 9990

    9990 CALL free_instanceset(isptr)

    ! Finally, close the file
    9999 IF (par_front) CALL close_file(handle)

  END FUNCTION parse_arff

  SUBROUTINE index_usedconts(datadesc)
    TYPE (datadescription), POINTER :: datadesc
    INTEGER :: i

    DO i = 1, UBOUND(datadesc%usedconts, 1)
      datadesc%attributes(datadesc%usedconts(i))%usedcont = i
    END DO
  END SUBROUTINE index_usedconts

  SUBROUTINE generate_class(isptr, original_count)
    TYPE (instanceset), POINTER :: isptr
    INTEGER :: i, j
    INTEGER :: original_count, instance_count, attribute_count

    instance_count = UBOUND(isptr%catvars, 1)
    attribute_count = UBOUND(isptr%catvars, 2)
    IF (opts%class_attribute_num.EQ.class_new) THEN
      ! Generate the second class
      opts%class_attribute_num = UBOUND(isptr%catvars, 2)
      DO i = original_count + 1, instance_count
        DO j = 1, UBOUND(isptr%catvars, 2)
          IF (j.EQ.attribute_count) THEN ! generated attribute is always last
            isptr%catvars(i, j) = 2 ! "constructed"
          ELSE
            isptr%catvars(i, j) = isptr%catvars(rnd_int(original_count), j)
          END IF
        END DO
        DO j = 1, UBOUND(isptr%contvars, 2)
          isptr%contvars(i, j) = isptr%contvars(rnd_int(original_count), j)
        END DO
        ! FIXME This should probably be cut, because it just slows things down.
        ! Also, perhaps filter out the unused vars?
        DO j = 1, UBOUND(isptr%ignorevars, 2)
          isptr%ignorevars(i, j) = isptr%ignorevars(rnd_int(instance_count), j)
        END DO
      END DO
    ELSE IF (opts%class_attribute_num.EQ.class_last) THEN
      opts%class_attribute_num = attribute_count
    END IF
  END SUBROUTINE generate_class

  PURE FUNCTION escape_token(string)
    CHARACTER(*), INTENT(IN) :: string
    CHARACTER(LEN=LEN(string)+2) :: escape_token

    ! Do we need single quotes?
    IF (INDEX(TRIM(string), '"').NE.0) THEN
      escape_token = "'" // TRIM(string) // "'"

    ! Do we need quotes at all?
    ELSE IF (SCAN(TRIM(string), " '").NE.0) THEN
      escape_token = '"' // TRIM(string) // '"'

    ! A simple token
    ELSE
      escape_token = TRIM(string)
    END IF
  END FUNCTION escape_token

  SUBROUTINE print_datadescription(dd, relname, handle)
    TYPE (datadescription), POINTER :: dd
    CHARACTER(LEN=*) :: relname
    INTEGER :: handle, i, j
    CHARACTER(LEN=1024) line, val

    ! Relation name
    WRITE(handle, af) "@relation " // TRIM(relname)
    WRITE(handle, *)

    ! Attribute descriptors
    DO i = 1, UBOUND(dd%attributes, 1)
      SELECT CASE (dd%attributes(i)%cat_count)
        CASE (ignorevar)
          line = "string"
        CASE (contvar)
          line = "numeric"
        CASE DEFAULT
          line = ""
          DO j = dd%attributes(i)%cat_start, &
            & dd%attributes(i)%cat_start &
            & + dd%attributes(i)%cat_count - 1
            line = TRIM(line) // ", " // &
              & escape_token(dd%categories(j)%name)
            IF (dd%categories(j)%weight.NE.1) THEN
              CALL squeeze_num(val, dd%categories(j)%weight)
              line = TRIM(line) // " (" // TRIM(val) // ")"
            END IF
          END DO
          line = "{ " // TRIM(line(3:)) // " }"
      END SELECT
      WRITE(handle, af) "@attribute " &
        & // TRIM(escape_token(dd%attributes(i)%name)) // " " // TRIM(line)
    END DO
    WRITE(handle, *)
  END SUBROUTINE print_datadescription

  SUBROUTINE print_instances(isptr, handle)
    TYPE (instanceset), POINTER :: isptr
    INTEGER :: handle

    CALL print_datadescription(isptr%dd, isptr%relation_name, handle)
    WRITE(handle, af) "@data"
    CALL print_data(isptr, handle)
  END SUBROUTINE print_instances

  SUBROUTINE print_data(isptr, handle)
    TYPE (instanceset), POINTER :: isptr
    INTEGER :: handle
    INTEGER :: i, j
    CHARACTER(LEN=1024) line, val
    INTEGER :: cat_tmp

    DO i = 1, UBOUND(isptr%catvars, 1)
      line = ""
      DO j = 1, UBOUND(isptr%dd%attributes, 1)
        IF (getbit2(isptr%missing_data, i, j)) THEN
          line = TRIM(line) // ", ?"
          CYCLE
        END IF
        SELECT CASE (isptr%dd%attributes(j)%cat_count)
          CASE (ignorevar)
            val = escape_token(isptr%ignorevars(i, &
              & isptr%dd%attributes(j)%mapping))
          CASE (contvar)
            CALL squeeze_num(val, &
              & isptr%contvars(i, isptr%dd%attributes(j)%mapping))
          CASE DEFAULT
            IF (j.EQ.opts%class_attribute_num) THEN
              cat_tmp = isptr%classes(i)
            ELSE
              cat_tmp = isptr%catvars(i, isptr%dd%attributes(j)%mapping)
            END IF
            val = escape_token(isptr%dd%categories( &
              & isptr%dd%attributes(j)%cat_start+cat_tmp-1)%name)
        END SELECT
        line = TRIM(line) // ", " // TRIM(val)
      END DO
      WRITE(handle, af) TRIM(line(3:))
    END DO
  END SUBROUTINE print_data

  SUBROUTINE print_arff(filename, isptr, isptr2)
    TYPE (instanceset), POINTER :: isptr
    TYPE (instanceset), POINTER, OPTIONAL :: isptr2
    CHARACTER(LEN=*) :: filename
    INTEGER :: handle
    LOGICAL :: err

    handle = open_file(filename, .TRUE., err)
    IF (err) RETURN

    CALL print_instances(isptr, handle)
    IF (PRESENT(isptr2)) THEN
      WRITE(handle, af) "%-------"
      CALL print_data(isptr2, handle)
    END IF

    CALL close_file(handle)
  END SUBROUTINE print_arff

  SUBROUTINE calculate_rough_fills(isptr)
    TYPE (instanceset), POINTER :: isptr
    INTEGER :: i, a, attr

    ! Allocate arrays
    ALLOCATE (isptr%dd%contfills(UBOUND(isptr%contvars, 2)), &
      & isptr%dd%catfills(UBOUND(isptr%catvars, 2)))

    ! Calculate rough fills
    DO i = 1, UBOUND(isptr%dd%usedvars, 1)
      a = isptr%dd%usedvars(i)
      IF (getbit(isptr%constant_attr, a)) CYCLE
      attr = isptr%dd%attributes(a)%mapping
      SELECT CASE (isptr%dd%attributes(a)%cat_count)
        CASE (ignorevar)
        CASE (contvar)
          ! For contvars, median value
          isptr%dd%contfills(attr) = median(isptr%contvars(:,attr))
        CASE DEFAULT
          ! For catvars, the most frequent category
          isptr%dd%catfills(attr) = &
            & most_frequent(isptr%catvars(:,attr), &
            & isptr%dd%attributes(a)%cat_count)
      END SELECT
    END DO
  END SUBROUTINE calculate_rough_fills

  SUBROUTINE fill_missing_rough(isptr)
    TYPE (instanceset), POINTER :: isptr
    INTEGER :: i, j, a, attr, num_instances
    LOGICAL :: ismissing ! C function

    num_instances = UBOUND(isptr%catvars, 1)
    DO i = 1, UBOUND(isptr%dd%usedvars, 1)
      a = isptr%dd%usedvars(i)
      IF (getbit(isptr%constant_attr, a)) CYCLE
      attr = isptr%dd%attributes(a)%mapping
      SELECT CASE (isptr%dd%attributes(a)%cat_count)
        CASE (ignorevar)
        CASE (contvar)
          DO j = 1, num_instances
            IF (ismissing(isptr%contvars(j, attr))) THEN
              isptr%contvars(j, attr) = isptr%dd%contfills(attr)
            END IF
          END DO
        CASE DEFAULT
          DO j = 1, num_instances
            IF ((isptr%catvars(j, attr).EQ.missing_cat)) THEN
              isptr%catvars(j, attr) = isptr%dd%catfills(attr)
            END IF
          END DO
      END SELECT
    END DO
  END SUBROUTINE fill_missing_rough

  SUBROUTINE fill_missing_by_prox(isptr)
    TYPE (instanceset), POINTER :: isptr
    INTEGER :: i, j, k, l, a, cat, attr, num_instances, cat_count
    REAL :: weighted_sum, total_prox
    INTEGER, POINTER :: votes(:)
    ! FIXME

PRINT*,"GTDEBUG ",UBOUND(isptr%prox_index), num_instances, opts%num_prox
    num_instances = UBOUND(isptr%catvars, 1)
    DO i = 1, UBOUND(isptr%dd%usedvars, 1)
      a = isptr%dd%usedvars(i)
      IF (getbit(isptr%constant_attr, a)) CYCLE
      attr = isptr%dd%attributes(a)%mapping
      cat_count = isptr%dd%attributes(i)%cat_count
      SELECT CASE (cat_count)
        CASE (ignorevar)
        CASE (contvar)
          ! Continuous variable:
          ! Make a proximity-weighted average of non-missing values
          DO j = isptr%lower, isptr%upper
            IF (getbit2(isptr%missing_data, j, attr)) THEN
              weighted_sum = 0
              total_prox = 0
              DO k = 1, opts%num_prox
                l = isptr%prox_index(j, k)
                IF (.NOT.getbit2(isptr%missing_data, l, attr)) THEN
PRINT*, j, k, isptr%prox(j, k)
                  weighted_sum = weighted_sum + isptr%prox(j, k) &
                    & * isptr%contvars(l, attr)
                  total_prox = total_prox + isptr%prox(j, k)
                END IF
              END DO
              IF (total_prox.GT.0) THEN
                isptr%contvars(j, attr) = weighted_sum / total_prox
              END IF
            END IF
          END DO
        CASE DEFAULT
          ! Categorical variable:
          ! Sum proximities by category; pick highest proximity total
          ALLOCATE (votes(cat_count))
          DO j = isptr%lower, isptr%upper
            votes = 0
            IF (getbit2(isptr%missing_data, j, attr)) THEN
              DO k = 1, opts%num_prox
                l = isptr%prox_index(j, k)
                IF (.NOT.getbit2(isptr%missing_data, l, attr)) THEN
                  cat = isptr%catvars(l, attr)
                  votes(cat) = votes(cat) + isptr%prox(j, k)
                END IF
              END DO
              l = 1
              DO k = 2, cat_count
                IF (votes(k).GE.votes(l)) l = k
              END DO
              isptr%catvars(j, attr) = l
            END IF
          END DO
          DEALLOCATE (votes)
      END SELECT
    END DO
  END SUBROUTINE fill_missing_by_prox

  ! Called after filling missing values, so no ?'s here
  SUBROUTINE sort_and_rank(isptr, skip_constants)
    TYPE (instanceset), POINTER :: isptr
    LOGICAL :: skip_constants
    INTEGER :: i, j, attr, instance_count, contvar_count
    INTEGER :: percent5, percent95
    INTEGER :: last_idx, idx, temp_idx

    instance_count = UBOUND(isptr%catvars, 1)
    contvar_count = UBOUND(isptr%contvars, 2)
    percent5 = NINT((instance_count - 1)*0.05)+1
    percent95 = NINT((instance_count - 1)*0.95)+1

    ! Allocate arrays, but only the first time
    IF (.NOT.ASSOCIATED(isptr%contvar_ranks)) THEN
      ALLOCATE (isptr%contvar_perms(instance_count, contvar_count), &
        & isptr%contvar_ranks(instance_count, contvar_count))
    END IF
    IF (opts%num_prot .GT. 0) THEN ! Only needed for the prototypes
      IF (ASSOCIATED(isptr%contvar_5_percent)) &
        & DEALLOCATE (isptr%contvar_5_percent)
      IF (ASSOCIATED(isptr%contvar_95_percent)) &
        & DEALLOCATE (isptr%contvar_95_percent)
      ALLOCATE (isptr%contvar_5_percent(contvar_count), &
        & isptr%contvar_95_percent(contvar_count))
    END IF

    DO i = 1, UBOUND(isptr%dd%usedvars, 1)
      j = isptr%dd%usedvars(i)

      ! sort constant attributes only once
      IF (skip_constants .AND. getbit(isptr%constant_attr, j)) CYCLE

      attr = isptr%dd%attributes(j)%mapping
      IF (isptr%dd%attributes(j)%cat_count .EQ. contvar) THEN

        ! Create a permutation vector
        CALL qsort_real(isptr%contvars(:,attr), isptr%contvar_perms(:,attr))

        IF (opts%num_prot .GT. 0) THEN
          ! Get the 5% and 95% values
          isptr%contvar_5_percent(attr) = &
            & isptr%contvars(isptr%contvar_perms(percent5, attr), attr)
          isptr%contvar_95_percent(attr) = &
            & isptr%contvars(isptr%contvar_perms(percent95, attr), attr)
        END IF

        ! Rank the instances
        idx = isptr%contvar_perms(1, attr)
        IF (idx.GT.0) THEN ! only if not all values are missing
          isptr%contvar_ranks(idx, attr) = 1
          DO j = 2, instance_count
            temp_idx = isptr%contvar_perms(j, attr)
            ! FIXME this should be idx.EQ.0 EXIT ?
            IF (temp_idx.EQ.0) CYCLE ! Skip missing values altogether
            last_idx = idx
            idx = temp_idx
            IF (isptr%contvars(idx, attr) &
              & .NE. isptr%contvars(last_idx, attr)) THEN
              isptr%contvar_ranks(idx, attr) = &
                & isptr%contvar_ranks(last_idx, attr) + 1
            ELSE
              isptr%contvar_ranks(idx, attr) = &
                & isptr%contvar_ranks(last_idx, attr)
            END IF
          END DO
        ELSE ! if all values are missing, all are rank 1
          DO j = 1, instance_count
            isptr%contvar_ranks(j, attr) = 1
          END DO
        END IF
      END IF
    END DO
  END SUBROUTINE sort_and_rank

  SUBROUTINE count_classes(isptr)
    TYPE (instanceset), POINTER :: isptr
    INTEGER :: i, c, instance_count, class_count, class_catvar
    instance_count = UBOUND(isptr%catvars, 1)
    class_count = isptr%dd%attributes(opts%class_attribute_num)%cat_count
    class_catvar = isptr%dd%attributes(opts%class_attribute_num)%mapping
    ALLOCATE (isptr%class_populations(0:class_count))
    isptr%class_populations = 0
    DO i = 1, instance_count
      c = isptr%catvars(i, class_catvar)
      isptr%class_populations(c) = isptr%class_populations(c) + 1
    END DO
    ALLOCATE (isptr%tagged_instances(instance_count - &
      & isptr%class_populations(0)))
    c = 0
    DO i = 1, instance_count
      IF (isptr%catvars(i, class_catvar).NE.missing_cat) THEN
        c = c + 1
        isptr%tagged_instances(c) = i
      END IF
    END DO
  END SUBROUTINE count_classes

  FUNCTION get_category_by_name(isptr, str)
    INTEGER :: get_category_by_name
    TYPE (instanceset), POINTER :: isptr
    CHARACTER(LEN=*), INTENT(IN) :: str
    TYPE (attribute), POINTER :: class
    INTEGER :: attribute_count, i

    class => isptr%dd%attributes(opts%class_attribute_num)
    DO i = 1, class%cat_count
      IF (TRIM(isptr%dd%categories(i + class%cat_start - 1)%name) &
          & .EQ.TRIM(ADJUSTL(str))) THEN
        get_category_by_name = i
        RETURN
      END IF
    END DO

    ! The name was not recognised, see if it is numeric
    READ(str, *, ERR=9200) get_category_by_name
    IF ((get_category_by_name.GE.1).OR. &
      & (get_category_by_name.LE.class%cat_count)) RETURN

    ! Error
    9200 get_category_by_name = 0
  END FUNCTION get_category_by_name

  FUNCTION get_attribute_by_name(isptr, str)
    INTEGER :: get_attribute_by_name
    TYPE (instanceset), POINTER :: isptr
    CHARACTER(LEN=*), INTENT(IN) :: str
    INTEGER :: attribute_count, i

    attribute_count = UBOUND(isptr%dd%attributes, 1)
    DO i = 1, attribute_count
      IF (TRIM(isptr%dd%attributes(i)%name).EQ.TRIM(ADJUSTL(str))) THEN
        get_attribute_by_name = i
        RETURN
      END IF
    END DO

    ! The name was not recognised, see if it is numeric
    READ(str, *, ERR=9210) get_attribute_by_name
    IF ((get_attribute_by_name.GE.1).AND. &
      & (get_attribute_by_name.LE.attribute_count)) RETURN

    ! Error
    9210 get_attribute_by_name = 0
  END FUNCTION get_attribute_by_name

  SUBROUTINE get_num_split_variables(dd)
    TYPE (datadescription), POINTER :: dd
    INTEGER :: num_used

    num_used = UBOUND(dd%usedvars, 1)
    IF (opts%split_variables.LT.0) THEN
      opts%split_variables = NINT(SQRT(REAL(num_used)))
    ELSE IF (opts%split_variables.GT.num_used) THEN
      opts%split_variables = num_used
    END IF
  END SUBROUTINE

  FUNCTION label_for(isptr, i)
    TYPE (instanceset), POINTER :: isptr
    INTEGER :: i, attr
    CHARACTER(LEN=10) :: label_for

    IF (labelattr.NE.0) THEN
      IF (getbit2(isptr%missing_data, i, labelattr)) THEN
        label_for = "?"
      ELSE
        SELECT CASE (label%cat_count)
          CASE (ignorevar)
            WRITE (label_for, "(A10)"), isptr%ignorevars(i, label%mapping)
          CASE (contvar)
            WRITE (label_for, "(F10.2)"), isptr%contvars(i, label%mapping)
          CASE DEFAULT
            WRITE (label_for, "(A10)"), isptr%dd%categories( &
              & label%cat_start + &
              & isptr%catvars(i, label%mapping) - 1)%name
        END SELECT
      END IF
    ELSE
      WRITE(label_for, "(I10)"), i
    END IF
  END FUNCTION label_for

  SUBROUTINE print_votes(isptr, filename)
    TYPE (instanceset), POINTER :: isptr
    CHARACTER(LEN=*) :: filename
    INTEGER :: i
    CHARACTER(LEN=20) :: fmtstr
    CHARACTER(LEN=10) :: labelstr
    INTEGER :: handle
    LOGICAL :: err

    handle = open_file(filename, .TRUE., err)
    IF (err) RETURN

    WRITE(fmtstr, *) UBOUND(isptr%votes, 2)
    fmtstr = "(A10, 1X, " // TRIM(ADJUSTL(fmtstr)) // "F10.4)"

    DO i = 1, UBOUND(isptr%catvars, 1)
      labelstr = label_for(isptr, i)
      WRITE(handle, fmtstr), labelstr, isptr%votes(i, :)
    END DO

    CALL close_file(handle)
  END SUBROUTINE

  SUBROUTINE process_confusion_matrix(isptr, filename)
    TYPE (instanceset), POINTER :: isptr
    CHARACTER(LEN=*) :: filename
    INTEGER, POINTER :: confusion(:, :)
    INTEGER :: instance_count, i
    TYPE (attribute), POINTER :: class
    INTEGER, POINTER :: counter
    CHARACTER(LEN=20) :: fmtstr
    CHARACTER(LEN=5) :: namestr
    INTEGER :: handle
    INTEGER :: tp, fp, tn, fn
    LOGICAL :: err

    instance_count = UBOUND(isptr%catvars, 1)
    class => isptr%dd%attributes(opts%class_attribute_num)
    ALLOCATE (confusion(0:class%cat_count, 0:class%cat_count))
    confusion = 0

    DO i = 1, instance_count
      counter => confusion(isptr%catvars(i, class%mapping), &
        & isptr%estimated_class(i))
      counter = counter + 1
    END DO

    IF (opts%positive_category_num.NE.0) THEN
      tp = confusion(opts%positive_category_num, opts%positive_category_num)
      fp = SUM(confusion(1:, opts%positive_category_num)) - tp
      tn = SUM((/(confusion(i, i), i = 1, class%cat_count)/)) - tp
      fn = SUM(confusion(1:, 1:)) - (fp + tp + tn)
      IF (isptr%set_type.EQ.trainset_type) fmtstr = "Trainset"
      IF (isptr%set_type.EQ.testset_type) fmtstr = " Testset"
      WRITE(6, "(A8, 1X, A10, F8.4, A9, F8.4, A14, F8.4)") fmtstr, &
        & "Precision:", REAL(tp) / (tp + fp), &
        & "; Recall:", REAL(tp) / (tp + fn), &
        & "; Specificity:", REAL(tn) / (tn + fp)
    END IF

    IF (LEN_TRIM(filename).GT.0) THEN

      handle = open_file(filename, .TRUE., err)
      IF (.NOT.err) THEN

        WRITE(fmtstr, *) class%cat_count + 1
        fmtstr = "(A6, " // TRIM(ADJUSTL(fmtstr)) // "(1X, A5))"

        WRITE(handle, fmtstr) "Tag\Cl", "NotCl", &
          & (ADJUSTR(isptr%dd%categories(i)%name(1:5)), &
          & i = class%cat_start, class%cat_start + class%cat_count - 1)

        WRITE(fmtstr, *) class%cat_count + 1
        fmtstr = "(1X, A5, " // TRIM(ADJUSTL(fmtstr)) // "I6)"

        DO i = 0, class%cat_count
          IF (i.EQ.0) THEN
            namestr = "NoTag"
          ELSE
            namestr = isptr%dd%categories(class%cat_start + i - 1)%name
          END IF
          WRITE(handle, fmtstr), namestr, confusion(i, :)
        END DO
      END IF
    END IF
    DEALLOCATE (confusion)

    CALL close_file(handle)
  END SUBROUTINE process_confusion_matrix
END MODULE instancesets

max_stars_repo_name: efurlanm/parf

max_issues_repo_name: efurlanm/parf

max_forks_repo_name: efurlanm/parf


text:
      FUNCTION K63R(J,M,K,L,R,JA)
C BY GEORGE DUISMAN
C EDITED FROM BASIC BY AX, 3/7/79
C TYPED BY JM 3/15/79
      K63R=JA       ! Added 7/32/93 to report own old value
      IF (M .EQ. 1) ik = 1
      ik = 1 - ik
      K63R = IK
cc test 2 lines Ax 7/93. Also rewritten by Ax 7/21/93 putting ik where K63r was
cc  write (6,993) k63r
cc993   format (' test from k63r, k63r= ', i3)
C COOP ON ODD MOVES ONLY
      RETURN
      END

ext: f

max_stars_repo_name: Axelrod-Python/TourExec

max_issues_repo_name: Axelrod-Python/TourExec

max_forks_repo_name: Axelrod-Python/TourExec


text:
Address(Vistosa Street) is a residential street in the Mace Ranch section of East Davis.

 Intersecting Streets

  Caricia Drive across the intersection is Vistosa Court
  Arroyo Avenue

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
C
C $Id: surf2.f,v 1.5 2008-07-27 03:10:12 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
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding double precision routine.
C
      function surf2 (xx,yy,m,n,x,y,z,iz,zp,sigma)
c
      integer m,n,iz
      real xx,yy,x(m),y(n),z(iz,n),zp(m,n,3),sigma
c
c                                 coded by alan kaylor cline
c                           from fitpack -- january 26, 1987
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a surface at a given coordinate
c pair using a bi-spline under tension. the subroutine surf1
c should be called earlier to determine certain necessary
c parameters.
c
c on input--
c
c   xx and yy contain the x- and y-coordinates of the point
c   to be mapped onto the interpolating surface.
c
c   m and n contain the number of grid lines in the x- and
c   y-directions, respectively, of the rectangular grid
c   which specified the surface.
c
c   x and y are arrays containing the x- and y-grid values,
c   respectively, each in increasing order.
c
c   z is a matrix containing the m * n functional values
c   corresponding to the grid values (i. e. z(i,j) is the
c   surface value at the point (x(i),y(j)) for i = 1,...,m
c   and j = 1,...,n).
c
c   iz contains the row dimension of the array z as declared
c   in the calling program.
c
c   zp is an array of 3*m*n locations stored with the
c   various surface derivative information determined by
c   surf1.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters m, n, x, y, z, iz, zp, and sigma should be
c input unaltered from the output of surf1.
c
c on output--
c
c   surf2 contains the interpolated surface value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c inline one dimensional cubic spline interpolation
c
      hermz (f1,f2,fp1,fp2) = (f2*del1+f1*del2)/dels-del1*
     *                        del2*(fp2*(del1+dels)+
     *                              fp1*(del2+dels))/
     *                        (6.*dels)
c
c inline one dimensional spline under tension interpolation
c
      hermnz (f1,f2,fp1,fp2,sigmap) = (f2*del1+f1*del2)/dels
     *          +(fp2*del1*(sinhm1-sinhms)
     *           +fp1*del2*(sinhm2-sinhms)
     *          )/(sigmap*sigmap*dels*(1.+sinhms))
c
c denormalize tension factor in x and y direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c determine y interval
c
      jm1 = intrvl (yy,y,n)
      j = jm1+1
c
c determine x interval
c
      im1 = intrvl (xx,x,m)
      i = im1+1
      del1 = yy-y(jm1)
      del2 = y(j)-yy
      dels = y(j)-y(jm1)
      if (sigmay .ne. 0.) go to 1
c
c perform four interpolations in y-direction
c
      zim1 = hermz(z(i-1,j-1),z(i-1,j),zp(i-1,j-1,1),
     *                                  zp(i-1,j,1))
      zi = hermz(z(i,j-1),z(i,j),zp(i,j-1,1),zp(i,j,1))
      zxxim1 = hermz(zp(i-1,j-1,2),zp(i-1,j,2),
     *                zp(i-1,j-1,3),zp(i-1,j,3))
      zxxi = hermz(zp(i,j-1,2),zp(i,j,2),
     *              zp(i,j-1,3),zp(i,j,3))
      go to 2
    1 call snhcsh (sinhm1,dummy,sigmay*del1,-1)
      call snhcsh (sinhm2,dummy,sigmay*del2,-1)
      call snhcsh (sinhms,dummy,sigmay*dels,-1)
      zim1 = hermnz(z(i-1,j-1),z(i-1,j),zp(i-1,j-1,1),
     *               zp(i-1,j,1),sigmay)
      zi = hermnz(z(i,j-1),z(i,j),zp(i,j-1,1),zp(i,j,1),
     *             sigmay)
      zxxim1 = hermnz(zp(i-1,j-1,2),zp(i-1,j,2),
     *                 zp(i-1,j-1,3),zp(i-1,j,3),sigmay)
      zxxi = hermnz(zp(i,j-1,2),zp(i,j,2),
     *               zp(i,j-1,3),zp(i,j,3),sigmay)
c
c perform final interpolation in x-direction
c
    2 del1 = xx-x(im1)
      del2 = x(i)-xx
      dels = x(i)-x(im1)
      if (sigmax .ne. 0.) go to 3
      surf2 = hermz(zim1,zi,zxxim1,zxxi)
      return
    3 call snhcsh (sinhm1,dummy,sigmax*del1,-1)
      call snhcsh (sinhm2,dummy,sigmax*del2,-1)
      call snhcsh (sinhms,dummy,sigmax*dels,-1)
      surf2 = hermnz(zim1,zi,zxxim1,zxxi,sigmax)
      return
      end

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
      program t
      implicit none
!     inquire stmt 'pad' specifier (no)
 !     and character variable in open stmt
      character*3::a, yes='no'
      open (56, status='new', file='tmpfile', pad=yes)
      inquire (56, pad=a)
      print *,a
      close (56,status='delete')
      endprogram t

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text:
program remover
use msflib
integer,allocatable :: arqui(:,:),aux(:,:)
integer i,ii,n,esco,v,lin,m
n=0
allocate(arqui(5,2),aux(5,2))
arqui = 0 ; aux = 0
do while(.true.)
read(*,*)esco
select case(esco)
case(1)
n = n+1
read(*,*)v
arqui(n,1)=v
call clearscreen($gclearscreen)
case(2)
write(*,*)(arqui(i,1),i=1,5)
call sleep(2)
call clearscreen($gclearscreen)
case(3)
m=0
read(*,*)lin
remove:do i = 1,5
if(i == lin)cycle remove
m = m+1
aux(m,1)=arqui(i,1)
end do remove
arqui = aux
n = n-1
case(4)
i = clickmenuqq(loc(winexit))
end select
end do
stop
end program

max_stars_repo_path: codes/teste remover/teste1.f90

max_stars_repo_name: danielsanfr/fortran-study

max_issues_repo_path: codes/teste remover/teste1.f90

max_issues_repo_name: danielsanfr/fortran-study

max_forks_repo_path: codes/teste remover/teste1.f90

max_forks_repo_name: danielsanfr/fortran-study


text:
module Mod_plcd_Rotators
   use typre
   use Mod_plcd_Rotation
   use Mod_Memor
   implicit none
   private
   public Rotator_Yes, Rotator_Not

   type, extends(Rotation) :: Rotator_Yes

      integer(ip) :: ndime
      real(rp), allocatable :: angle(:)
      real(rp), allocatable :: OpeA(:,:), OpeR(:,:), OpeRbar(:,:)

contains

      procedure :: SetNdime => Yes_SetNdime
      procedure :: SetAngle => Yes_SetAngle
      procedure :: GetAngle => Yes_GetAngle
      procedure :: ScatterData => Yes_ScatterData
      procedure :: Initialize => Yes_Initialize
      procedure :: Finalize => Yes_Finalize
      procedure :: Vec_Glo2Loc => Yes_Vec_Glo2Loc
      procedure :: Vec_Loc2Glo => Yes_Vec_Loc2Glo
      procedure :: Mat_Glo2Loc => Yes_Mat_Glo2Loc
      procedure :: Mat_Loc2Glo => Yes_Mat_Loc2Glo
      procedure :: strain_Glo2Loc => Yes_strain_Glo2Loc
      procedure :: strain_Loc2Glo => Yes_strain_Loc2Glo
      procedure :: stress_Glo2Loc => Yes_stress_Glo2Loc
      procedure :: stress_Loc2Glo => Yes_stress_Loc2Glo
      procedure :: CT_Glo2Loc => Yes_CT_Glo2Loc
      procedure :: CT_Loc2Glo => Yes_CT_Loc2Glo

   end type

   type, extends(Rotation) :: Rotator_Not

contains

      procedure :: SetNdime => Not_SetNdime
      procedure :: SetAngle => Not_SetAngle
      procedure :: GetAngle => Not_GetAngle
      procedure :: ScatterData => Not_ScatterData
      procedure :: Initialize => Not_Initialize
      procedure :: Finalize => Not_Finalize
      procedure :: Vec_Glo2Loc => Not_Vec_Glo2Loc
      procedure :: Vec_Loc2Glo => Not_Vec_Loc2Glo
      procedure :: Mat_Glo2Loc => Not_Mat_Glo2Loc
      procedure :: Mat_Loc2Glo => Not_Mat_Loc2Glo
      procedure :: strain_Glo2Loc => Not_strain_Glo2Loc
      procedure :: strain_Loc2Glo => Not_strain_Loc2Glo
      procedure :: stress_Glo2Loc => Not_stress_Glo2Loc
      procedure :: stress_Loc2Glo => Not_stress_Loc2Glo
      procedure :: CT_Glo2Loc => Not_CT_Glo2Loc
      procedure :: CT_Loc2Glo => Not_CT_Loc2Glo

   end type

contains

!  SetNdime

   subroutine Yes_SetNdime(a,ndime)
      implicit none
      class(Rotator_Yes) :: a
      integer(ip) :: ndime

      a%ndime = ndime

   end subroutine

   subroutine Not_SetNdime(a,ndime)
      implicit none
      class(Rotator_Not) :: a
      integer(ip) :: ndime

   end subroutine

!  SetAngle

   subroutine Yes_SetAngle(a,angle,Memor)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: angle(:)
      type(MemoryMan) :: Memor

      select case(a%ndime)
      case(2)
!         allocate(a%angle(1))
         Call Memor%alloc(1,a%angle,'EulerAngles','Rotator')
         a%angle = angle(1)

      case(3)
!         allocate(a%angle(3))
         Call Memor%alloc(3,a%angle,'EulerAngles','Rotator')
         a%angle = angle(1:3)

      case default
         call runend('Rotation not implemented for this ndime data')

      end select

   end subroutine

   subroutine Not_SetAngle(a,angle,Memor)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: angle(:)
      type(MemoryMan) :: Memor

   end subroutine

!  GetAngle

   subroutine Yes_GetAngle(a,angle)
      implicit none
      class(Rotator_Yes),target :: a
      real(rp), pointer :: angle(:)

      angle => a%angle
   end subroutine

   subroutine Not_GetAngle(a,angle)
      implicit none
      class(Rotator_Not),target :: a
      real(rp), pointer :: angle(:)

   end subroutine

! ScatterData

   subroutine Yes_ScatterData(a)
      use MPI
      implicit none
      class(Rotator_Yes) :: a
      integer(ip) :: ierr
      call MPI_BCAST(a%angle,size(a%angle),MPI_REAL8,a%MPIroot,a%MPIcomm,ierr)

   end subroutine

   subroutine Not_ScatterData(a)
      use MPI
      implicit none
      class(Rotator_Not) :: a

   end subroutine

!  Initialize

   subroutine Yes_Initialize(a,Memor)
      implicit none
      class(Rotator_Yes) :: a
      type(MemoryMan) :: Memor
      real(rp), parameter :: PI = 3.14159265
      real(rp) :: c1,s1,c2,s2,c3,s3
      real(rp) :: l1,l2,l3,m1,m2,m3,n1,n2,n3

      select case(a%ndime)
      case(2)
!         allocate(a%OpeA(2,2),a%OpeR(3,3),a%OpeRbar(3,3))
         call Memor%alloc(2,2,a%OpeA,'OpeA','Rotator Initialize')
         call Memor%alloc(3,3,a%OpeR,'OpeR','Rotator Initialize')
         call Memor%alloc(3,3,a%OpeRbar,'OpeRbar','Rotator Initialize')

         l1 = dcos(a%angle(1)*PI/180.) ; l2 = -dsin(a%angle(1)*PI/180.)
         m1 = dsin(a%angle(1)*PI/180.) ; m2 = dcos(a%angle(1)*PI/180.)

         a%OpeA(1,1) = l1 ;  a%OpeA(1,2) = l2
         a%OpeA(2,1) = m1 ;  a%OpeA(2,2) = m2

         a%OpeR(1,1) = l1**2  ;  a%OpeR(1,2) = l2**2  ;  a%OpeR(1,3) = 2*l1*l2
         a%OpeR(2,1) = m1**2  ;  a%OpeR(2,2) = m2**2  ;  a%OpeR(2,3) = 2*m1*m2
         a%OpeR(3,1) = l1*m1  ;  a%OpeR(3,2) = l2*m2 ;  a%OpeR(3,3) = l1*m2+m1*l2

         a%OpeRbar(1,1) = l1**2     ;  a%OpeRbar(1,2) = l2**2    ;  a%OpeRbar(1,3) = l1*l2
         a%OpeRbar(2,1) = m1**2     ;  a%OpeRbar(2,2) = m2**2    ;  a%OpeRbar(2,3) = m1*m2
         a%OpeRbar(3,1) = 2*l1*m1   ;  a%OpeRbar(3,2) = 2*l2*m2  ;  a%OpeRbar(3,3) = l1*m2+m1*l2

      case(3)
!         allocate(a%OpeA(3,3),a%OpeR(6,6),a%OpeRbar(6,6))
         call Memor%alloc(3,3,a%OpeA,'OpeA','Rotator Initialize')
         call Memor%alloc(6,6,a%OpeR,'OpeR','Rotator Initialize')
         call Memor%alloc(6,6,a%OpeRbar,'OpeRbar','Rotator Initialize')

         c1 = dcos(a%angle(1)*PI/180.) ; s1 = dsin(a%angle(1)*PI/180.)
         c2 = dcos(a%angle(2)*PI/180.) ; s2 = dsin(a%angle(2)*PI/180.)
         c3 = dcos(a%angle(3)*PI/180.) ; s3 = dsin(a%angle(3)*PI/180.)

         l1 = c1*c3 - s1*c2*s3   ;  l2 = -c1*s3 - s1*c2*c3  ;  l3 = -s1*s2
         m1 = s1*c3 + c1*c2*s3   ;  m2 = -s1*s3 + c1*c2*c3  ;  m3 = -c1*s2
         n1 = s2*s3              ;  n2 = s2*c3              ;  n3 = c2

         a%OpeA(1,1) = l1 ;  a%OpeA(1,2) = l2 ;  a%OpeA(1,3) = l3
         a%OpeA(2,1) = m1 ;  a%OpeA(2,2) = m2 ;  a%OpeA(2,3) = m3
         a%OpeA(3,1) = n1 ;  a%OpeA(3,2) = n2 ;  a%OpeA(3,3) = n3

         a%OpeR(1,1) = l1**2    ; a%OpeR(1,2) = l2**2     ;  a%OpeR(1,3) = l3**2
         a%OpeR(1,4) = 2*l1*l2  ; a%OpeR(1,5) = 2*l1*l3   ;  a%OpeR(1,6) = 2*l2*l3

         a%OpeR(2,1) = m1**2    ; a%OpeR(2,2) = m2**2     ;  a%OpeR(2,3) = m3**2
         a%OpeR(2,4) = 2*m1*m2  ; a%OpeR(2,5) = 2*m1*m3   ;  a%OpeR(2,6) = 2*m2*m3

         a%OpeR(3,1) = n1**2    ; a%OpeR(3,2) = n2**2     ;  a%OpeR(3,3) = n3**2
         a%OpeR(3,4) = 2*n1*n2  ; a%OpeR(3,5) = 2*n1*n3   ;  a%OpeR(3,6) = 2*n2*n3

         a%OpeR(4,1) = l1*m1          ; a%OpeR(4,2) = l2*m2           ;  a%OpeR(4,3) = l3*m3
         a%OpeR(4,4) = l1*m2 + l2*m1  ; a%OpeR(4,5) = l1*m3 + l3*m1   ;  a%OpeR(4,6) = l2*m3 + l3*m2

         a%OpeR(5,1) = l1*n1          ; a%OpeR(5,2) = l2*n2           ;  a%OpeR(5,3) = l3*n3
         a%OpeR(5,4) = l1*n2 + l2*n1  ; a%OpeR(5,5) = l1*n3 + l3*n1   ;  a%OpeR(5,6) = l2*n3 + l3*n2

         a%OpeR(6,1) = m1*n1          ; a%OpeR(6,2) = m2*n2           ;  a%OpeR(6,3) = m3*n3
         a%OpeR(6,4) = m1*n2 + m2*n1  ; a%OpeR(6,5) = m1*n3 + m3*n1   ;  a%OpeR(6,6) = m2*n3 + m3*n2

         a%OpeRbar(1,1) = l1**2  ; a%OpeRbar(1,2) = l2**2   ;  a%OpeRbar(1,3) = l3**2
         a%OpeRbar(1,4) = l1*l2  ; a%OpeRbar(1,5) = l1*l3   ;  a%OpeRbar(1,6) = l2*l3

         a%OpeRbar(2,1) = m1**2  ; a%OpeRbar(2,2) = m2**2   ;  a%OpeRbar(2,3) = m3**2
         a%OpeRbar(2,4) = m1*m2  ; a%OpeRbar(2,5) = m1*m3   ;  a%OpeRbar(2,6) = m2*m3

         a%OpeRbar(3,1) = n1**2  ; a%OpeRbar(3,2) = n2**2   ;  a%OpeRbar(3,3) = n3**2
         a%OpeRbar(3,4) = n1*n2  ; a%OpeRbar(3,5) = n1*n3   ;  a%OpeRbar(3,6) = n2*n3

         a%OpeRbar(4,1) = 2*l1*m1        ; a%OpeRbar(4,2) = 2*l2*m2         ;  a%OpeRbar(4,3) = 2*l3*m3
         a%OpeRbar(4,4) = l1*m2 + l2*m1  ; a%OpeRbar(4,5) = l1*m3 + l3*m1   ;  a%OpeRbar(4,6) = l2*m3 + l3*m2

         a%OpeRbar(5,1) = 2*l1*n1        ; a%OpeRbar(5,2) = 2*l2*n2         ;  a%OpeRbar(5,3) = 2*l3*n3
         a%OpeRbar(5,4) = l1*n2 + l2*n1  ; a%OpeRbar(5,5) = l1*n3 + l3*n1   ;  a%OpeRbar(5,6) = l2*n3 + l3*n2

         a%OpeRbar(6,1) = 2*m1*n1        ; a%OpeRbar(6,2) = 2*m2*n2         ;  a%OpeRbar(6,3) = 2*m3*n3
         a%OpeRbar(6,4) = m1*n2 + m2*n1  ; a%OpeRbar(6,5) = m1*n3 + m3*n1   ;  a%OpeRbar(6,6) = m2*n3 + m3*n2

      case default
         call runend('Rotation not implemented for this ndime data')
      end select
   end subroutine

   subroutine Not_Initialize(a,Memor)
      implicit none
      class(Rotator_Not) :: a
      type(MemoryMan) :: Memor

   end subroutine

! Finalize

   subroutine Yes_Finalize(a,Memor)
      implicit none
      class(Rotator_Yes) :: a
      type(MemoryMan) :: Memor

      select case(a%ndime)
      case(2)
!         allocate(a%OpeA(2,2),a%OpeR(3,3),a%OpeRbar(3,3))
         call Memor%dealloc(2,2,a%OpeA,'OpeA','Rotator Initialize')
         call Memor%dealloc(3,3,a%OpeR,'OpeR','Rotator Initialize')
         call Memor%dealloc(3,3,a%OpeRbar,'OpeRbar','Rotator Initialize')

      case(3)
!         allocate(a%OpeA(3,3),a%OpeR(6,6),a%OpeRbar(6,6))
         call Memor%dealloc(3,3,a%OpeA,'OpeA','Rotator Initialize')
         call Memor%dealloc(6,6,a%OpeR,'OpeR','Rotator Initialize')
         call Memor%dealloc(6,6,a%OpeRbar,'OpeRbar','Rotator Initialize')

      end select

   end subroutine

   subroutine Not_Finalize(a,Memor)
      implicit none
      class(Rotator_Not) :: a
      type(MemoryMan) :: Memor

   end subroutine

!  Vec_Glo2Loc

   subroutine Yes_Vec_Glo2Loc(a,VecGloIn,VecLocOut)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: VecGloIn(:), VecLocOut(:)

      VecLocOut = matmul(transpose(a%OpeA),VecGloIn)

   end subroutine

   subroutine Not_Vec_Glo2Loc(a,VecGloIn,VecLocOut)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: VecGloIn(:), VecLocOut(:)

      VecLocOut = VecGloIn

   end subroutine

!  Vec_Loc2Glo

   subroutine Yes_Vec_Loc2Glo(a,VecLocIn,VecGloOut)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: VecLocIn(:), VecGloOut(:)

      VecGloOut = matmul(a%OpeA,VecLocIn)

   end subroutine

   subroutine Not_Vec_Loc2Glo(a,VecLocIn,VecGloOut)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: VecLocIn(:), VecGloOut(:)

      VecGloOut = VecLocIn

   end subroutine

!  Mat_Glo2Loc

   subroutine Yes_Mat_Glo2Loc(a,MatGloIn,MatLocOut)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: MatGloIn(:,:), MatLocOut(:,:)

      MatLocOut = matmul(transpose(a%OpeA),matmul(MatGloIn,a%OpeA))

   end subroutine

   subroutine Not_Mat_Glo2Loc(a,MatGloIn,MatLocOut)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: MatGloIn(:,:), MatLocOut(:,:)

      MatLocOut = MatGloIn

   end subroutine

!  Mat_Loc2Glo

   subroutine Yes_Mat_Loc2Glo(a,MatLocIn,MatGloOut)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: MatLocIn(:,:), MatGloOut(:,:)

      MatGloOut = matmul(a%OpeA,matmul(MatLocIn,transpose(a%OpeA)))

   end subroutine

   subroutine Not_Mat_Loc2Glo(a,MatLocIn,MatGloOut)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: MatLocIn(:,:), MatGloOut(:,:)

      MatGloOut = MatLocIn

   end subroutine

!  strain_Glo2Loc

   subroutine Yes_strain_Glo2Loc(a,strainGloIn,strainLocOut)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: strainGloIn(:), strainLocOut(:)

      strainLocOut = matmul(transpose(a%OpeR),strainGloIn)

   end subroutine

   subroutine Not_strain_Glo2Loc(a,strainGloIn,strainLocOut)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: strainGloIn(:), strainLocOut(:)

      strainLocOut = strainGloIn

   end subroutine

!  strain_Loc2Glo

   subroutine Yes_strain_Loc2Glo(a,strainLocIn,strainGloOut)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: strainLocIn(:), strainGloOut(:)

      strainGloOut = matmul(a%OpeRbar,strainLocIn)

   end subroutine

   subroutine Not_strain_Loc2Glo(a,strainLocIn,strainGloOut)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: strainLocIn(:), strainGloOut(:)

      strainGloOut = strainLocIn

   end subroutine

!  stress_Glo2Loc

   subroutine Yes_stress_Glo2Loc(a,stressGloIn,stressLocOut)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: stressGloIn(:), stressLocOut(:)

      stressLocOut = matmul(transpose(a%OpeRbar),stressGloIn)

   end subroutine

   subroutine Not_stress_Glo2Loc(a,stressGloIn,stressLocOut)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: stressGloIn(:), stressLocOut(:)

      stressLocOut = stressGloIn

   end subroutine

!  stress_Loc2Glo

   subroutine Yes_stress_Loc2Glo(a,stressLocIn,stressGloOut)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: stressLocIn(:), stressGloOut(:)

      stressGloOut = matmul(a%OpeR,stressLocIn)

   end subroutine

   subroutine Not_stress_Loc2Glo(a,stressLocIn,stressGloOut)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: stressLocIn(:), stressGloOut(:)

      stressGloOut = stressLocIn

   end subroutine

!  CT_Glo2Loc

   subroutine Yes_CT_Glo2Loc(a,CTGloIn,CTLocOut)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: CTGloIn(:,:), CTLocOut(:,:)

      CTLocOut = matmul(transpose(a%OpeRbar),matmul(CTGloIn,a%OpeRbar))

   end subroutine

   subroutine Not_CT_Glo2Loc(a,CTGloIn,CTLocOut)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: CTGloIn(:,:), CTLocOut(:,:)

      CTLocOut = CTGloIn

   end subroutine

!  CT_Loc2Glo

   subroutine Yes_CT_Loc2Glo(a,CTLocIn,CTGloOut)
      implicit none
      class(Rotator_Yes) :: a
      real(rp) :: CTLocIn(:,:), CTGloOut(:,:)

      CTGloOut = matmul(a%OpeR,matmul(CTLocIn,transpose(a%OpeR)))

   end subroutine

   subroutine Not_CT_Loc2Glo(a,CTLocIn,CTGloOut)
      implicit none
      class(Rotator_Not) :: a
      real(rp) :: CTLocIn(:,:), CTGloOut(:,:)

      CTGloOut = CTLocIn

   end subroutine

end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
c===========================================================================
c
c   This file is part of TISEAN
c
c   Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber
c
c   TISEAN is free software; you can redistribute it and/or modify
c   it under the terms of the GNU General Public License as published by
c   the Free Software Foundation; either version 2 of the License, or
c   (at your option) any later version.
c
c   TISEAN is distributed in the hope that it will be useful,
c   but WITHOUT ANY WARRANTY; without even the implied warranty of
c   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c   GNU General Public License for more details.
c
c   You should have received a copy of the GNU General Public License
c   along with TISEAN; if not, write to the Free Software
c   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
c
c===========================================================================
c   information dimension, fixed mass
c   see  H. Kantz, T. Schreiber, Nonlinear Time Series Analysis, Cambridge
c      University Press (1997)
c   author T. Schreiber (1999)
c===========================================================================

      parameter(nx=100000,mx=10)
      dimension x(nx,mx), icol(mx)
      character*72 file, fout
      data kmax/100/, res/2./
      data iverb/1/
      external rand

      call whatido("fixed mass approach to d1 estimation",iverb)
      id=imust("d")
      mfrom=imust("m")
      mto=imust("M")
      ntmin=imust("t")
      ncmin=imust("n")
      res=fcan("#",res)
      r=rand(sqrt(abs(fcan("I",0.0))))
      kmax=ican("K",kmax)
      resl=log(2.)/res
      nmax=ican("l",nx)
      nexcl=ican("x",0)
      call columns(mc,mx,icol)
      mcmax=max(1,mc)
      isout=igetout(fout,iverb)
      if(fout.eq." ") isout=1

      call nthstring(1,file)
      call xreadfile(nmax,mcmax,nx,x,nexcl,icol,file,iverb)
      if(file.eq."-") file="stdin"
      if(isout.eq.1) call addsuff(fout,file,"_c1")
      call outfile(fout,iunit,iverb)
      do 10 m=mfrom,mto
         write(iunit,'(4h#m= ,i5)') m
         pr=0.
         do 20 pl=log(1./(nmax-(m-1)*id)),0.,resl
            pln=pl
            call d1(nmax,mcmax,nx,x,id,m,ncmin,pr,pln,rln,ntmin,kmax)
            if(pln.eq.pr) goto 20
            it=it+1
            pr=pln
            write(iunit,*)   exp(rln), exp(pln)
 20         continue
         write(iunit,'()')
 10      write(iunit,'()')
      end

      subroutine usage()
c usage message

      call whatineed(
     .   "-d# -m# -M# -t# -n# "//
     .   "[-## -K# -o outfile -I# -l# -x# -c#,# -V# -h] file")
      call popt("d","delay")
      call popt("m","minimal total embedding dimension")
      call popt("M","maximal total embedding dimension")
      call popt("t","minimal time separation")
      call popt("n","minimal number of center points")
      call popt("#","resolution, values per octave (2)")
      call popt("K","maximal number of neighbours (100)")
      call popt("I","seed for random numbers")
      call popt("l","number of values to be read (all)")
      call popt("x","number of values to be skipped (0)")
      call popt("c","column(s) to be read (1 or file,#)")
      call pout("file_c1")
      call pall()
      stop
      end

max_stars_repo_name: homiak/jabaws

max_issues_repo_name: homiak/jabaws

max_forks_repo_name: homiak/jabaws


text:
      ! netCDF FORTRAN 90 Application/Abstraction Interface (nf90ai)
      ! netcdf - netcdfai
      ! nf90_  - nf90ai
      !
      program nf90ai_example
        use netcdfai
        implicit none

        type(nf90ai_meta) :: meta
        character(len=4) :: varName='Temp'
        real, pointer :: var(:,:,:)

        ! Read netcdf file meta information
        nf90ai_new_meta(meta,filename)

        ! "ncdump" print
        nf90ai_dump(meta)

        ! Get a variable
        nf90ai_get_var(meta,varName,var)

      end program nf90ai_example

max_stars_repo_name: ScottLongmore/netCDF-fortran-API

max_issues_repo_name: ScottLongmore/netCDF-fortran-API

max_forks_repo_name: ScottLongmore/netCDF-fortran-API


text:
********************************************************************************
!     Input Variables:
!     S        Amount of susceptible members at the current timestep
!     I        Amount of infected members at the current timestep
!     R        Amount of recovered members at the current timestep
!     beta     Rate of transmission via contact
!     gamma    Rate of recovery from infection
!     dt       Next inter-event time
!
!     State Variables:
!     infected    Increase in infected at the current timestep
!     recovered   Increase in recovered at the current timestep
********************************************************************************
      subroutine sir(S, I, R, beta, gamma, dt)
        implicit none
        double precision S, I, R, beta, gamma, dt
        double precision infected, recovered

        infected = (-(beta*S*I) / (S + I + R)) * dt
        recovered = (gamma*I) * dt

        S = S - infected
        I = I + infected - recovered
        R = R + recovered
      end subroutine sir