!=======================================================================
!  MODULE Aloha_mod
!  03/28/2017 CHP Written
!=======================================================================

      MODULE Aloha_mod
!     Contains data definitions for Aloha Pineaple model
      USE ModuleDefs

!     Data construct for control variables
      TYPE AlohaCul_type
        CHARACTER*6 VARNO,ECONO
        CHARACTER*12 CULfile
        CHARACTER*16 VRNAME
        CHARACTER*80 CULpath
        REAL P1, P2, P3, P4, P5, P6
        REAL G2, G3, PHINT
      END TYPE AlohaCul_type

      TYPE AlohaSpe_type
        CHARACTER*12 SPEfile
        CHARACTER*80 SPEpath
        REAL CONV, FDMC
        REAL TBASV, TOPTV, TTOPV
        REAL TBASR, TOPTR, TTOPR
        REAL LIFAC
        REAL RWEP, PORM, RWMX, RLWR
        REAL CMFC
        REAL, DIMENSION(10) :: CO2X, CO2Y
      End Type AlohaSpe_type

      TYPE AlohaSow_type
        REAL PLTPOP, SDEPTH, SDWTPL, PLANTSIZE
        INTEGER NFORCING, NDOF, PMTYPE, ForcingYRDOY
      End Type AlohaSow_type

      Type (AlohaCul_type) Cultivar
      Type (AlohaSpe_type) Species
      Type (AlohaSow_type) Planting

      CHARACTER*10 STNAME(20)
!     REAL TEMPM

      DATA STNAME/    &
        'Zero Stem ', &   ! 1
        'Forcing   ', &   ! 2
        'SCY       ', &   ! 3
        'Early Flwr', &   ! 4
        'Fruit Harv', &   ! 5
        'Maturity  ', &   ! 6
        'Planting  ', &   ! 7
        'Root Init.', &   ! 8
        'Leaf Emerg', &   ! 9
        '          ', &   !10
        '          ', &   !11
        '          ', &   !12
        '          ', &   !13
        'Start Sim ', &   !14
        'End Sim   ', &   !15
        '          ', &   !16
        '          ', &   !17
        '          ', &   !18
        '          ', &   !19
        'Harvest   '/     !20

      CONTAINS

!=======================================================================
!  Aloha_IPCROP, Subroutine
!  Read crop parameters from PIALO980.SPE
!-----------------------------------------------------------------------
!  Revision history
!
!  06/15/1994 PWW Original written
!  03/29/2017 CGO Revised for v4.6
!=======================================================================
      SUBROUTINE Aloha_IPCROP (CONTROL)

      IMPLICIT    NONE
      SAVE

      CHARACTER*6 SECTION
      CHARACTER*8, PARAMETER :: ERRKEY = 'IP_ALOHA'
      CHARACTER*200 FILESPE, TEXTLINE
      INTEGER ERR, FOUND, I, ISECT, L, LNUM, LUNIO, LUNSPE

      TYPE (ControlType) CONTROL
      LUNIO  = CONTROL % LUNIO

!-----------------------------------------------------------------------
!   Open species file, parse headers, and read data.
    FILESPE = TRIM(Species%SPEpath) // TRIM(Species%SPEfile)
    CALL GETLUN('FILEC', LUNSPE)
    OPEN (LUNSPE, FILE = FILESPE, ACTION = 'READ', IOSTAT=ERR)
    IF (ERR .NE. 0) THEN
       CALL ERROR(ERRKEY,ERR,FILESPE,0)
    END IF

    SECTION = "*SPECI"
    CALL FIND(LUNSPE,SECTION,LNUM,FOUND)

    L=0
    DO WHILE (.TRUE.)
      CALL IGNORE (LUNSPE, LNUM, ISECT, TEXTLINE)

      SELECT CASE(ISECT)
      CASE(0); EXIT   !End of file

!     -----------------------------------------
!     Read species file parameters
      CASE(1);        !Data record
        L = L + 1
        SELECT CASE(L)
        CASE (1); READ(TEXTLINE,'(2F7.0)',IOSTAT=ERR) Species % CONV,  Species % FDMC
        CASE (2); READ(TEXTLINE,'(3F7.0)',IOSTAT=ERR) Species % TBASV, Species % TOPTV, Species % TTOPV
        CASE (3); READ(TEXTLINE,'(3F7.0)',IOSTAT=ERR) Species % TBASR, Species % TOPTR, Species % TTOPR
        CASE (4); READ(TEXTLINE,'(1F7.0)',IOSTAT=ERR) Species % LIFAC
        CASE (5); READ(TEXTLINE,'(4F7.0)',IOSTAT=ERR) Species % RWEP, Species % PORM, Species % RWMX, Species % RLWR
        CASE (6); READ(TEXTLINE,'(2F7.0)',IOSTAT=ERR) Species % CMFC
        CASE (7:16); I = L - 6
                  READ(TEXTLINE,'(2F7.0)',IOSTAT=ERR) Species % CO2X(I), Species % CO2Y(I)
        END SELECT !L = Data line selection
        IF (ERR .NE. 0) GOTO 100
!     -----------------------------------------

      CASE(2); EXIT   !End of section
      END SELECT !ISECT
    ENDDO

    RETURN

100 CALL ERROR(ERRKEY,ERR,FILESPE,LNUM)

!   -------------------------------------------
!   No ecotype file for now
!      READ(LUNIO,51,IOSTAT=ERR) FILEE, PATHEC; LNUM = LNUM + 1
!   51 FORMAT(15X,A12,1X,A80)
!      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)

      RETURN
      END SUBROUTINE Aloha_IPCROP

!=======================================================================
!  Aloha_IpPlant, Subroutine
!  Read crop parameters from PIALO980.SPE
!-----------------------------------------------------------------------
!  Revision history
!
!  06/15/1994 PWW Original written
!  03/29/2017 CHP Revised for v4.6
!=======================================================================
      SUBROUTINE Aloha_IpPlant (CONTROL)

      IMPLICIT NONE
      SAVE

      CHARACTER*6, PARAMETER :: ERRKEY = 'IPPLNT'
      CHARACTER*5 ChemType
      CHARACTER*6 SECTION
      CHARACTER*12 FILEIO
      INTEGER LUNIO, ERR, LNUM, LINC, FOUND, ChemYRDOY
      TYPE (ControlType) CONTROL

      FILEIO = CONTROL % FILEIO

!     -----------------------------------------------------------------
!     Read input file name (ie. DSSAT45.INP) and path
      CALL GETLUN('FILEIO', LUNIO)
      OPEN (LUNIO, FILE = CONTROL % FILEIO, STATUS = 'OLD', IOSTAT=ERR)
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,0)
      REWIND (LUNIO)
      READ(LUNIO,50,IOSTAT=ERR) Species % SPEfile, Species % SPEpath; LNUM = 7  !Species file, path
   50 FORMAT(//////,15X,A12,1X,A80)
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)

!      READ(LUNIO,51,IOSTAT=ERR) FILEE, PATHER; LNUM = LNUM + 1  !Ecotype file name
!      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)

      READ(LUNIO,51,IOSTAT=ERR) Cultivar % CULfile, Cultivar % CULpath; LNUM = LNUM + 2
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)        !Cultivar file, path
   51 FORMAT(/,15X,A12,1X,A80)

!     -----------------------------------------------------------------
!     Read Planting Details Section
      SECTION = '*PLANT'
      CALL FIND(LUNIO, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILEIO, LNUM)
      ELSE
        READ (LUNIO,70) PLANTING % PLTPOP, PLANTING % SDEPTH, PLANTING % SDWTPL !, PLANTING % NFORCING, &
!                        PLANTING % PLANTSIZE, PLANTING % NDOF, PLANTING % PMTYPE
   70   FORMAT (24X,F6.0,24X,2F6.0,24X,I6,F6.0,2I6)
      ENDIF

!PLANTING DETAILS
!        1         2         3         4         5         6         7         8         9        10        11        12
!23456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
!  1989166     -99   2.6   2.6     S     R   53.    0.   5.0  595.  -99. -99.0 -99.0   0.0     2 551.2   459     0
!    yrplt   iemrg      pltpop  plme  plds       azir sdepth      sdage  atemp  plph    nforcing        ndof
!                 plants                  rowspc           sdwtpl                   sprlap   plantsize       pmtype

!     May want to remove PMTYPE and PLANTSIZE
      PLANTING % PMTYPE = 0
      PLANTING % NFORCING = 0
      PLANTING % PLANTSIZE = 0.0
      PLANTING % PMTYPE = 0

