! perfiles.f90
! module in which all save to .per file routines are held
! contains: SavePER, etc
! 	the power of SavePerSilent is now available through options on SavePer

module SavePerFiles

use FileNames

implicit none

contains

!*******************************************************************************
! save .per files
! call with AllData, or with Monthly+Seasonal+Annual

subroutine SavePer (CallFile, YearAD, CallVariCode, AllData,  &
		    Monthly, Seasonal, Annual, CallLineFormat, NoResponse, &
		    ExtraHeads,ScenHeads,CallPoliUnitName,CallVariableName)

real, pointer,dimension (:,:),optional	:: Monthly, Seasonal,AllData
real, pointer,dimension (:), optional	:: Annual

integer, pointer, dimension (:) 	:: YearAD

character (len=20), intent(in),optional	:: CallLineFormat	! specify if you don't want the auto hi-prec
character (len=20), intent(in),optional :: CallPoliUnitName	! reg-name
character (len=80), intent(in),optional :: CallVariableName	! variable
character (len=80), intent(in)		:: CallFile		! can be blank
character(len=158),pointer,dimension(:) :: Headers

integer, intent(in)			:: CallVariCode 	! can be MissVal, -1=min,0=mean,1=max,2=sum
integer, intent(in), optional		:: NoResponse   	! ensures no run-time inputs are required
integer, intent(in), optional		:: ExtraHeads   	! writes extra header lines if =1
integer, intent(in), optional		:: ScenHeads   		! writes scen header lines if =1

real, parameter :: MissVal = -999.0

integer :: NoSave, ReadStatus, AllocStat
integer :: YearN, MonthN, SeasonN, HeaderN
integer :: XYear, XMonth, XSeason, XHeader, XPeriod
integer :: VariCode, QSepAll

character (len=80) :: SaveFile, NameVa
character (len=20) :: LineFormat, NamePU
character (len= 4) :: Suffix

!***************************************
! check sizes

NoSave = 0
Suffix = ".per"

if (present(Monthly).AND.present(Seasonal).AND.present(Annual)) then
  YearN   = size (Monthly,1)
  MonthN  = size (Monthly,2)
  SeasonN = size (Seasonal,2)
  if (size(YearAD).NE.YearN.OR.size(Seasonal,1).NE.YearN.OR.size(Annual).NE.YearN &
				.OR.MonthN.NE.12.OR.SeasonN.NE.4) then
    print*, "  > SavePER: No save. Weird number of months or years."
    NoSave = 1
  else
    QSepAll = 1
  end if
else if (present(AllData)) then
  YearN = size (AllData,1)
  if (size(AllData,2).NE.17) then
    print*, "  > SavePER: No save. Weird number of seasons."
    NoSave = 1
  else
    QSepAll = 2
  end if 
else
  print*, "  > ##### ERROR : SavePer: No input data specified #####"
end if

if (CallVariCode.LT.-1.OR.CallVariCode.GT.2) then
  if (present(NoResponse)) then
    print*, "  > ##### SavePER: No save. Clash between spec and data needs. #####"
    NoSave = 1
  else
    print*, "  > Enter the variable (-1=min,0=mean,1=max,2=sum): "
    do
		read (*,*,iostat=ReadStatus), VariCode
		if (ReadStatus.LE.0.AND.VariCode.GE.-1.AND.VariCode.LE.2) exit
    end do
  end if
else
  VariCode = CallVariCode
end if

if (present(CallLineFormat)) then
  LineFormat = trim(adjustl(CallLineFormat))
else
  if (present(NoResponse)) then
    LineFormat = '(i5,12f9.3,5f9.3)'
  else
    call MakePERLineFormat (LineFormat)
  end if
end if

if      (present(ExtraHeads)) then
  HeaderN=20
else if (present(ScenHeads)) then
  HeaderN=15
else
  HeaderN= 4
end if
allocate (Headers(HeaderN),stat=AllocStat)
if (AllocStat.NE.0) print*, "  > ##### ERROR: SavePER: allocation failure #####"

if (present(ExtraHeads).OR.present(ScenHeads)) then
  if (present(CallPoliUnitName)) then
    NamePU = CallPoliUnitName
  else
    NamePU = " "
  end if
  
  if (present(CallVariableName)) then
    NameVa = CallVariableName
  else
    NameVa = " "
  end if
  
  if (present(ExtraHeads)) then
    call MakePERHeaders (VariCode,LineFormat,YearAD,Headers,&
  			ManyHeads=ExtraHeads,PoliUnitName=NamePU,VariableName=NameVa)
  else 
    call MakePERHeaders (VariCode,LineFormat,YearAD,Headers,&
  			ScenHeads=ScenHeads, PoliUnitName=NamePU,VariableName=NameVa)
  end if
else
  call MakePERHeaders (VariCode,LineFormat,YearAD,Headers)
end if

