diff --git a/src/fortran/gfile.f90 b/src/fortran/gfile.f90 index 7d3e74e..992beab 100644 --- a/src/fortran/gfile.f90 +++ b/src/fortran/gfile.f90 @@ -27,6 +27,7 @@ module GFile public :: GfTypeAllocate public :: GfGetValue, GfSetValue, GfForceSetValue public :: GfGetArrValue, GfSetArrValue + public :: GfConvertStringArrToString, GfConvertStringToStringArr private :: GfGetValueString, GfGetValueInteger, GfGetValueReal private :: GfSetValueString, GfSetValueInteger, GfSetValueReal @@ -76,18 +77,38 @@ module GFile end interface contains + function GfConvertStringArrToString(inString) result(outString) + character(len=1), intent(in) , dimension(:) :: inString + character(len=SIZE(inString)) :: outString + integer :: i + do i = 1, SIZE(inString) + outString(i:i) = inString(i) + end do + end function + + function GfConvertStringToStringArr(inString) result(outString) + character(len=*), intent(in) :: inString + character(len=1), dimension(len(inString)) :: outString + integer :: i + do i = 1, LEN(inString) + outString(i) = inString(i:i) + end do + end function + function GfGetArrayValueString(g1,varname,varval) result(iOut) type(GfType), intent(in) :: g1 character(kind=skc,len=*), intent(in) :: varname - character(kind=skc,len=*), intent(inout) :: varval(:) + character(kind=skc,len=1), intent(inout) :: varval(:,:) logical :: iOut integer :: i character(len=5) :: f + character(kind=skc) :: tempStringArr(sklen) + character(kind=skc, len=sklen) :: tempString iOut = .true. - do i=1,size(varval) + do i=1,size(varval, dim=1) write(f,'(I2)') i - iOut = GfGetValueString(g1,varname//"("//trim(adjustl(f))//")",varval(i)) .and. iOut + iOut = GfGetValueString(g1,TRIM(varname)//"("//trim(adjustl(f))//")",varval(i,:)) .and. iOut end do end function @@ -102,7 +123,7 @@ function GfGetArrayValueInteger(g1,varname,varval) result(iOut) iOut = .true. do i=1,size(varval) write(f,'(I2)') i - iOut = GfGetValueInteger(g1,varname//"("//trim(adjustl(f))//")",varval(i)) .and. iOut + iOut = GfGetValueInteger(g1,TRIM(varname)//"("//trim(adjustl(f))//")",varval(i)) .and. iOut end do end function @@ -117,7 +138,7 @@ function GfGetArrayValueReal(g1,varname,varval) result(iOut) iOut = .true. do i=1,size(varval) write(f,'(I2)') i - iOut = GfGetValueReal(g1,varname//"("//trim(adjustl(f))//")",varval(i)) .and. iOut + iOut = GfGetValueReal(g1,TRIM(varname)//"("//trim(adjustl(f))//")",varval(i)) .and. iOut end do end function @@ -126,15 +147,15 @@ function GfGetArrayValueReal(g1,varname,varval) result(iOut) function GfSetArrayValueString(g1,varname,varval) result(iOut) type(GfType), intent(inout) :: g1 character(kind=skc,len=*), intent(in) :: varname - character(kind=skc,len=*), intent(in) :: varval(:) + character(kind=skc,len=1), intent(in) :: varval(:,:) logical :: iOut integer :: i character(len=5) :: f iOut = .true. - do i=1,size(varval) + do i=1,size(varval, dim=1) write(f,'(I2)') i - iOut = GfForceSetValueString(g1,varname//"("//trim(adjustl(f))//")",varval(i)) .and. iOut + iOut = GfForceSetValueString(g1,TRIM(varname)//"("//trim(adjustl(f))//")",varval(i,:)) .and. iOut end do end function @@ -149,7 +170,7 @@ function GfSetArrayValueInteger(g1,varname,varval) result(iOut) iOut = .true. do i=1,size(varval) write(f,'(I2)') i - iOut = GfForceSetValueInteger(g1,varname//"("//trim(adjustl(f))//")",varval(i)) .and. iOut + iOut = GfForceSetValueInteger(g1,TRIM(varname)//"("//trim(adjustl(f))//")",varval(i)) .and. iOut end do end function @@ -164,7 +185,7 @@ function GfSetArrayValueReal(g1,varname,varval) result(iOut) iOut = .true. do i=1,size(varval) write(f,'(I2)') i - iOut = GfForceSetValueReal(g1,varname//"("//trim(adjustl(f))//")",varval(i)) .and. iOut + iOut = GfForceSetValueReal(g1,TRIM(varname)//"("//trim(adjustl(f))//")",varval(i)) .and. iOut end do end function @@ -212,17 +233,21 @@ end function GfTypeAllocate function GfGetValueString (g1, variableName, variable) result(iOut) type(GfType), intent(in) :: g1 character(len=*), intent(in) :: variableName - character(len=*), intent(inout) :: variable + character(len=1), intent(inout) :: variable(:) logical :: iOut integer(kind=ski) :: j character(len=sklen) :: var + character(len=sklen) :: tempString + integer :: i iOut = GfIsDefined(g1,variableName,j) if (iOut) then read(g1%variableValues(j),fmt="(a)") var - variable = trim(var) + do i = 1, len_trim(var) + variable(i) = var(i:i) + end do end if if (.not. iOut) print *,"Warning GfGetValueString: "//trim(variableName) @@ -239,6 +264,7 @@ function GfGetValueInteger (g1, variableName, variable) result(iOut) integer(kind=ski) :: j integer(kind=ski) :: var + character(len=sklen) :: tempString iOut = GfIsDefined(g1, variableName, j) @@ -261,6 +287,7 @@ function GfGetValueReal (g1, variableName, variable) result(iOut) integer(kind=ski) :: j real(kind=skr) :: var + character(len=sklen) :: tempString iOut = GfIsDefined(g1, variableName, j) @@ -269,7 +296,6 @@ function GfGetValueReal (g1, variableName, variable) result(iOut) variable=var end if - if (.not. iOut) print *,"Warning GfGetValueReal: "//trim(variableName) @@ -280,15 +306,17 @@ end function GfGetValueReal function GfSetValueString (g1, variableName, variable) result(iOut) type(GfType), intent(inout) :: g1 character(len=*), intent(in) :: variableName - character(len=*), intent(in) :: variable + character(len=1), intent(in) :: variable(:) logical :: iOut - integer(kind=ski) :: j + integer(kind=ski) :: j, i iOut = GfIsDefined(g1, variableName, j) if (iOut) then - g1%variableValues(j) = variable + do i = 1, SIZE(variable) + g1%variableValues(j)(i:i) = variable(i) + end do endif if (.not. iOut) print *,"Warning GfSetValueString: "//trim(variableName) @@ -312,7 +340,6 @@ function GfSetValueInteger (g1, variableName, variable) result(iOut) write(g1%variableValues(j),fmt=*) variable endif - if (.not. iOut) print *,"Warning GfSetValueInteger: "//trim(variableName) @@ -337,7 +364,6 @@ function GfSetValueReal (g1, variableName, variable) result(iOut) write(g1%variableValues(j),fmt="(g30.15)") variable endif - if (.not. iOut) print *,"Warning GfSetValueReal: "//trim(variableName) @@ -348,14 +374,17 @@ end function GfSetValueReal function GfForceSetValueString (g1, variableName, variable) result(iout) type (gftype), intent(inout) :: g1 character(len=*), intent(in) :: variableName - character(len=*), intent(in) :: variable + character(len=1), intent(in) :: variable(:) logical :: iOut type (gftype) :: g2 integer(kind=ski) :: i + character(len=sklen) :: tempString iOut = .true. + tempString = GfConvertStringArrToString(variable) + if ( .not. gfIsDefined(g1, variableName, i) ) then g2 = g1 g1%nLines = g1%nLines+1 @@ -365,7 +394,7 @@ function GfForceSetValueString (g1, variableName, variable) result(iout) do i=1, g1%nLines-1 g1%fileLines(i) = g2%fileLines(i) end do - g1%fileLines(g1%nLines) = variableName//" = "//variable + g1%fileLines(g1%nLines) = variableName//" = "//tempString do i=1, g1%nvariables-1 g1%variableNames(i) = g2%variableNames(i) @@ -411,11 +440,12 @@ function GfForceSetValueReal (g1, variableName, variable) result(iOut) g1%variableNames(i) = g2%variableNames(i) g1%variableValues(i) = g2%variableValues(i) end do - g1%variableNames(g1%nVariables)=variableName + g1%variableNames(g1%nVariables) = variableName g1%variableValues(g1%nVariables)=" " end if iOut = gfSetValue(g1, variableName, variable) + if (.not. iOut) print *,"Warning GfForceSetValueReal: "//trim(variableName) end function GfForceSetValueReal @@ -449,11 +479,12 @@ function GfForceSetValueInteger (g1, variableName, variable) result(iOut) g1%variableNames(i)=g2%variableNames(i) g1%variableValues(i)=g2%variableValues(i) end do - g1%variableNames(g1%nVariables)=variableName + g1%variableNames(g1%nVariables) = variableName g1%variableValues(g1%nVariables)=" " end if iOut = gfSetValue(g1, variablename, variable) + if (.not. iOut) print *,"Warning GfForceSetValueInteger: "//trim(variableName) end function GfForceSetValueInteger @@ -612,7 +643,6 @@ function GfIsDefined (g1,variableName,variableIndex) Result(iOut) logical :: iOut integer(kind=ski) :: i - iOut = .false. if (present(variableIndex)) variableIndex=-1 diff --git a/src/fortran/shadow_kernel.f90 b/src/fortran/shadow_kernel.f90 index c900971..12179ca 100644 --- a/src/fortran/shadow_kernel.f90 +++ b/src/fortran/shadow_kernel.f90 @@ -63,7 +63,7 @@ Module shadow_kernel !---- Variables SOURCE ----! #define EXPAND_SOURCE_SCALAR(ctype,ftype,fkind,pytype,name,cformat,fformat,defvalue) ftype(kind=fkind) :: name -#define EXPAND_SOURCE_STRING(ctype,ftype,fkind,pytype,name,cformat,fformat,length,defvalue) ftype(kind=fkind,len=length) :: name +#define EXPAND_SOURCE_STRING(ctype,ftype,fkind,pytype,name,cformat,fformat,length,defvalue) ftype(kind=fkind,len=1), dimension(length) :: name #include "shadow_source.def" @@ -82,9 +82,9 @@ Module shadow_kernel ! NOTE: FOR ADDING A NEW VARIABLE, IT SHOULD BE ADDED IN *.def #define EXPAND_OE_SCALAR(ctype,ftype,fkind,pytype,name,cformat,fformat,defvalue) ftype(kind=fkind) :: name -#define EXPAND_OE_STRING(ctype,ftype,fkind,pytype,name,cformat,fformat,length,defvalue) ftype(kind=fkind,len=length) :: name +#define EXPAND_OE_STRING(ctype,ftype,fkind,pytype,name,cformat,fformat,length,defvalue) ftype(kind=fkind,len=1), dimension(length) :: name #define EXPAND_OE_ARRAYS(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,defvalue) ftype(kind=fkind), dimension(arrdim) :: name -#define EXPAND_OE_ARRSTR(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,length,defvalue) ftype(kind=fkind, len=length), dimension(arrdim) :: name +#define EXPAND_OE_ARRSTR(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,length,defvalue) ftype(kind=fkind, len=1), dimension(arrdim, length) :: name #include "shadow_oe_without_repetitions.def" @@ -4506,6 +4506,7 @@ SUBROUTINE REFLEC (PIN,WNUM,SIN_REF,COS_POLE,R_P,R_S,PHASEP,PHASES,ABSOR,K_WHAT) integer(kind=ski):: i,j,nrefl,ierr,ier,index1,iunit integer(kind=ski):: ngx, ngy, ntx, nty, nin, npair + ! C ! C SAVE the variables that need to be saved across subsequent invocations ! C of this subroutine. @@ -4556,10 +4557,10 @@ SUBROUTINE REFLEC (PIN,WNUM,SIN_REF,COS_POLE,R_P,R_S,PHASEP,PHASES,ABSOR,K_WHAT) ! other codes to create it). ! Note: the old binary format is also accepted when reading ! - OPEN (23,FILE=FILE_REFL,STATUS='OLD', & + OPEN (23,FILE=GfConvertStringArrToString(FILE_REFL),STATUS='OLD', & FORM='UNFORMATTED', IOSTAT=iErr) IF (ierr /= 0 ) then - PRINT *,"Error: REFLEC: File not found: "//TRIM(file_refl) + PRINT *,"Error: REFLEC: File not found: "//TRIM(GfConvertStringArrToString(file_refl)) RETURN ! STOP ' Fatal error: aborted' END IF @@ -6360,7 +6361,7 @@ SUBROUTINE SCREEN_EXTERNAL(I_SCR,I_ELEMENT,RAY,RAY_OUT) ! C indices (into xvec and zvec) and number of points per polygon. ! C IFLAG = 0 - filename = FILE_SCR_EXT(I_SCR) + filename = GfConvertStringArrToString(FILE_SCR_EXT(I_SCR,:)) CALL SCREEN_EXTERNAL_GETDIMENSIONS(filename, N_POLYS,N_POINTS,IFLAG) !print *,'>>> SCREEN_EXTERNAL_GETDIMENSIONS: N_POLYS: ',N_POLYS !print *,'>>> SCREEN_EXTERNAL_GETDIMENSIONS: N_POINTS: ',N_POINTS @@ -10398,8 +10399,8 @@ SUBROUTINE INPUT_OE (I_OENUM,iTerminate) !c !c IF (I_OENUM.EQ.1) THEN - FILE_SOURCE = RSTRING ('File containing the source array [Default: begin.dat] ? ') - IF (trim(FILE_SOURCE) == "") FILE_SOURCE="begin.dat" + FILE_SOURCE = GfConvertStringToStringArr(RSTRING ('File containing the source array [Default: begin.dat] ? ')) + IF (trim(GfConvertStringArrToString(FILE_SOURCE)) == "") FILE_SOURCE=GfConvertStringToStringArr("begin.dat") END IF 10101 CONTINUE !c @@ -11925,12 +11926,12 @@ End Subroutine PoolSourceToGlobal Subroutine PoolOEToGlobal(oe) !bind(C,NAME="PoolOEToGlobal") type(poolOE),intent(in out) :: oe - integer(kind=ski) :: i + integer(kind=ski) :: i, j #define EXPAND_OE_SCALAR(ctype,ftype,fkind,pytype,name,cformat,fformat,defvalue) name = oe%name #define EXPAND_OE_STRING(ctype,ftype,fkind,pytype,name,cformat,fformat,length,defvalue) name = oe%name -#define EXPAND_OE_ARRAYS(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,defvalue) forall(i=1:arrdim) name(i) = oe%name(i) -#define EXPAND_OE_ARRSTR(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,length,defvalue) forall(i=1:arrdim) name(i) = oe%name(i) +#define EXPAND_OE_ARRAYS(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,defvalue) name = oe%name +#define EXPAND_OE_ARRSTR(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,length,defvalue) name = oe%name #include "shadow_oe.def" diff --git a/src/fortran/shadow_variables.f90 b/src/fortran/shadow_variables.f90 index abd1116..20d92af 100644 --- a/src/fortran/shadow_variables.f90 +++ b/src/fortran/shadow_variables.f90 @@ -66,16 +66,16 @@ Module shadow_variables ! again the same variables encapsulated in a structure type, public, bind(C) :: poolSource #define EXPAND_SOURCE_SCALAR(ctype,ftype,fkind,pytype,name,cformat,fformat,defvalue) ftype(kind=fkind) :: name -#define EXPAND_SOURCE_STRING(ctype,ftype,fkind,pytype,name,cformat,fformat,length,defvalue) ftype(kind=fkind,len=length) :: name +#define EXPAND_SOURCE_STRING(ctype,ftype,fkind,pytype,name,cformat,fformat,length,defvalue) ftype(kind=fkind,len=1), dimension(length) :: name #include "shadow_source.def" end type poolSource type, public, bind(C) :: poolOE #define EXPAND_OE_SCALAR(ctype,ftype,fkind,pytype,name,cformat,fformat,defvalue) ftype(kind=fkind) :: name -#define EXPAND_OE_STRING(ctype,ftype,fkind,pytype,name,cformat,fformat,length,defvalue) ftype(kind=fkind,len=length) :: name +#define EXPAND_OE_STRING(ctype,ftype,fkind,pytype,name,cformat,fformat,length,defvalue) ftype(kind=fkind,len=1), dimension(length) :: name #define EXPAND_OE_ARRAYS(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,defvalue) ftype(kind=fkind), dimension(arrdim) :: name -#define EXPAND_OE_ARRSTR(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,length,defvalue) ftype(kind=fkind, len=length), dimension(arrdim) :: name +#define EXPAND_OE_ARRSTR(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,length,defvalue) ftype(kind=fkind, len=1), dimension(arrdim,length) :: name #include "shadow_oe.def" end type poolOE @@ -299,11 +299,11 @@ end subroutine PoolSourceDefault subroutine PoolOEDefault(oe) type (poolOE), intent(inout) :: oe - integer(kind=ski) :: i + integer(kind=ski) :: i, j #define EXPAND_OE_SCALAR(ctype,ftype,fkind,pytype,name,cformat,fformat,defvalue) oe%name=defvalue #define EXPAND_OE_STRING(ctype,ftype,fkind,pytype,name,cformat,fformat,length,defvalue) oe%name=defvalue #define EXPAND_OE_ARRAYS(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,defvalue) FORALL(i=1:arrdim) oe%name(i)=defvalue -#define EXPAND_OE_ARRSTR(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,length,defvalue) FORALL(i=1:arrdim) oe%name(i)=defvalue +#define EXPAND_OE_ARRSTR(ctype,ftype,fkind,pytype,name,cformat,fformat,arrdim,length,defvalue) FORALL(i=1:arrdim, j=1:length) oe%name(i,j)=defvalue #include "shadow_oe.def" end subroutine PoolOEDefault