!     -----------------------------------------------------------------
!     Read Chemical applications section to get forcing date
      SECTION = '*CHEMI'
      CALL FIND(LUNIO, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      PLANTING % NFORCING = 0
      IF (FOUND .NE. 0) THEN
        DO WHILE (.TRUE.)
          READ (LUNIO,'(3X,I7,1X,A5)', IOSTAT=ERR) ChemYRDOY, ChemType
          IF (ERR .NE. 0) EXIT
          IF (ChemType == 'CH101' .OR. ChemTYPE == 'CH102') THEN
            PLANTING % NFORCING = 2
            PLANTING % ForcingYRDOY = ChemYRDOY
            EXIT
          ENDIF
        ENDDO
      ENDIF

!*CHEMICALS
!   1990350 CH102  1.00 AP006 -99.0   -99  -99

!     -----------------------------------------------------------------
 !     Read crop cultivar coefficients
       SECTION = '*CULTI'
       CALL FIND(LUNIO, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
       IF (FOUND .EQ. 0) THEN
           CALL ERROR(SECTION, 42, FILEIO, LNUM)
       ELSE
         READ (LUNIO,1800,IOSTAT=ERR) &
            Cultivar % VARNO, Cultivar % VRNAME, Cultivar % ECONO,     &
            Cultivar % P1, Cultivar % P2, Cultivar % P3, Cultivar % P4, Cultivar % P5, &
            Cultivar % P6, Cultivar % G2, Cultivar % G3, Cultivar % PHINT
 1800    FORMAT (A6,1X,A16,1X,A6,1X,15F6.0)
!B0066 SC-F153          IB0001   60.0  629.  381. 2640.  400.  60.0  200.  14.0  40.0
         IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)
       ENDIF
      CLOSE(LUNIO)

      RETURN
      END SUBROUTINE Aloha_IpPlant

!=======================================================================

!=======================================================================

      END MODULE Aloha_mod
!======================================================================


text:
! ###################################################################
! Copyright (c) 2013-2020, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

!--------------------------------------------------------------------------
! EMsoft:ECPiomod.f90
!--------------------------------------------------------------------------
!
! MODULE: support routines for ECP output files in .ang (TSL) and .ctf (HKL) formats
!
!> @author Saransh Singh, Carnegie Mellon University
!
!> @date 3/16/17 SS 1.0 original
!--------------------------------------------------------------------------

module ECPiomod

use local
use stringconstants

IMPLICIT NONE

contains

!--------------------------------------------------------------------------
!
! SUBROUTINE:ctfebsd_writeFile
!
!> @author Saransh Singh, Carnegie Mellon University
!
!> @brief Write a *.ctf output file with EBSD data (HKL format)
!
!> @param ecpnl namelist
!> @param ipar  series of integer dimensions
!> @param indexmain indices into the main Euler array
!> @param eulerarray array of Euler angle triplets
!> @param resultmain dot product array
!
!> @date 02/07/15  SS 1.0 original
!> @date 03/10/16 MDG 1.1 moved from program to module and updated [TO BE COMPLETED]
!> @date 06/05/16 MDG 1.2 added reading of xtal file for correct crystallography output; corrected Euler angles for hkl convention
!> @date 06/05/16 MDG 1.3 added sampling step sizes
!> @date 06/25/16 MDG 1.4 added noindex optional keyword
!> @date 07/10/16 MDG 1.5 swapped Error, MAD, and BC columns
!--------------------------------------------------------------------------
recursive subroutine ctfecp_writeFile(ecpnl,ipar,indexmain,eulerarray,resultmain,noindex)
!DEC$ ATTRIBUTES DLLEXPORT :: ctfecp_writeFile

use NameListTypedefs
use HDF5
use HDFsupport
use typedefs
use error

IMPLICIT NONE

type(ECPIndexingNameListType),INTENT(INOUT)         :: ecpnl
!f2py intent(in,out) ::  ecpnl
integer(kind=irg),INTENT(IN)                        :: ipar(10)
integer(kind=irg),INTENT(IN)                        :: indexmain(ipar(1),ipar(2))
real(kind=sgl),INTENT(IN)                           :: eulerarray(3,ipar(4))
real(kind=sgl),INTENT(IN)                           :: resultmain(ipar(1),ipar(2))
logical,INTENT(IN),OPTIONAL                         :: noindex

integer(kind=irg)                                   :: ierr, i, ii, indx, hdferr, SGnum, LaueGroup
character(fnlen)                                    :: ctfname
character                                           :: TAB = CHAR(9)
character(fnlen)                                    :: str1,str2,str3,str4,str5,str6,str7,str8,str9,str10,filename,grname,dataset
real(kind=sgl)                                      :: euler(3)
logical                                             :: stat, readonly, donotuseindexarray
integer(HSIZE_T)                                    :: dims(1)
real(kind=dbl),allocatable                          :: cellparams(:)

type(HDFobjectStackType)                            :: HDF_head_local

donotuseindexarray = .FALSE.
if (present(noindex)) then
  if (noindex.eqv..TRUE.) then
    donotuseindexarray = .TRUE.
  end if
end if

! open the file (overwrite old one if it exists)
ctfname = trim(EMsoft_getEMdatapathname())//trim(ecpnl%ctffile)
ctfname = EMsoft_toNativePath(ctfname)
open(unit=dataunit2,file=trim(ctfname),status='unknown',action='write',iostat=ierr)

write(dataunit2,'(A)') 'Channel Text File'
write(dataunit2,'(A)') 'Prj Test'
write(dataunit2,'(A)') 'Author  '//trim(EMsoft_getUsername())
write(dataunit2,'(A)') 'JobMode  Grid'
write(dataunit2,'(2A,I5)') 'XCells',TAB, ecpnl%totnumexpt
write(dataunit2,'(2A,I5)') 'YCells',TAB, 1
write(dataunit2,'(2A,F6.2)') 'XStep',TAB, 1.0
write(dataunit2,'(2A,F6.2)') 'YStep',TAB, 1.0
write(dataunit2,'(A)') 'AcqE1  0'
write(dataunit2,'(A)') 'AcqE2  0'
write(dataunit2,'(A)') 'AcqE3  0'
write(dataunit2,'(A,A)',ADVANCE='No') 'Euler angles refer to Sample Coordinate system (CS0)!',TAB
str1 = 'Mag  30  Coverage  100  Device  0  KV'
write(str2,'(F4.1)') ecpnl%EkeV
str1 = trim(str1)//TAB//trim(str2)//TAB//'TiltAngle'
write(str2,'(F5.2)') ecpnl%sampletilt
str2 = adjustl(str2)
str1 = trim(str1)//TAB//trim(str2)//TAB//'TiltAxis  0'
write(dataunit2,'(A)') trim(str1)
!write(dataunit2,'(A)')'Mag  30  Coverage  100  Device  0  KV  288.9  TiltAngle  -1  TiltAxis  0'
write(dataunit2,'(A)') 'Phases  1'

! here we need to read the .xtal file and extract the lattice parameters, Laue group and space group numbers
! test to make sure the input file exists and is HDF5 format
filename = trim(EMsoft_getXtalpathname())//trim(ecpnl%MCxtalname)
filename = EMsoft_toNativePath(filename)

stat = .FALSE.

call h5fis_hdf5_f(filename, stat, hdferr)
nullify(HDF_head_local%next)

if (stat) then

! open the xtal file using the default properties.
  readonly = .TRUE.
  hdferr =  HDF_openFile(filename, HDF_head_local, readonly)

! open the namelist group
  grname = 'CrystalData'
  hdferr = HDF_openGroup(grname, HDF_head_local)

! get the spacegroupnumber
dataset = SC_SpaceGroupNumber
  call HDF_readDatasetInteger(dataset, HDF_head_local, hdferr, SGnum)

! get the lattice parameters
dataset = SC_LatticeParameters
  call HDF_readDatasetDoubleArray1D(dataset, dims, HDF_head_local, hdferr, cellparams)

! and close the xtal file
  call HDF_pop(HDF_head_local,.TRUE.)
else
  call FatalError('ctfebsd_writeFile','Error reading xtal file '//trim(filename))
end if

! unit cell size
cellparams(1:3) = cellparams(1:3)*10.0  ! convert to Angstrom
write(str1,'(F8.3)') cellparams(1)
write(str2,'(F8.3)') cellparams(2)
write(str3,'(F8.3)') cellparams(3)
str1 = adjustl(str1)
str2 = adjustl(str2)
str3 = adjustl(str3)
str1 = trim(str1)//';'//trim(str2)//';'//trim(str3)

! unit cell angles
write(str4,'(F8.3)') cellparams(4)
write(str5,'(F8.3)') cellparams(5)
write(str6,'(F8.3)') cellparams(6)
str4 = adjustl(str5)
str5 = adjustl(str5)
str6 = adjustl(str6)
str1 = trim(str1)//TAB//trim(str4)//';'//trim(str5)//';'//trim(str6)

! structure name
str3 = ''
ii = len(trim(ecpnl%MCxtalname))-5
do i=1,ii
  str3(i:i) = ecpnl%MCxtalname(i:i)
end do
str1 = trim(str1)//TAB//trim(str3)

! rotational symmetry group
if (SGnum.ge.221) then
  i = 32
else
  i=1
  do while (SGPG(i).lt.SGnum)
    i = i+1
  end do
end if
str4 = ''
LaueGroup = PGLaueinv(i)
write(str4,'(I2)') LaueGroup
str1 = trim(str1)//TAB//trim(adjustl(str4))

! space group
str2 = ''
write(str2,'(I3)') SGnum
str1 = trim(str1)//TAB//trim(adjustl(str2))

! and now collect them all into a single string
write(dataunit2,'(A)') str1

! write(dataunit2,'(A)'),'3.524;3.524;3.524  90;90;90  Nickel  11  225'

! this is the table header
write(dataunit2,'(A)') 'Phase  X  Y  Bands  Error  Euler1  Euler2  Euler3  MAD  BC  BS'

! go through the entire array and write one line per sampling point
do ii = 1,ipar(3)
    if (donotuseindexarray.eqv..TRUE.) then
      indx = 0
      euler = eulerarray(1:3,ii)
    else
      indx = indexmain(1,ii)
      euler = eulerarray(1:3,indx)
    end if
! changed order of coordinates to conform with ctf standard
    write(str2,'(F12.3)') float(ii-1)
    write(str1,'(F12.3)') 0.0
    write(str3,'(I2)') 10
    write(str8,'(I8)') 0 ! integer zero error; was indx, which is now moved to BC
    write(str5,'(F12.3)') euler(1) - 90.0  ! conversion from TSL to Oxford convention
    write(str6,'(F12.3)') euler(2)
! intercept the hexagonal case, for which we need to subtract 30° from the third Euler angle
    if ((LaueGroup.eq.8).or.(LaueGroup.eq.9)) euler(3) = euler(3) - 30.0
    write(str7,'(F12.3)') euler(3)
    write(str4,'(F12.6)') resultmain(1,ii)   ! this replaces MAD
! the following two parameters need to be modified to contain more meaningful information
    write(str9,'(I8)') indx   ! index into the dictionary list
    write(str10,'(I8)') 255
! Oxford 3D files have four additional integer columns;
! GrainIndex
! GrainRandomColourR
! GrainRandomColourG
! GrainRandomColourB
!
    write(dataunit2,'(A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A,A)')'1',TAB,trim(adjustl(str1)),TAB,&
    trim(adjustl(str2)),TAB,trim(adjustl(str3)),TAB,trim(adjustl(str8)),TAB,trim(adjustl(str5)),&
    TAB,trim(adjustl(str6)),TAB,trim(adjustl(str7)),TAB,trim(adjustl(str4)),TAB,trim(adjustl(str9)),&
    TAB,trim(adjustl(str10))
end do

close(dataunit2,status='keep')

end subroutine ctfecp_writeFile

!--------------------------------------------------------------------------
!
! SUBROUTINE: h5ecp_writeFile
!
!> @author Saransh Singh, Carnegie Mellon University
!
!> @brief write an .h5ecp file. There is no industry standard yet, so we need to make our
!> own standard file. This format is STILL UNDER DEVELOPEMENT and will be CHANGED FREQUENTLY
!
!> @param ecpnl      input name list
!> @param dstr       date string
!> @param tstrb      timestamp
!> @param ipar       integer dimensions of various arrays
!> @param resultmain main result array
!> @param indexmain  main array with index of best nnk matches
!> @param eulerarray euler array of all RFZ sampled points
!> @param progname   name of program
!> @param nmldeffile namelist file
!
!> @date 03/16/17 SS 1.0 original
!--------------------------------------------------------------------------
recursive subroutine h5ecp_writeFile(ecpnl, dstr, tstrb, ipar, resultmain, &
                            indexmain, eulerarray, progname, nmldeffile)
!DEC$ ATTRIBUTES DLLEXPORT :: h5ecp_writeFile

use NameListTypedefs
use io
use constants
use ecpmod
use HDF5
use HDFsupport
use ISO_C_BINDING

IMPLICIT NONE

type(ECPIndexingNameListType),INTENT(INOUT)         :: ecpnl
!f2py intent(in,out) ::  ecpnl
character(11),INTENT(INOUT)                         :: dstr
!f2py intent(in,out) ::  dstr
character(15),INTENT(IN)                            :: tstrb
integer(kind=irg),INTENT(INOUT)                     :: ipar(10)
!f2py intent(in,out) ::  ipar
real(kind=sgl),INTENT(IN)                           :: resultmain(ipar(1),ipar(2))
integer(kind=irg),INTENT(IN)                        :: indexmain(ipar(1),ipar(2))
real(kind=sgl),INTENT(INOUT)                        :: eulerarray(3,ipar(4))
!f2py intent(in,out) ::  eulerarray
character(fnlen),INTENT(IN)                         :: progname
character(fnlen),INTENT(IN)                         :: nmldeffile

character(15)                                       :: tstre
character(fnlen, KIND=c_char),allocatable,TARGET    :: stringarray(:)
integer(kind=irg)                                   :: hdferr, filetype, i, ii, jj,indx, istat, ipar2(6), L
character(fnlen)                                    :: groupname, dataset, h5ecpfile, savefile
logical                                             :: noindex
type(dicttype)                                      :: dict

real(kind=sgl),allocatable                          :: exptCI(:), eangle(:), results(:), avEuler(:,:), &
                                                       lresultmain(:,:), eulers(:,:)
integer(kind=1),allocatable                         :: iPhase(:), valid(:)
integer(kind=irg),allocatable                       :: SEMsignal(:), lindexmain(:,:)

type(HDFobjectStackType)                            :: HDF_head

!=============================================================
! write the output in the format of an h5ecp file
!!!! THIS PART IS STILL UNDER DEVELOPMENT !!!!
! NO STANDARD EXISTS, SO THIS CODE WILL BE CHANGED FREQUENTLY
!=============================================================

allocate(stringarray(1))

nullify(HDF_head%next)
call timestamp(timestring=tstre)

! Create a new file using the default properties.
h5ecpfile = trim(EMsoft_getEMdatapathname())//trim(ecpnl%datafile)
h5ecpfile = EMsoft_toNativePath(h5ecpfile)
hdferr =  HDF_createFile(h5ecpfile, HDF_head)
if (hdferr.ne.0) call HDF_handleError(hdferr,'Error opening file')

call h5ecp_writeInfo(dstr, tstrb, tstre, progname, ecpnl, nmldeffile, HDF_head)

! here we start with the h5ecp-specific stuff
groupname = 'Scan 1'
hdferr = HDF_createGroup(groupname, HDF_head)
if (hdferr.ne.0) call HDF_handleError(hdferr,'Error opening group Scan 1')

groupname = SC_ECP
hdferr = HDF_createGroup(groupname, HDF_head)
if (hdferr.ne.0) call HDF_handleError(hdferr,'Error opening group EBSD')

!=====================================================
!=====================================================
groupname = SC_Data
hdferr = HDF_createGroup(groupname, HDF_head)
if (hdferr.ne.0) call HDF_handleError(hdferr,'Error opening group Data')
!=====================================================
! CI Confidence Index: real(kind=sgl), one for each pattern... we take this
! to be the largest dot product
dataset = SC_CI
  allocate(exptCI(ipar(3)))
  exptCI = resultmain(1,1:ipar(3))
  hdferr = HDF_writeDatasetFloatArray1D(dataset, exptCI, ipar(3), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset CI')

!=====================================================
! Phase: Phase identifier (all zero for now)
dataset = SC_Phase
  allocate(iPhase(ipar(3)),stat=istat)
  iPhase = 0
  hdferr = HDF_writeDatasetInteger1byteArray1D(dataset, iPhase, ipar(3), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset Phase')
  deallocate(iPhase)

!=====================================================
! Euler angles: Phi
dataset = SC_Phi
  allocate(eangle(ipar(3)),stat=istat)
  do ii = 1,ipar(3)
    indx = indexmain(1,ii)
    eangle(ii) = eulerarray(2,indx)
  end do
  eangle = eangle * sngl(cPi)/180.0
  hdferr = HDF_writeDatasetFloatArray1D(dataset, eangle, ipar(3), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset Phi')

!=====================================================
! Euler angles: Phi1
dataset = SC_Phi1
  do ii = 1,ipar(3)
    indx = indexmain(1,ii)
    eangle(ii) = eulerarray(1,indx)
  end do
  eangle = eangle * sngl(cPi)/180.0
  hdferr = HDF_writeDatasetFloatArray1D(dataset, eangle, ipar(3), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset Phi1')

!=====================================================
! Euler angles: Phi2
dataset = SC_Phi2
  do ii = 1,ipar(3)
    indx = indexmain(1,ii)
    eangle(ii) = eulerarray(3,indx)
  end do
  eangle = eangle * sngl(cPi)/180.0
  hdferr = HDF_writeDatasetFloatArray1D(dataset, eangle, ipar(3), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset Phi2')
  deallocate(eangle)

! number of samples in dictionary
dataset = SC_FZcnt
  hdferr = HDF_writeDatasetInteger(dataset, ipar(5), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset FZcnt')

! point group number
dataset = SC_PointGroupNumber
  hdferr = HDF_writeDatasetInteger(dataset, ipar(6), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset PointGroupNumber')

! Ncubochoric
dataset = SC_Ncubochoric
  hdferr = HDF_writeDatasetInteger(dataset, ecpnl%ncubochoric, HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset Ncubochoric')

! write the list of sampled Euler angles
dataset = SC_EulerAngles
  hdferr = HDF_writeDatasetFloatArray2D(dataset, eulerarray, 3, ipar(4), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset EulerAngles')

! number of experimental patterns
dataset = SC_NumExptPatterns
  hdferr = HDF_writeDatasetInteger(dataset, ipar(3), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset NumExptPatterns')

! list of top nnk dot product values
dataset = SC_TopDotProductList
  hdferr = HDF_writeDatasetFloatArray2D(dataset, resultmain, ipar(1), ipar(2), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset TopDotProductList')

! indices of top matches into Euler angle list
dataset = SC_TopMatchIndices
  hdferr = HDF_writeDatasetIntegerArray2D(dataset, indexmain, ipar(1), ipar(2), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset TopMatchIndices')

!=====================================================
! X Position: list of x positions for sampling points; requires knowledge of step size
! from Header
  dataset = 'X Position'
  allocate(results(ipar(3)),stat=istat)
  do jj=1,ipar(3)
      results(jj) = float(jj-1)
  end do
  hdferr = HDF_writeDatasetFloatArray1D(dataset, results, ipar(3), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset X Position')

!=====================================================
! Y Position: list of y positions for sampling points; requires knowledge of step size
! from Header
  dataset = 'Y Position'
  results = 0.0
  hdferr = HDF_writeDatasetFloatArray1D(dataset, results, ipar(3), HDF_head)
  if (hdferr.ne.0) call HDF_handleError(hdferr,'Error writing dataset Y position')
  deallocate(results)

! leave this group
  call HDF_pop(HDF_head)

end subroutine h5ecp_writeFile

!--------------------------------------------------------------------------
!
! SUBROUTINE:h5ecp_writeInfo
!
!> @author Saransh Singh, Carnegie Mellon University
!
!> @brief write general information fields to the h5ecp file, including EMsoft specific fields
!
!> @param dstr date string
!> @param tstrb begin time string
!> @param tstre end time string
!> @param progname name of the calling program
!
!> @date 02/11/16 MDG 1.0 original
!--------------------------------------------------------------------------
recursive subroutine h5ecp_writeInfo(dstr, tstrb, tstre, progname, ecpnl, nmldeffile, HDF_head)
!DEC$ ATTRIBUTES DLLEXPORT :: h5ecp_writeInfo

use NameListTypedefs
use NameListHandlers
use NameListHDFwriters

IMPLICIT NONE

type(ECPIndexingNameListType),INTENT(INOUT)         :: ecpnl
!f2py intent(in,out) ::  ecpnl
character(11),INTENT(INOUT)                         :: dstr
!f2py intent(in,out) ::  dstr
character(15),INTENT(IN)                            :: tstrb
character(15),INTENT(IN)                            :: tstre
character(fnlen),INTENT(IN)                         :: progname
character(fnlen),INTENT(IN)                         :: nmldeffile
type(HDFobjectStackType)                            :: HDF_head

character(fnlen, KIND=c_char),allocatable,TARGET    :: stringarray(:)
character(fnlen)                                    :: groupname, dataset, nmlname, manufacturer
integer(kind=irg)                                   :: hdferr

manufacturer = 'EMECPDictionaryIndexing.f90'
nmlname = 'EMECPDictionaryIndexingNML'

allocate(stringarray(1))

! set the Manufacturer and Version data sets
dataset = SC_Manufacturer
stringarray(1)= trim(manufacturer)
hdferr = HDF_writeDatasetStringArray(dataset, stringarray, 1, HDF_head)

dataset = SC_Version
stringarray(1)= 'EMsoft '//EMsoft_getEMsoftversion()
hdferr = HDF_writeDatasetStringArray(dataset, stringarray, 1, HDF_head)

! add the EMsoft header group
! write the EMheader to the file
groupname = SC_h5EBSD
call HDF_writeEMheader(HDF_head, dstr, tstrb, tstre, progname)

! create a namelist group to write all the namelist files into
groupname = SC_NMLfiles
hdferr = HDF_createGroup(groupname, HDF_head)

! and write the nml file for this program to the HDF5 file
! read the text file and write the array to the file
dataset = trim(nmlname)
hdferr = HDF_writeDatasetTextFile(dataset, nmldeffile, HDF_head)

! leave this group
call HDF_pop(HDF_head)

! create a namelist group to write all the namelist files into
groupname = SC_NMLparameters
hdferr = HDF_createGroup(groupname, HDF_head)
call HDFwriteECPDictionaryIndexingNameList(HDF_head, ecpnl)

! leave this group
call HDF_pop(HDF_head)

end subroutine h5ecp_writeInfo

end module ECPiomod

max_stars_repo_name: maochsendorf/EMsoft

max_stars_repo_licenses: Intel Unlicense MIT-CMU BSD-3-Clause

max_issues_repo_name: maochsendorf/EMsoft

max_issues_repo_licenses: Intel Unlicense MIT-CMU BSD-3-Clause

max_forks_repo_name: maochsendorf/EMsoft

max_forks_repo_licenses: Intel Unlicense MIT-CMU BSD-3-Clause


text:
PROGRAM Random

  INTEGER, PARAMETER :: n = 1000
  INTEGER :: i
  REAL :: array(n), pi, temp, mean = 1.0, sd = 0.5

  pi = 4.0*ATAN(1.0)
  CALL RANDOM_NUMBER(array) ! Uniform distribution

! Now convert to normal distribution
  DO i = 1, n-1, 2
    temp = sd * SQRT(-2.0*LOG(array(i))) * COS(2*pi*array(i+1)) + mean
    array(i+1) = sd * SQRT(-2.0*LOG(array(i))) * SIN(2*pi*array(i+1)) + mean
    array(i) = temp
  END DO

! Check mean and standard deviation
  mean = SUM(array)/n
  sd = SQRT(SUM((array - mean)**2)/n)

  WRITE(*, "(A,F8.6)") "Mean = ", mean
  WRITE(*, "(A,F8.6)") "Standard Deviation = ", sd

END PROGRAM Random

ext: f

max_issues_repo_name: seanwallawalla-forks/RosettaCodeData

max_forks_repo_name: seanwallawalla-forks/RosettaCodeData


text:
SUBROUTINE FDS2LS_DYNA (CHID,NOMASTER,C_S,TBEG,TEND,TINT,COUNTER,VARIABLE,N,N_AVERAGE,BOUNDARY,CURVEID)

! Program to read the Adiabatic Surface Temperature from bndf files for a specific
! location, based on fds2ascii (part of FDS package)
! This program is part of a Coupling Procedure between fire and structural models
!                                                                       - SILVA, JC

! $Id$
! $Revision$
! $Date$

IMPLICIT NONE

INTEGER, PARAMETER :: FB = SELECTED_REAL_KIND(6)
INTEGER :: IERR, NMESHES, NM, NOC, I, J, K, L, IOR_LOOP
INTEGER :: IDUM, IFILE, NSAM, NV, MV
INTEGER :: IOR_INPUT, NPATCH, IJBAR, JKBAR,II
REAL(FB) :: XS, XF, YS, YF, ZS, ZF, TIME

TYPE MESH_TYPE
   REAL(FB), POINTER, DIMENSION(:) :: X,Y,Z
   REAL(FB) :: D1,D2,D3,D4
   INTEGER :: IBAR,JBAR,KBAR,IERR
END TYPE MESH_TYPE

TYPE (MESH_TYPE), DIMENSION(:), ALLOCATABLE, TARGET :: MESH
TYPE (MESH_TYPE), POINTER :: M

INTEGER, ALLOCATABLE, DIMENSION(:) :: IOR,I1B,I2B,J1B,J2B,K1B,K2B
REAL(FB), ALLOCATABLE, DIMENSION(:,:,:,:) :: Q
REAL(FB), ALLOCATABLE, DIMENSION(:,:,:) :: F
LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: ALREADY_USED
CHARACTER(2) :: ANS
CHARACTER(4) :: CHOICE
CHARACTER(256) GRIDFILE,CHID,QFILE,JUNK
CHARACTER(256), DIMENSION(500) :: BNDF_FILE,BNDF_TEXT,BNDF_UNIT
CHARACTER(20), DIMENSION(500) :: BNDF_TYPE
CHARACTER(20) :: BNDF_TYPE_CHOSEN
INTEGER,  DIMENSION(60) :: IB
INTEGER,  DIMENSION(500) :: BNDF_MESH
INTEGER :: RCODE
INTEGER :: NFILES_EXIST
LOGICAL :: EXISTS
INTEGER :: BATCHMODE

INTEGER COUNTER,CURVE,LOCATION,CURVEID
INTEGER V,SIZE,VCOUNT(7),P,POND,VARIABLE,WARNING,IN,VAR
REAL Xa,Ya,Za,C_SIZE,TINT,A,B,C,C_S,NX,NY,NZ
REAL TBEG,TEND,SUM
REAL NOMASTER(COUNTER,4),N(COUNTER,4),BOUNDARY(2*COUNTER,4)
REAL, ALLOCATABLE, DIMENSION(:,:) :: M_AST
REAL, ALLOCATABLE, DIMENSION(:) :: V_TIME,TAST,MED_TAST
CHARACTER(8) OUTFILE
CHARACTER(30) VARIABLE_KIND
REAL MED
INTEGER N_AVERAGE,T_AVERAGE,I_AVERAGE,COMEBACK,NUM_INT_CSIZE(7),H_NULL(3),N_DIR

! Set a few default values
BATCHMODE=0
CURVE=CURVEID

! Check to see if the .smv file exists
GRIDFILE = TRIM(CHID)//'.smv'
INQUIRE(FILE=GRIDFILE,EXIST=EXISTS)
IF (.NOT.EXISTS) THEN
   WRITE(6,*)"*** Fatal error: The file: ",TRIM(GRIDFILE)," does not exist"
   STOP
ENDIF

! Open the .smv file

OPEN(11,FILE=GRIDFILE,STATUS='OLD',FORM='FORMATTED')

! Determine the number of meshes

REWIND(11)

CALL SEARCH('NMESHES',7,11,IERR)
IF (IERR==1) THEN
   WRITE(6,*) ' WARNING: Assuming 1 mesh'
   NMESHES = 1
ELSE
   READ(11,*) NMESHES
ENDIF

ALLOCATE(MESH(NMESHES))

! Get the coordinates of the meshes

REWIND(11)

READ_SMV: DO NM=1,NMESHES
   M=>MESH(NM)
   CALL SEARCH('GRID',4,11,IERR)
   READ(11,*) M%IBAR,M%JBAR,M%KBAR
   ALLOCATE(M%X(0:M%IBAR))
   ALLOCATE(M%Y(0:M%JBAR))
   ALLOCATE(M%Z(0:M%KBAR))

   CALL SEARCH('TRNX',4,11,IERR)
   READ(11,*) NOC
   DO I=1,NOC
      READ(11,*)
      ENDDO
      DO I=0,M%IBAR
      READ(11,*) IDUM,M%X(I)
   ENDDO

   CALL SEARCH('TRNY',4,11,IERR)
   READ(11,*) NOC
   DO I=1,NOC
      READ(11,*)
      ENDDO
      DO J=0,M%JBAR
      READ(11,*) IDUM,M%Y(J)
   ENDDO

   CALL SEARCH('TRNZ',4,11,IERR)
   READ(11,*) NOC
   DO I=1,NOC
      READ(11,*)
      ENDDO
      DO K=0,M%KBAR
      READ(11,*) IDUM,M%Z(K)
   ENDDO

ENDDO READ_SMV

IFILE=3
NSAM=1
ANS='y'
CALL TOUPPER(ANS,ANS)
! **************************************************
BNDF_MESH = 1
REWIND(11)
NFILES_EXIST=0
SEARCH_BNDF: DO I=1,500
   CALL SEARCH2('BNDF',4,'BNDC',4,11,IERR,CHOICE)
   IF (IERR==1) EXIT SEARCH_BNDF
   BACKSPACE(11)
   READ(11,*) JUNK,BNDF_MESH(I)
   READ(11,'(A)') BNDF_FILE(I)
   READ(11,'(A)') BNDF_TEXT(I)
   READ(11,*)
   READ(11,'(A)') BNDF_UNIT(I)
   OPEN(12,FILE=BNDF_FILE(I),FORM='UNFORMATTED',STATUS='OLD', IOSTAT=RCODE)
   CLOSE(12)
   IF (RCODE/=0) CYCLE
   NFILES_EXIST=NFILES_EXIST+1
   IF (CHOICE=='BNDC') BNDF_TYPE(I) = 'CENTERED'
   IF (CHOICE=='BNDF') BNDF_TYPE(I) = 'STAGGERED'
   !IF (BATCHMODE==0) write(6,'(I3,3X,A,I2,A,A)') I,'MESH ',BNDF_MESH(I), ', ',TRIM(BNDF_TEXT(I))
ENDDO SEARCH_BNDF
IF (NFILES_EXIST==0)THEN
   IF(BATCHMODE==0) write(6,*)"There are no boundary files to convert"
   STOP
ENDIF

LOOP_FDS2LS_DYNA:DO P=1,COUNTER
   Xa=NOMASTER(P,2)
   Ya=NOMASTER(P,3)
   Za=NOMASTER(P,4)
   WRITE (OUTFILE,'(g8.0)') INT(NOMASTER(P,1))
   PRINT *, OUTFILE
   C_SIZE=C_S
   LOOP_LOCATION:DO L=1,2
      BOUNDARY(P*2+L-2,1)=P
      IF (L==1) THEN
         LOCATION=1
         NX=N(P,2)
         NY=N(P,3)
         NZ=N(P,4)
      ELSE
         LOCATION=-1
         NX=-N(P,2)
         NY=-N(P,3)
         NZ=-N(P,4)
      ENDIF
      BOUNDARY(P*2+L-2,4)=LOCATION
    !
      XS = Xa-(C_SIZE/2)
      XF = Xa+(C_SIZE/2)
      YS = Ya-(C_SIZE/2)
      YF = Ya+(C_SIZE/2)
      ZS = Za-(C_SIZE/2)
      ZF = Za+(C_SIZE/2)

   VARIABLE_NUMBER: DO VAR=1,VARIABLE
!  500 - Point of the loop in case of the point does not reach a meaning value - SILVA, JC
   500 CONTINUE
   COMEBACK=0
!  SIZE is the lenght of the vectors - SILVA, JC
   SIZE=((TEND-TBEG)/TINT)+1
   ALLOCATE (V_TIME(SIZE))
   ALLOCATE (TAST(SIZE))
   ALLOCATE (M_AST(SIZE,7))
   IF (VAR==1) VCOUNT=0.0
   V_TIME=0.0
   TAST=0.0
   M_AST=0.0

! IN_LOOP is a loop at index file - SILVA, JC
   IN_LOOP: DO IN=VAR,VARIABLE*NMESHES,VARIABLE

!*********
      IOR_LOOPING: DO IOR_LOOP=1,7
         IOR_INPUT=IOR_LOOP-4
         IF (IOR_INPUT==0) CYCLE
         IF (IOR_INPUT==-3 .AND. NZ>=0) CYCLE
         IF (IOR_INPUT==-2 .AND. NY>=0) CYCLE
         IF (IOR_INPUT==-1 .AND. NX>=0) CYCLE
         IF (IOR_INPUT==1 .AND. NX<=0) CYCLE
         IF (IOR_INPUT==2 .AND. NY<=0) CYCLE
         IF (IOR_INPUT==3 .AND. NZ<=0) CYCLE
         NV=1
         MV=1
         IB(MV) = IN
         QFILE = BNDF_FILE(IN)
         OPEN(12+VAR,FILE=QFILE,FORM='UNFORMATTED',STATUS='OLD', IOSTAT=RCODE)
         IF (RCODE/=0) THEN
           CLOSE(12+VAR)
           CYCLE
         ENDIF

         NM = BNDF_MESH(IN)
         M=>MESH(NM)
         ALLOCATE(Q(0:M%IBAR,0:M%JBAR,0:M%KBAR,NV))
         Q = 0.0
         ALLOCATE(ALREADY_USED(0:M%IBAR,0:M%JBAR,0:M%KBAR))
         BNDF_TYPE_CHOSEN = BNDF_TYPE(IN)
         READ(12+VAR)
         READ(12+VAR)
         READ(12+VAR)
         READ(12+VAR) NPATCH
         ALLOCATE(IOR(1:NPATCH))
         ALLOCATE(I1B(1:NPATCH))
         ALLOCATE(I2B(1:NPATCH))
         ALLOCATE(J1B(1:NPATCH))
         ALLOCATE(J2B(1:NPATCH))
         ALLOCATE(K1B(1:NPATCH))
         ALLOCATE(K2B(1:NPATCH))
         DO I=1,NPATCH
            READ(12+VAR) I1B(I),I2B(I),J1B(I),J2B(I),K1B(I),K2B(I),IOR(I)
         ENDDO
         IJBAR = MAX(M%IBAR,M%JBAR)
         JKBAR = MAX(M%JBAR,M%KBAR)
         ALLOCATE(F(0:IJBAR,0:JKBAR,NPATCH))
         READ_BLOOP: DO
            READ(12+VAR,END=199) TIME
            DO II=1,NPATCH
               SELECT CASE(ABS(IOR(II)))
               CASE(1)
                  IF (BNDF_TYPE_CHOSEN=='STAGGERED')READ(12+VAR,END=199) ((F(J,K,II),J=J1B(II),J2B(II)),K=K1B(II),K2B(II))
                  IF (BNDF_TYPE_CHOSEN=='CENTERED') READ(12+VAR,END=199) ((F(J,K,II),J=J1B(II)+1,J2B(II)+1),K=K1B(II)+1,K2B(II)+1)
               CASE(2)
                  IF (BNDF_TYPE_CHOSEN=='STAGGERED')READ(12+VAR,END=199) ((F(I,K,II),I=I1B(II),I2B(II)),K=K1B(II),K2B(II))
                  IF (BNDF_TYPE_CHOSEN=='CENTERED') READ(12+VAR,END=199) ((F(I,K,II),I=I1B(II)+1,I2B(II)+1),K=K1B(II)+1,K2B(II)+1)
               CASE(3)
                  IF (BNDF_TYPE_CHOSEN=='STAGGERED')READ(12+VAR,END=199) ((F(I,J,II),I=I1B(II),I2B(II)),J=J1B(II),J2B(II))
                  IF (BNDF_TYPE_CHOSEN=='CENTERED') READ(12+VAR,END=199) ((F(I,J,II),I=I1B(II)+1,I2B(II)+1),J=J1B(II)+1,J2B(II)+1)
               END SELECT
            ENDDO
            IF (TIME<TBEG) CYCLE READ_BLOOP
            IF (INT(TIME)>TEND) EXIT READ_BLOOP

            ALREADY_USED = .FALSE.
            REC_PATCH: DO II=1,NPATCH
               IF (IOR(II)/=IOR_INPUT) CYCLE REC_PATCH
               IF (M%X(I1B(II))>XF .OR. M%X(I2B(II))<XS) CYCLE REC_PATCH
               IF (M%Y(J1B(II))>YF .OR. M%Y(J2B(II))<YS) CYCLE REC_PATCH
               IF (M%Z(K1B(II))>ZF .OR. M%Z(K2B(II))<ZS) CYCLE REC_PATCH
               SELECT CASE(ABS(IOR(II)))
                  CASE(1)
                     DO K=K1B(II),K2B(II)
                        DO J=J1B(II),J2B(II)
                           IF (.NOT. ALREADY_USED(I1B(II),J,K)) THEN
!                                 Q(I1B(II),J,K,MV) = Q(I1B(II),J,K,MV) + F(J,K,II)
                              Q(I1B(II),J,K,MV) = F(J,K,II)
                              ALREADY_USED(I1B(II),J,K) = .TRUE.
                           ENDIF
                        ENDDO
                     ENDDO
                  CASE(2)
                     DO K=K1B(II),K2B(II)
                        DO I=I1B(II),I2B(II)
                           IF (.NOT. ALREADY_USED(I,J1B(II),K)) THEN
!                               Q(I,J1B(II),K,MV) = Q(I,J1B(II),K,MV) + F(I,K,II)
                              Q(I,J1B(II),K,MV) = F(I,K,II)
                              ALREADY_USED(I,J1B(II),K) = .TRUE.
                           ENDIF
                        ENDDO
                     ENDDO
                  CASE(3)
                     DO J=J1B(II),J2B(II)
                        DO I=I1B(II),I2B(II)
                           IF (.NOT. ALREADY_USED(I,J,K1B(II))) THEN
!                                 Q(I,J,K1B(II),MV) = Q(I,J,K1B(II),MV) + F(I,J,II)
                              Q(I,J,K1B(II),MV) =  F(I,J,II)
                              ALREADY_USED(I,J,K1B(II)) = .TRUE.
                           ENDIF
                        ENDDO
                     ENDDO
               END SELECT
            ENDDO REC_PATCH

            V=(TIME/TINT)+1
            V_TIME(V)=TIME
            PATCHES: DO II=1,NPATCH
               DO K=K1B(II),K2B(II),NSAM
                  DO J=J1B(II),J2B(II),NSAM
                     DO I=I1B(II),I2B(II),NSAM
                        IF (M%X(I)>XF .OR. M%X(I)<XS) CYCLE
                        IF (M%Y(J)>YF .OR. M%Y(J)<YS) CYCLE
                        IF (M%Z(K)>ZF .OR. M%Z(K)<ZS) CYCLE
                        M_AST(V,IOR_LOOP)=M_AST(V,IOR_LOOP)+Q(I,J,K,NV)
                        IF (TRIM(BNDF_TEXT(VAR))==' ADIABATIC SURFACE TEMPERATURE') THEN
                           IF (TIME==TBEG .AND. Q(I,J,K,NV)>0) VCOUNT(IOR_LOOP)=VCOUNT(IOR_LOOP)+1
                        ENDIF
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO PATCHES

            ENDDO READ_BLOOP

            199 CLOSE(12+VAR)

            DEALLOCATE(Q)
            DEALLOCATE(ALREADY_USED)
            DEALLOCATE(IOR)
            DEALLOCATE(I1B)
            DEALLOCATE(I2B)
            DEALLOCATE(J1B)
            DEALLOCATE(J2B)
            DEALLOCATE(K1B)
            DEALLOCATE(K2B)
            DEALLOCATE(F)

         ENDDO IOR_LOOPING

      ENDDO IN_LOOP

   IF (VCOUNT(1)>1) THEN
      DO I=1,V
         M_AST(I,1)=M_AST(I,1)/VCOUNT(1)
      END DO
   END IF
   IF (VCOUNT(2)>1) THEN
      DO I=1,V
         M_AST(I,2)=M_AST(I,2)/VCOUNT(2)
      END DO
   END IF
   IF (VCOUNT(3)>1) THEN
      DO I=1,V
      M_AST(I,3)=M_AST(I,3)/VCOUNT(3)
      END DO
   END IF
   IF (VCOUNT(5)>1) THEN
      DO I=1,V
         M_AST(I,5)=M_AST(I,5)/VCOUNT(5)
      END DO
   END IF
   IF (VCOUNT(6)>1) THEN
      DO I=1,V
         M_AST(I,6)=M_AST(I,6)/VCOUNT(6)
      END DO
   END IF
   IF (VCOUNT(7)>1) THEN
      DO I=1,V
         M_AST(I,7)=M_AST(I,7)/VCOUNT(7)
      END DO
   END IF
!
   VARIABLE_KIND=TRIM(BNDF_TEXT(VAR))
   IF (VARIABLE_KIND==' ADIABATIC SURFACE TEMPERATURE') THEN
!
      IF (NZ>0) THEN
         DO I=1,V
            M_AST(I,1)=0.D0
         END DO
      END IF
      IF (NZ<0) THEN
         DO I=1,V
            M_AST(I,7)=0.D0
         END DO
      END IF
      IF (NZ==0) THEN
          DO I=1,V
             M_AST(I,1)=0.D0
             M_AST(I,7)=0.D0
          END DO
      END IF
!
      IF (NY>0) THEN
         DO I=1,V
            M_AST(I,2)=0.D0
         END DO
      END IF
      IF (NY<0) THEN
         DO I=1,V
            M_AST(I,6)=0.D0
         END DO
      END IF
      IF (NY==0) THEN
         DO I=1,V
            M_AST(I,2)=0.D0
            M_AST(I,6)=0.D0
         END DO
      END IF
!
      IF (NX>0) THEN
         DO I=1,V
            M_AST(I,3)=0.D0
         END DO
      END IF
      IF (NX<0) THEN
         DO I=1,V
            M_AST(I,5)=0.D0
         END DO
      END IF
      IF (NX==0) THEN
         DO I=1,V
            M_AST(I,3)=0.D0
            M_AST(I,5)=0.D0
         END DO
      END IF
!
!
      IF (M_AST(2,7)<19 .AND. M_AST(2,7)>0) THEN
         DO I=1,V
            M_AST(I,7)=20.0
         END DO
      END IF
      IF (M_AST(2,1)<19 .AND. M_AST(2,1)>0) THEN
         DO I=1,V
            M_AST(I,1)=20.0
         END DO
        END IF
      IF (M_AST(2,2)<19 .AND. M_AST(2,2)>0) THEN
         DO I=1,V
            M_AST(I,2)=20.0
        END DO
      END IF
      IF (M_AST(2,6)<19 .AND. M_AST(2,6)>0) THEN
         DO I=1,V
            M_AST(I,6)=20.0
         END DO
      END IF
      IF (M_AST(2,5)<19 .AND. M_AST(2,5)>0) THEN
         DO I=1,V
            M_AST(I,5)=20.0
         END DO
      END IF
      IF (M_AST(2,3)<19 .AND. M_AST(2,3)>0) THEN
         DO I=1,V
            M_AST(I,3)=20.0
         END DO
      END IF
      IF (M_AST(1,7)<20 .AND. M_AST(1,7)>0) THEN
         M_AST(1,7)=20.0
      END IF
      IF (M_AST(1,1)<20 .AND. M_AST(1,1)>0) THEN
         M_AST(1,1)=20.0
      END IF
      IF (M_AST(1,2)<20 .AND. M_AST(1,2)>0) THEN
         M_AST(1,2)=20.0
      END IF
      IF (M_AST(1,6)<20 .AND. M_AST(1,6)>0) THEN
         M_AST(1,6)=20.0
      END IF
      IF (M_AST(1,5)<20 .AND. M_AST(1,5)>0) THEN
         M_AST(1,5)=20.0
      END IF
      IF (M_AST(1,3)<20 .AND. M_AST(1,3)>0) THEN
         M_AST(1,3)=20.0
      END IF
!
      IF (NZ<0) THEN
         IF (M_AST(1,1)==0) THEN
            ZS = ZS-(0.05*(ZF-ZS))
            ZF = ZF+(0.05*(ZF-ZS))
            COMEBACK=1
            NUM_INT_CSIZE(1)=NUM_INT_CSIZE(1)+1
         ENDIF
      END IF
!
      IF (NY<0) THEN
         IF (M_AST(1,2)==0) THEN
            YS = YS-(0.05*(YF-YS))
            YF = YF+(0.05*(YF-YS))
            COMEBACK=1
            NUM_INT_CSIZE(2)=NUM_INT_CSIZE(2)+1
         ENDIF
      END IF
!
      IF (NX<0) THEN
         IF (M_AST(1,3)==0) THEN
            XS = XS-(0.05*(XF-XS))
            XF = XF+(0.05*(XF-XS))
            COMEBACK=1
            NUM_INT_CSIZE(3)=NUM_INT_CSIZE(3)+1
         ENDIF
      END IF
!
      IF (NZ>0) THEN
         IF (M_AST(1,7)==0) THEN
            ZS = ZS-(0.05*(ZF-ZS))
            ZF = ZF+(0.05*(ZF-ZS))
            COMEBACK=1
            NUM_INT_CSIZE(7)=NUM_INT_CSIZE(7)+1
         ENDIF
      END IF
!
      IF (NY>0) THEN
         IF (M_AST(1,6)==0) THEN
            YS = YS-(0.05*(YF-YS))
            YF = YF+(0.05*(YF-YS))
            COMEBACK=1
            NUM_INT_CSIZE(6)=NUM_INT_CSIZE(6)+1
         ENDIF
      END IF
!
      IF (NX>0) THEN
         IF (M_AST(1,5)==0) THEN
            XS = XS-(0.05*(XF-XS))
            XF = XF+(0.05*(XF-XS))
            COMEBACK=1
            NUM_INT_CSIZE(5)=NUM_INT_CSIZE(5)+1
         ENDIF
      END IF
!
      IF (MAX(NUM_INT_CSIZE(1),NUM_INT_CSIZE(2),NUM_INT_CSIZE(3),NUM_INT_CSIZE(5),NUM_INT_CSIZE(6),NUM_INT_CSIZE(7))>=5) THEN
         XS = XS-(0.05*(XF-XS))
         XF = XF+(0.05*(XF-XS))
         YS = YS-(0.05*(YF-YS))
         YF = YF+(0.05*(YF-YS))
         ZS = ZS-(0.05*(ZF-ZS))
         ZF = ZF+(0.05*(ZF-ZS))
      ENDIF
!
      IF (COMEBACK==1) THEN
         DEALLOCATE (V_TIME)
         DEALLOCATE (TAST)
         DEALLOCATE (M_AST)
         GOTO 500
      ENDIF
!
      C=SQRT((NX**2)+(NY**2)+(NZ**2))
!
      IF (NZ<0 .AND. NY<0 .AND. NX<0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(-M_AST(I,2)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,2)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY<0 .AND. NX>0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(-M_AST(I,2)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,2)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY>0 .AND. NX<0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(M_AST(I,6)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,6)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY>0 .AND. NX>0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(M_AST(I,6)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,6)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY<0 .AND. NX==0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(-M_AST(I,2)*NY))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,2)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY==0 .AND. NX<0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY==0 .AND. NX>0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY>0 .AND. NX==0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(M_AST(I,6)*NY))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,6)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY==0 .AND. NX==0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ))
            B=SQRT((M_AST(I,1)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY<0 .AND. NX<0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(-M_AST(I,2)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,2)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY<0 .AND. NX>0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(-M_AST(I,2)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,2)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY>0 .AND. NX<0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(M_AST(I,6)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,6)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY>0 .AND. NX>0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(M_AST(I,6)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,6)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY<0 .AND. NX==0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(-M_AST(I,2)*NY))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,2)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY==0 .AND. NX<0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY==0 .AND. NX>0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY>0 .AND. NX==0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(M_AST(I,6)*NY))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,6)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY==0 .AND. NX==0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ))
            B=SQRT((M_AST(I,7)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY<0 .AND. NX<0) THEN
         DO I=1,V
            A=((-M_AST(I,2)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,2)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY<0 .AND. NX>0) THEN
         DO I=1,V
            A=((-M_AST(I,2)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,2)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY<0 .AND. NX==0) THEN
         DO I=1,V
            A=((-M_AST(I,2)*NY))
            B=SQRT((M_AST(I,2)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY>0 .AND. NX<0) THEN
         DO I=1,V
            A=((M_AST(I,6)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,6)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY>0 .AND. NX>0) THEN
         DO I=1,V
            A=((M_AST(I,6)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,6)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY>0 .AND. NX==0) THEN
         DO I=1,V
            A=((M_AST(I,6)*NY))
            B=SQRT((M_AST(I,6)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY==0 .AND. NX<0) THEN
         DO I=1,V
            A=((-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY==0 .AND. NX>0) THEN
         DO I=1,V
            A=((M_AST(I,5)*NX))
            B=SQRT((M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
!********************************
      IF (TAST(1)>0) THEN
         TAST(1)=20
      ELSE
         XS = XS-(0.05*(XF-XS))
         XF = XF+(0.05*(XF-XS))
         YS = YS-(0.05*(YF-YS))
         YF = YF+(0.05*(YF-YS))
         ZS = ZS-(0.05*(ZF-ZS))
         ZF = ZF+(0.05*(ZF-ZS))
         DEALLOCATE (V_TIME)
         DEALLOCATE (TAST)
         DEALLOCATE (M_AST)
         GOTO 500
      END IF
   !
   END IF
!**************************************************************
   IF (VARIABLE_KIND==' HEAT TRANSFER COEFFICIENT    ') THEN
      IF (NZ>0) THEN
         DO I=1,V
            M_AST(I,1)=0.D0
         END DO
      END IF
      IF (NZ<0) THEN
         DO I=1,V
            M_AST(I,7)=0.D0
         END DO
      END IF
      IF (NZ==0) THEN
         DO I=1,V
            M_AST(I,1)=0.D0
            M_AST(I,7)=0.D0
         END DO
      END IF
!
      IF (NY>0) THEN
         DO I=1,V
            M_AST(I,2)=0.D0
         END DO
      END IF
      IF (NY<0) THEN
         DO I=1,V
            M_AST(I,6)=0.D0
         END DO
      END IF
      IF (NY==0) THEN
         DO I=1,V
            M_AST(I,2)=0.D0
            M_AST(I,6)=0.D0
         END DO
      END IF
!
      IF (NX>0) THEN
         DO I=1,V
            M_AST(I,3)=0.D0
         END DO
      END IF
      IF (NX<0) THEN
         DO I=1,V
            M_AST(I,5)=0.D0
         END DO
      END IF
      IF (NX==0) THEN
         DO I=1,V
            M_AST(I,3)=0.D0
            M_AST(I,5)=0.D0
         END DO
      END IF
!
      H_NULL=0.d0
      IF (NZ<0) THEN
         SUM=0.d0
         DO I=1,V
            SUM=SUM+ABS(M_AST(I,1))
         ENDDO
         IF (SUM==0) H_NULL(3)=1
      END IF
!
      IF (NY<0) THEN
         SUM=0.d0
         DO I=1,V
            SUM=SUM+ABS(M_AST(I,2))
         ENDDO
         IF (SUM==0) H_NULL(2)=1
      END IF
!
      IF (NX<0) THEN
         SUM=0.d0
         DO I=1,V
            SUM=SUM+ABS(M_AST(I,3))
         ENDDO
         IF (SUM==0) H_NULL(1)=1
      END IF
!
      IF (NZ>0) THEN
         SUM=0.d0
         DO I=1,V
            SUM=SUM+ABS(M_AST(I,7))
         ENDDO
         IF (SUM==0) H_NULL(3)=1
      END IF
!
      IF (NY>0) THEN
         SUM=0.d0
         DO I=1,V
            SUM=SUM+ABS(M_AST(I,6))
         ENDDO
         IF (SUM==0) H_NULL(2)=1
      END IF
!
      IF (NX>0) THEN
         SUM=0.d0
         DO I=1,V
            SUM=SUM+ABS(M_AST(I,5))
         ENDDO
         IF (SUM==0) H_NULL(1)=1
      END IF
!
      IF (NZ/=0 .AND. H_NULL(3)==1) COMEBACK=COMEBACK+1
      IF (NY/=0 .AND. H_NULL(2)==1) COMEBACK=COMEBACK+1
      IF (NX/=0 .AND. H_NULL(1)==1) COMEBACK=COMEBACK+1
      IF (COMEBACK==N_DIR) THEN
         DO I=1,V
            TAST(I)=0.d0
         END DO
         GOTO 600
      ENDIF
!
      C=SQRT((NX**2)+(NY**2)+(NZ**2))
!
      IF (NZ<0 .AND. NY<0 .AND. NX<0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(-M_AST(I,2)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,2)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY<0 .AND. NX>0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(-M_AST(I,2)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,2)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY>0 .AND. NX<0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(M_AST(I,6)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,6)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY>0 .AND. NX>0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(M_AST(I,6)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,6)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY<0 .AND. NX==0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(-M_AST(I,2)*NY))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,2)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY==0 .AND. NX<0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY==0 .AND. NX>0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY>0 .AND. NX==0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ)+(M_AST(I,6)*NY))
            B=SQRT((M_AST(I,1)**2)+(M_AST(I,6)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ<0 .AND. NY==0 .AND. NX==0) THEN
         DO I=1,V
            A=((-M_AST(I,1)*NZ))
            B=SQRT((M_AST(I,1)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY<0 .AND. NX<0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(-M_AST(I,2)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,2)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY<0 .AND. NX>0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(-M_AST(I,2)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,2)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY>0 .AND. NX<0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(M_AST(I,6)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,6)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY>0 .AND. NX>0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(M_AST(I,6)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,6)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY<0 .AND. NX==0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(-M_AST(I,2)*NY))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,2)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY==0 .AND. NX<0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY==0 .AND. NX>0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY>0 .AND. NX==0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ)+(M_AST(I,6)*NY))
            B=SQRT((M_AST(I,7)**2)+(M_AST(I,6)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ>0 .AND. NY==0 .AND. NX==0) THEN
         DO I=1,V
            A=((M_AST(I,7)*NZ))
            B=SQRT((M_AST(I,7)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY<0 .AND. NX<0) THEN
         DO I=1,V
            A=((-M_AST(I,2)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,2)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY<0 .AND. NX>0) THEN
         DO I=1,V
            A=((-M_AST(I,2)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,2)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY<0 .AND. NX==0) THEN
         DO I=1,V
            A=((-M_AST(I,2)*NY))
            B=SQRT((M_AST(I,2)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY>0 .AND. NX<0) THEN
         DO I=1,V
            A=((M_AST(I,6)*NY)+(-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,6)**2)+(M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY>0 .AND. NX>0) THEN
         DO I=1,V
            A=((M_AST(I,6)*NY)+(M_AST(I,5)*NX))
            B=SQRT((M_AST(I,6)**2)+(M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY>0 .AND. NX==0) THEN
         DO I=1,V
            A=((M_AST(I,6)*NY))
            B=SQRT((M_AST(I,6)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY==0 .AND. NX<0) THEN
         DO I=1,V
            A=((-M_AST(I,3)*NX))
            B=SQRT((M_AST(I,3)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
      IF (NZ==0 .AND. NY==0 .AND. NX>0) THEN
         DO I=1,V
            A=((M_AST(I,5)*NX))
            B=SQRT((M_AST(I,5)**2))
            TAST(I)=(A/(B*C))*B
         END DO
      END IF
!********************************
      IF (TAST(2)>=0 .AND. TAST(2)<1000) THEN
         TAST(1)=0.0
!      ELSE
!         XS = XS-(0.05*(XF-XS))
!         XF = XF+(0.05*(XF-XS))
!         YS = YS-(0.05*(YF-YS))
!         YF = YF+(0.05*(YF-YS))
!         ZS = ZS-(0.05*(ZF-ZS))
!         ZF = ZF+(0.05*(ZF-ZS))
!         DEALLOCATE (V_TIME)
!         DEALLOCATE (TAST)
!         DEALLOCATE (M_AST)
!         GOTO 500
      END IF
!
   END IF
!****************
   600 CONTINUE
   WRITE (70,'(A)') "*DEFINE_CURVE"
   WRITE (70,'(I8,A)') CURVE, ", 0,1.0, 1.0, , , "
   IF (VARIABLE_KIND==' ADIABATIC SURFACE TEMPERATURE') THEN
      DO I=1,V-1
         WRITE (70,'(ES10.3,A,ES10.3)') V_TIME(I), ",", (TAST(I)+273.15)
      ENDDO
   ELSEIF (VARIABLE_KIND==' HEAT TRANSFER COEFFICIENT    ') THEN
      DO I=1,V-1
         WRITE (70,'(ES10.3,A,ES10.3)') V_TIME(I), ",", TAST(I)
      ENDDO
   ENDIF
!**********************
!*** Set an average value for a steady simulation (last N_AVERAGE results)
   IF (N_AVERAGE==0) THEN
      CONTINUE
   ELSE IF (T_AVERAGE==0) THEN
      MED=0.0
      DO I=0,N_AVERAGE-1
         MED=MED+TAST(V-I)
      ENDDO
      MED=MED/(N_AVERAGE)
      IF (VARIABLE_KIND==' ADIABATIC SURFACE TEMPERATURE') THEN
         WRITE (70,'(ES10.3,A,ES10.3)') V_TIME(V)+TINT, ",", (MED+273.15)
         WRITE (70,'(ES10.3,A,ES10.3)') 18000.0, ",", (MED+273.15)
      ENDIF
      IF (VARIABLE_KIND==' HEAT TRANSFER COEFFICIENT    ') THEN
         WRITE (70,'(ES10.3,A,ES10.3)') V_TIME(V)+TINT, ",", MED
         WRITE (70,'(ES10.3,A,ES10.3)') 18000.0, ",", MED
      ENDIF
   ELSE IF (T_AVERAGE/=0) THEN
      MED=0.0
      DO I=0,N_AVERAGE-1
         MED=MED+MED_TAST(((V-1)/I_AVERAGE)-I)
      ENDDO
         MED=MED/(N_AVERAGE)
      IF (VARIABLE_KIND==' ADIABATIC SURFACE TEMPERATURE') THEN
         WRITE (70,'(ES10.3,A,ES10.3)') V_TIME(V)+T_AVERAGE, ",", (MED+273.15)
         WRITE (70,'(ES10.3,A,ES10.3)') 18000.0, ",", (MED+273.15)
      ENDIF
      IF (VARIABLE_KIND==' HEAT TRANSFER COEFFICIENT    ') THEN
         WRITE (70,'(ES10.3,A,ES10.3)') V_TIME(V)+T_AVERAGE, ",", (MED+273.15)
         WRITE (70,'(ES10.3,A,ES10.3)') 18000.0, ",", (MED+273.15)
      ENDIF
      IF (VARIABLE_KIND==' NET HEAT FLUX                ') THEN
         WRITE (70,'(ES10.3,A,ES10.3)') V_TIME(V)+T_AVERAGE, ",", (MED+273.15)
         WRITE (70,'(ES10.3,A,ES10.3)') 18000.0, ",", (MED+273.15)
      ENDIF
   ENDIF
!
   IF (VARIABLE_KIND==' ADIABATIC SURFACE TEMPERATURE') THEN
      BOUNDARY(P*2+L-2,2)=CURVE
   ELSEIF (VARIABLE_KIND==' HEAT TRANSFER COEFFICIENT    ') THEN
      BOUNDARY(P*2+L-2,3)=CURVE
   ENDIF
   CURVE=CURVE+1
!**********************
   IF (VARIABLE_KIND==' ADIABATIC SURFACE TEMPERATURE') THEN
      WRITE (6,'(A, F8.3, A, F8.3, A, F8.3)') 'Interface point    ', Xa, '        ', Ya, &
      '        ', Za
      WRITE (6,'(A, F8.3, A, F8.3, A, F8.3)') 'Cell dimension     ', (XF-XS), '        ', (YF-YS), &
      '        ', (ZF-ZS)
      WRITE (6,'(A, F8.3, F8.3, F8.3, F8.3, F8.3, F8.3)') 'AST Results   ', M_AST(1,3), M_AST(1,5), M_AST(1,2), &
      M_AST(1,6), M_AST(1,1), M_AST(1,7)
      IF (VARIABLE==1) WRITE (6,'(A, F8.5, A, F8.5, A, F8.5)') 'Normal_Vector      ',NX, '        ', NY, '        ', NZ
   END IF
   IF (VARIABLE_KIND==' HEAT TRANSFER COEFFICIENT    ') THEN
      WRITE (6,'(A, F8.3, A, F8.3, A, F8.3)') 'Cell dimension     ', (XF-XS), '        ', (YF-YS), &
      '        ', (ZF-ZS)
      WRITE (6,'(A, F8.3, F8.3, F8.3, F8.3, F8.3, F8.3)') ' h  Results   ', M_AST(10,3), M_AST(10,5), M_AST(10,2), &
      M_AST(10,6), M_AST(10,1), M_AST(10,7)
      IF (VARIABLE==2) WRITE (6,'(A, F8.5, A, F8.5, A, F8.5)') 'Normal_Vector      ',NX, '        ', NY, '        ', NZ
   END IF
   DEALLOCATE (V_TIME)
   DEALLOCATE (TAST)
   DEALLOCATE (M_AST)
   IF (T_AVERAGE/=0) DEALLOCATE (MED_TAST)
    !CLOSE (100+VAR)
   100 CONTINUE
   ENDDO VARIABLE_NUMBER
   ENDDO LOOP_LOCATION
ENDDO LOOP_FDS2LS_DYNA
RETURN
END SUBROUTINE FDS2LS_DYNA

max_stars_repo_name: ajnavarro/language-dataset

max_issues_repo_name: ajnavarro/language-dataset

max_forks_repo_name: ajnavarro/language-dataset