!***************************************
! save data to file

if (NoSave.EQ.0) then
  SaveFile = SavePath (CallFile,Suffix)

  open (2, file=SaveFile, status="replace", access="sequential", form="formatted", action="write")
  
  do XHeader = 1, HeaderN
    write (2,"(a158)"), Headers(XHeader)
  end do 
  
  do XYear = 1, YearN
    if (QSepAll.EQ.1) write (2,LineFormat), YearAD(XYear), (Monthly(XYear,XMonth), XMonth=1,12), &
      			(Seasonal(XYear,XSeason), XSeason=1,4), Annual(XYear)
    if (QSepAll.EQ.2) write (2,LineFormat), YearAD(XYear), (AllData(XYear,XPeriod), XPeriod=1,17)
  end do
  
  close (2)
end if

deallocate (Headers,stat=AllocStat)
if (AllocStat.NE.0) print*, "  > ##### ERROR: SavePER: Deallocation failure #####"

end subroutine SavePer

!*******************************************************************************
! make line format for save to .per

subroutine MakePerLineFormat (LineFormat)

character (len=20), intent(out) :: LineFormat

integer :: ReadStatus

character (len=1) :: DeciTxtShort

LineFormat = ""

print*, "  > Enter the no. of decimal places to save (1...3): "
print*, "  >    ...for MONTHS: "
do
	read (*,*,iostat=ReadStatus), DeciTxtShort
	if (ReadStatus.GT.0) print*, "  > Not a string. Try again."
	if (DeciTxtShort.EQ."") print*, "  > A null string. Try again."
	if (ReadStatus.LE.0.AND.DeciTxtShort.NE."") exit
end do
      
LineFormat = '(i5,12f9.' // DeciTxtShort // ',5f9.'

print*, "  >    ...for SEASONS,ANNUALS: "
do
	read (*,*,iostat=ReadStatus), DeciTxtShort
	if (ReadStatus.GT.0) print*, "  > Not a string. Try again."
	if (DeciTxtShort.EQ."") print*, "  > A null string. Try again."
	if (ReadStatus.LE.0.AND.DeciTxtShort.NE."") exit
end do
      
LineFormat = LineFormat(1:15) // DeciTxtShort // ')'

end subroutine MakePerLineFormat

!*******************************************************************************
! make headers for .per data files

subroutine MakePerHeaders (VariCode,LineFormat,YearAD,Headers, &
		ManyHeads,ScenHeads,PoliUnitName,VariableName)

integer, dimension (:), pointer :: YearAD	

character (len=158), pointer, dimension (:) :: Headers

integer, intent (in), optional 	:: ManyHeads		! writes extra headers if =1
integer, intent (in), optional 	:: ScenHeads		! writes scen headers if =1
integer, intent (in) 		:: VariCode		! -1=min, 0=mean, 1=max, 2=sum

character (len=20),intent(in) 		:: LineFormat
character (len=20),intent(in), optional :: PoliUnitName
character (len=80),intent(in), optional :: VariableName

real, parameter :: MissVal = -999.0

integer :: AllocStat
integer :: YearN,HeaderN

character (len=12) :: Date, Time
character (len=8)  :: TimePeriod, Variable 
character (len=4 ) :: Year, Year0, Year1
character (len=2 ) :: Month, Day, Hour, Minute

!***************************************

TimePeriod= "Periodic" ; Variable   = "" ; Year0      = ""
YearN      = size (YearAD) ; HeaderN=size(Headers)

if (VariCode.EQ.-1) Variable = "Min"
if (VariCode.EQ. 0) Variable = "Mean"
if (VariCode.EQ. 1) Variable = "Max"
if (VariCode.EQ. 2) Variable = "Sum"

if (YearAD(1).GT.0.AND.YearAD(YearN).GE.YearAD(1)) then
  open   (1,status="scratch")  
  write  (1,"(2i4)"), YearAD(1), YearAD(YearN)  
  rewind (1)
  read   (1,"(2a4)"), Year0, Year1
  close  (1)
else
  print*, "  > ##### ERROR: MakePerHeaders: weird period #####"
end if

call date_and_time (Date, Time)
Year  = Date (1:4) ; Month = Date (5:6) ; Day   = Date (7:8)
Hour  = Time (1:2) ; Minute= Time (3:4)

if (present(ManyHeads)) then
 if (ManyHeads.EQ.1) then
  Headers = " "
  
  Headers ( 1) = "Monthly, seasonal, and annual climate observations averaged for political units."
  if (present(PoliUnitName)) Headers ( 2) = "Political unit = " // trim(adjustl(PoliUnitName))
  if (present(VariableName)) Headers ( 3) = "Variable = " // trim(adjustl(VariableName))
  Headers ( 4) = "Period = " // Year0 // "-" // Year1 // ": missing value = -999.0 : format = " // &
  			trim(adjustl(LineFormat))
  Headers ( 5) = "*"
  Headers ( 6) = "File created and owned by Dr. Tim Mitchell (t.mitchell@uea.ac.uk). Full rights retained."
  Headers ( 7) = "Created at the Tyndall Centre (www.tyndall.ac.uk) on   " &
			// Day // "." // Month // "." // Year // " at " // Hour // ":" // Minute 
  Headers ( 8) = "The data in this file may be used for non-commercial scientific and educational purposes."
  Headers ( 9) = "Where research using this data is published, the source should be acknowledged as: "
  Headers (10) = "  Mitchell,T.D. et al 2003: A comprehensive set of climate scenarios for Europe"
  Headers (11) = "  and the globe. In prep."
  Headers (12) = "Method: The country aggregation is based on the CRU TS 2.0 gridded data-set."
  Headers (13) = "  The gridded data were aggregated into countries using political boundaries; see:" 
  Headers (14) = "  Mitchell,Hulme,New,2001: Climate data for political areas. Area 34:109-112"
  Headers (15) = "For more information see http://www.cru.uea.ac.uk/~timm/"
  Headers (16) = "Disclaimer: No responsibility is taken for the accuracy of these data."
  Headers (17) = "Disclaimer: No political statement is implied in the selection of these political units."
  Headers (18) = "*"
  Headers (19) = "*"
  if (LineFormat(8:8).EQ.'8') then
    Headers (20) = ' YEAR     JAN     FEB     MAR     APR     MAY     JUN     JUL     ' // &
       			'AUG     SEP     OCT     NOV     DEC     MAM     JJA     SON     DJF     ANN'
  else
    Headers (20) = ' YEAR      JAN      FEB      MAR      APR      MAY      JUN      JUL      ' // &
       			'AUG      SEP      OCT      NOV      DEC      MAM      JJA      SON      DJF      ANN'
  end if
 end if
else if (present(ScenHeads)) then
 Headers = "*"
  
 Headers (1) = "A Tyndall Centre file (www.tyndall.ac.uk) created on     " &
		// Day // "." // Month // "." // Year // " at " // Hour // ":" // Minute &
		// " by Dr. Tim Mitchell"
 Headers (2) = "Scenario .per data; time,var codes: " // TimePeriod // " " // Variable
 Headers (3) = "Scenarios" // Year0 // "-" // Year1 // ": missing value = -999.0 : format = " // LineFormat
 Headers (5) = "This is part of the TYN CY 3.0 data-set. See http://www.cru.uea.ac.uk/~timm/"
 if (present(PoliUnitName)) Headers ( 6) = "Political unit = " // trim(adjustl(PoliUnitName))
 if (present(VariableName)) Headers ( 7) = "Variable = " // trim(adjustl(VariableName))
 Headers (9) = "The scenario indices each represent a GCM/SRES combination:"
 Headers(10) = "  CGCM2: 1=A1FI, 2=A2, 3=B2, 4=B1"
 Headers(11) = " CSIRO2: 5=A1FI, 6=A2, 7=B2, 8=B1"
 Headers(12) = " HadCM3: 9=A1FI,10=A2,11=B2,12=B1"
 Headers(13) = "    PCM:13=A1FI,14=A2,15=B2,16=B1"
 
 if (LineFormat(8:8).EQ.'8') then
    Headers (15) = ' SCEN     JAN     FEB     MAR     APR     MAY     JUN     JUL     ' // &
       			'AUG     SEP     OCT     NOV     DEC     MAM     JJA     SON     DJF     ANN'
 else
    Headers (15) = ' SCEN      JAN      FEB      MAR      APR      MAY      JUN      JUL      ' // &
       			'AUG      SEP      OCT      NOV      DEC      MAM      JJA      SON      DJF      ANN'
 end if
else
 Headers = ""
  
 Headers (1) = "Tyndall Centre file (www.tyndall.ac.uk) created on     " &
		// Day // "." // Month // "." // Year // " at " // Hour // ":" // Minute &
		// " by Dr. Tim Mitchell"
 Headers (2) = "Periodic .per data; time,var codes: " // TimePeriod // " " // Variable
 Headers (3) = "Period = " // Year0 // "-" // Year1 // ": missing value = -999.0 : format = " // LineFormat
 if (LineFormat(8:8).EQ.'8') then
    Headers (4) = ' YEAR     JAN     FEB     MAR     APR     MAY     JUN     JUL     ' // &
       			'AUG     SEP     OCT     NOV     DEC     MAM     JJA     SON     DJF     ANN'
 else
    Headers (4) = ' YEAR      JAN      FEB      MAR      APR      MAY      JUN      JUL      ' // &
       			'AUG      SEP      OCT      NOV      DEC      MAM      JJA      SON      DJF      ANN'
 end if
end if

end subroutine MakePerHeaders

!*******************************************************************************

end module SavePerFiles