From 15deec07735802efd308251e493d1667ce0e5920 Mon Sep 17 00:00:00 2001 From: Bonnie Jonkman Date: Fri, 19 Jul 2019 10:22:43 -0600 Subject: [PATCH] Registry updates (+ corresponding change in NWTC Library) - updated C2F copy routines to allow for skipping the pointers (in case of module initially defining the pointers in Fortran code in instead of C/C++ code) - updated pack/unpack routines to avoid putting entire arrays on the stack (https://github.com/OpenFAST/openfast/issues/99) - updated extrap/interp routines to account for values that have a period of 2pi. This change requires additional routines in NWTC_Num.f90. - this also includes changes that were introduces in a not-yet-merged pull request for 2D airfoil interpolation --- modules/nwtc-library/src/NWTC_Num.f90 | 505 ++++++++++- modules/openfast-registry/src/Makefile | 67 -- modules/openfast-registry/src/data.h | 2 +- modules/openfast-registry/src/gen_c_types.c | 7 +- .../openfast-registry/src/gen_module_files.c | 843 +++++++++--------- modules/openfast-registry/src/reg_parse.c | 31 +- modules/openfast-registry/src/registry.h | 6 +- 7 files changed, 894 insertions(+), 567 deletions(-) delete mode 100644 modules/openfast-registry/src/Makefile diff --git a/modules/nwtc-library/src/NWTC_Num.f90 b/modules/nwtc-library/src/NWTC_Num.f90 index 836fc56e4f..14653edcb5 100644 --- a/modules/nwtc-library/src/NWTC_Num.f90 +++ b/modules/nwtc-library/src/NWTC_Num.f90 @@ -55,6 +55,10 @@ MODULE NWTC_Num REAL(ReKi) :: TwoByPi !< 2/Pi REAL(ReKi) :: TwoPi !< 2*Pi + REAL(SiKi) :: Pi_R4 !< Ratio of a circle's circumference to its diameter in 4-byte precision + REAL(R8Ki) :: Pi_R8 !< Ratio of a circle's circumference to its diameter in 8-byte precision + REAL(QuKi) :: Pi_R16 !< Ratio of a circle's circumference to its diameter in 16-byte precision + !======================================================================= ! Create interfaces for generic routines that use specific routines. @@ -109,10 +113,11 @@ MODULE NWTC_Num MODULE PROCEDURE GetSmllRotAngsR END INTERFACE - !> \copydoc nwtc_num::zero2twopir + !> \copydoc nwtc_num::zero2twopir4 INTERFACE Zero2TwoPi - MODULE PROCEDURE Zero2TwoPiD - MODULE PROCEDURE Zero2TwoPiR + MODULE PROCEDURE Zero2TwoPiR4 + MODULE PROCEDURE Zero2TwoPiR8 + MODULE PROCEDURE Zero2TwoPiR16 END INTERFACE !> \copydoc nwtc_num::twonormr4 @@ -194,57 +199,123 @@ MODULE NWTC_Num MODULE PROCEDURE SkewSymMatR16 END INTERFACE + !> \copydoc nwtc_num::angle_extrapinterp2_r4 + INTERFACE Angles_ExtrapInterp + MODULE PROCEDURE Angles_ExtrapInterp1_R4 + MODULE PROCEDURE Angles_ExtrapInterp1_R8 + MODULE PROCEDURE Angles_ExtrapInterp1_R16 + MODULE PROCEDURE Angles_ExtrapInterp2_R4 + MODULE PROCEDURE Angles_ExtrapInterp2_R8 + MODULE PROCEDURE Angles_ExtrapInterp2_R16 + END INTERFACE + !> \copydoc nwtc_num::addorsub2pi_r4 + INTERFACE AddOrSub2Pi + MODULE PROCEDURE AddOrSub2Pi_R4 + MODULE PROCEDURE AddOrSub2Pi_R8 + MODULE PROCEDURE AddOrSub2Pi_R16 + END INTERFACE CONTAINS !======================================================================= -!> This routine is used to convert NewAngle to an angle within 2*Pi of -!! OldAngle by adding or subtracting 2*Pi accordingly; it then sets -!! OldAngle equal to NewAngle. This routine is useful for converting +!> This routine is used to convert NewAngle to an angle within Pi of +!! OldAngle by adding or subtracting 2*Pi accordingly. +!! This routine is useful for converting !! angles returned from a call to the ATAN2() FUNCTION into angles that may !! exceed the -Pi to Pi limit of ATAN2(). For example, if the nacelle yaw !! angle was 179deg in the previous time step and the yaw angle increased !! by 2deg in the new time step, we want the new yaw angle returned from a !! call to the ATAN2() FUNCTION to be 181deg instead of -179deg. This !! routine assumes that the angle change between calls is not more than -!! 2*Pi in absolute value. OldAngle should be saved in the calling -!! routine. - SUBROUTINE AddOrSub2Pi ( OldAngle, NewAngle ) +!! Pi in absolute value. +!! Use AddOrSub2Pi (nwtc_num::addorsub2pi) instead of directly calling a specific routine in the generic interface. + SUBROUTINE AddOrSub2Pi_R4 ( OldAngle, NewAngle ) + ! Argument declarations: + + REAL(SiKi), INTENT(IN ) :: OldAngle !< Angle from which NewAngle will be converted to within Pi of, rad. + REAL(SiKi), INTENT(INOUT) :: NewAngle !< Angle to be converted to within 2*Pi of OldAngle, rad. + + + ! Local declarations: + + REAL(SiKi) :: DelAngle ! The difference between OldAngle and NewAngle, rad. + + + + ! Add or subtract 2*Pi in order to convert NewAngle two within Pi of OldAngle: + + + DelAngle = OldAngle - NewAngle + + DO WHILE ( ABS( DelAngle ) >= Pi_R4 ) + + NewAngle = NewAngle + Pi_R4 * SIGN( 2.0_SiKi, DelAngle ) + DelAngle = OldAngle - NewAngle + + END DO + + RETURN + END SUBROUTINE AddOrSub2Pi_R4 +!======================================================================= +!> \copydoc nwtc_num::addorsub2pi_r4 + SUBROUTINE AddOrSub2Pi_R8 ( OldAngle, NewAngle ) ! Argument declarations: - REAL(ReKi), INTENT(INOUT) :: OldAngle !< Angle from which NewAngle will be converted to within 2*Pi of, rad. - REAL(ReKi), INTENT(INOUT) :: NewAngle !< Angle to be converted to within 2*Pi of OldAngle, rad. + REAL(R8Ki), INTENT(IN ) :: OldAngle ! Angle from which NewAngle will be converted to within Pi of, rad. + REAL(R8Ki), INTENT(INOUT) :: NewAngle ! Angle to be converted to within Pi of OldAngle, rad. ! Local declarations: - REAL(ReKi) :: DelAngle ! The difference between OldAngle and NewAngle, rad. + REAL(R8Ki) :: DelAngle ! The difference between OldAngle and NewAngle, rad. - ! Add or subtract 2*Pi in order to convert NewAngle two within 2*Pi of - ! OldAngle: + ! Add or subtract 2*Pi in order to convert NewAngle two within Pi of OldAngle: DelAngle = OldAngle - NewAngle - DO WHILE ( ABS( DelAngle ) >= TwoPi ) + DO WHILE ( ABS( DelAngle ) >= Pi_R8 ) - NewAngle = NewAngle + SIGN( TwoPi, DelAngle ) + NewAngle = NewAngle + Pi_R8 * SIGN( 2.0_R8Ki, DelAngle ) DelAngle = OldAngle - NewAngle END DO + RETURN + END SUBROUTINE AddOrSub2Pi_R8 +!======================================================================= +!> \copydoc nwtc_num::addorsub2pi_r4 + SUBROUTINE AddOrSub2Pi_R16 ( OldAngle, NewAngle ) - ! Set OldAngle to equal NewAngle: + ! Argument declarations: - OldAngle = NewAngle + REAL(QuKi), INTENT(IN ) :: OldAngle ! Angle from which NewAngle will be converted to within 2*Pi of, rad. + REAL(QuKi), INTENT(INOUT) :: NewAngle ! Angle to be converted to within 2*Pi of OldAngle, rad. + + + ! Local declarations: + REAL(QuKi) :: DelAngle ! The difference between OldAngle and NewAngle, rad. + + ! Add or subtract 2*Pi in order to convert NewAngle two within Pi of OldAngle: + + + DelAngle = OldAngle - NewAngle + + DO WHILE ( ABS( DelAngle ) >= Pi_R16 ) + + NewAngle = NewAngle + Pi_R16 * SIGN( 2.0_QuKi, DelAngle ) + DelAngle = OldAngle - NewAngle + + END DO + RETURN - END SUBROUTINE AddOrSub2Pi + END SUBROUTINE AddOrSub2Pi_R16 !======================================================================= !> This routine sorts a list of real numbers. It uses the bubble sort algorithm, !! which is only suitable for short lists. @@ -4066,7 +4137,7 @@ END FUNCTION OuterProductR16 !! a change in log map parameters. SUBROUTINE PerturbOrientationMatrix( Orientation, Perturbation, AngleDim ) REAL(R8Ki), INTENT(INOUT) :: Orientation(3,3) - REAL(R8Ki), INTENT(IN) :: Perturbation + REAL(R8Ki), INTENT(IN) :: Perturbation ! angle (radians) of the perturbation INTEGER, INTENT(IN) :: AngleDim ! Local variables @@ -4975,8 +5046,8 @@ FUNCTION GetClockTime(StartClockTime, EndClockTime) ! return the number of seconds between StartClockTime and EndClockTime REAL :: GetClockTime ! Elapsed clock time for the simulation phase of the run. - INTEGER , INTENT(IN) :: StartClockTime (8) ! Start time of simulation (after initialization) - INTEGER , INTENT(IN) :: EndClockTime (8) ! Start time of simulation (after initialization) + INTEGER , INTENT(IN) :: StartClockTime (8) ! Start time of simulation (after initialization) + INTEGER , INTENT(IN) :: EndClockTime (8) ! Start time of simulation (after initialization) !bjj: This calculation will be wrong at certain times (e.g. if it's near midnight on the last day of the month), but to my knowledge, no one has complained... GetClockTime = 0.001*( EndClockTime(8) - StartClockTime(8) ) & ! Is the milliseconds of the second (range 0 to 999) - local time @@ -5054,6 +5125,9 @@ SUBROUTINE SetConstants( ) TwoPi = 2.0_ReKi*Pi Inv2Pi = 0.5_ReKi/Pi ! 1.0/TwoPi + Pi_R4 = ACOS( -1.0_SiKi ) + Pi_R8 = ACOS( -1.0_R8Ki ) + Pi_R16 = ACOS( -1.0_QuKi ) ! IEEE constants: CALL Set_IEEE_Constants( NaN_D, Inf_D, NaN, Inf ) @@ -5193,7 +5267,7 @@ SUBROUTINE SimStatus( PrevSimTime, PrevClockTime, ZTime, TMax, DescStrIn ) PrevSimTime = ZTime RETURN - END SUBROUTINE SimStatus + END SUBROUTINE SimStatus !======================================================================= !> This routine computes the 3x3 transformation matrix, \f$TransMat\f$, !! to a coordinate system \f$x\f$ (with orthogonal axes \f$x_1, x_2, x_3\f$) @@ -5620,7 +5694,12 @@ SUBROUTINE SortUnion ( Ary1, N1, Ary2, N2, Ary, N ) END SUBROUTINE SortUnion ! ( Ary1, N1, Ary2, N2, Ary, N ) !======================================================================= !> This routine calculates the standard deviation of a population contained in Ary. - FUNCTION StdDevFn ( Ary, AryLen, Mean ) +!! +!! This can be calculated as either\n +!! \f$ \sqrt{ \frac{\sum_{i=1}^N \left(x_i -\bar{x}\right)^2 }{N-1} } \f$ \n +!! or \n +!! \f$ \sqrt{ \frac{\sum_{i=1}^N \left(x_i -\bar{x}\right)^2 }{N} } \f$ if `UseN` is true \n + FUNCTION StdDevFn ( Ary, AryLen, Mean, UseN ) ! Function declaration. @@ -5633,6 +5712,7 @@ FUNCTION StdDevFn ( Ary, AryLen, Mean ) REAL(ReKi), INTENT(IN) :: Ary (AryLen) !< Input array. REAL(ReKi), INTENT(IN) :: Mean !< The previously calculated mean of the array. + LOGICAL, OPTIONAL, INTENT(IN) :: UseN !< Use `N` insted of `N-1` in denomenator ! Local declarations. @@ -5640,8 +5720,17 @@ FUNCTION StdDevFn ( Ary, AryLen, Mean ) REAL(DbKi) :: Sum ! A temporary sum. INTEGER :: I ! The index into the array. + INTEGER :: Denom ! Denominator - + IF(PRESENT(UseN)) THEN + IF (UseN) THEN + Denom = AryLen + ELSE + Denom = AryLen-1 + ENDIF + ELSE + Denom = AryLen-1 + ENDIF Sum = 0.0_DbKi @@ -5649,7 +5738,7 @@ FUNCTION StdDevFn ( Ary, AryLen, Mean ) Sum = Sum + ( Ary(I) - Mean )**2 END DO ! I - StdDevFn = SQRT( Sum/( AryLen - 1 ) ) + StdDevFn = SQRT( Sum/( Denom ) ) RETURN @@ -5733,6 +5822,7 @@ FUNCTION SkewSymMatR16 ( x ) RESULT(M) RETURN END FUNCTION SkewSymMatR16 + !======================================================================= !> This routine takes an array of time values such as that returned from !! CALL DATE_AND_TIME ( Values=TimeAry ) @@ -5858,30 +5948,30 @@ FUNCTION TwoNormR16(v) !> This routine is used to convert Angle to an equivalent value !! in the range \f$[0, 2\pi)\f$. \n !! Use Zero2TwoPi (nwtc_num::zero2twopi) instead of directly calling a specific routine in the generic interface. - SUBROUTINE Zero2TwoPiR ( Angle ) + SUBROUTINE Zero2TwoPiR4 ( Angle ) ! Argument declarations: - REAL(ReKi), INTENT(INOUT) :: Angle !< angle that is input and converted to equivalent in range \f$[0, 2\pi)\f$ + REAL(SiKi), INTENT(INOUT) :: Angle !< angle that is input and converted to equivalent in range \f$[0, 2\pi)\f$ ! Get the angle between 0 and 2Pi. - Angle = MODULO( Angle, TwoPi ) + Angle = MODULO( Angle, 2.0_SiKi * Pi_R4 ) ! Check numerical case where Angle == 2Pi. - IF ( Angle == TwoPi ) THEN + IF ( Angle == 2.0_SiKi * Pi_R4 ) THEN Angle = 0.0_ReKi END IF RETURN - END SUBROUTINE Zero2TwoPiR + END SUBROUTINE Zero2TwoPiR4 !======================================================================= -!> \copydoc nwtc_num::zero2twopir - SUBROUTINE Zero2TwoPiD ( Angle ) +!> \copydoc nwtc_num::zero2twopir4 + SUBROUTINE Zero2TwoPiR8 ( Angle ) ! This routine is used to convert Angle to an equivalent value ! in the range [0, 2*pi). @@ -5889,23 +5979,364 @@ SUBROUTINE Zero2TwoPiD ( Angle ) ! Argument declarations: - REAL(DbKi), INTENT(INOUT) :: Angle + REAL(R8Ki), INTENT(INOUT) :: Angle ! Get the angle between 0 and 2Pi. - Angle = MODULO( Angle, TwoPi_D ) + Angle = MODULO( Angle, 2.0_R8Ki * Pi_R8 ) ! Check numerical case where Angle == 2Pi. - IF ( Angle == TwoPi_D ) THEN + IF ( Angle == 2.0_R8Ki * Pi_R8 ) THEN Angle = 0.0_DbKi END IF RETURN - END SUBROUTINE Zero2TwoPiD + END SUBROUTINE Zero2TwoPiR8 +!======================================================================= +!> \copydoc nwtc_num::zero2twopir4 + SUBROUTINE Zero2TwoPiR16 ( Angle ) + + ! This routine is used to convert Angle to an equivalent value + ! in the range [0, 2*pi). + + + ! Argument declarations: + + REAL(QuKi), INTENT(INOUT) :: Angle + + + + ! Get the angle between 0 and 2Pi. + + Angle = MODULO( Angle, 2.0_QuKi * Pi_R16 ) + + + ! Check numerical case where Angle == 2Pi. + + IF ( Angle == 2.0_QuKi * Pi_R16 ) THEN + Angle = 0.0_DbKi + END IF + + + RETURN + END SUBROUTINE Zero2TwoPiR16 +!======================================================================= + !< This routine extrapolates or interpolates between angles + SUBROUTINE Angles_ExtrapInterp1_R4(Angle1, Angle2, tin, Angle_out, tin_out ) + REAL(SiKi), INTENT(IN ) :: Angle1 !< Angle at t1 > t2 + REAL(SiKi), INTENT(IN ) :: Angle2 !< Angle at t2 + REAL(DbKi), INTENT(IN ) :: tin(:) !< Times associated with the inputs + REAL(SiKi), INTENT(INOUT) :: Angle_out !< Input at tin_out + REAL(DbKi), INTENT(IN ) :: tin_out !< time to be extrap/interp'd to + + ! local variables + INTEGER(IntKi), parameter :: order = 1 ! order of polynomial fit (max 2) + REAL(DbKi) :: t(SIZE(tin)) ! Times associated with the inputs + REAL(DbKi) :: t_out ! Time to which to be extrap/interpd + + REAL(DbKi) :: scaleFactor ! temporary for extrapolation/interpolation + REAL(SiKi) :: Angle2_mod + + ! we'll subtract a constant from the times to resolve some + ! numerical issues when t gets large (and to simplify the equations) + t = tin - tin(1) + t_out = tin_out - tin(1) + + ! ! some error checking: + ! + ! if ( size(t) .ne. order+1) then + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp1: size(t) must equal 2.' + ! RETURN + ! end if + ! + !IF ( EqualRealNos( t(1), t(2) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp1: t(1) must not equal t(2) to avoid a division-by-zero error.' + ! RETURN + !END IF + + Angle2_mod = Angle2 + call AddOrSub2Pi( Angle1, Angle2_mod ) + + Angle_out = Angle1 + (Angle2_mod - Angle1) * t_out / t(2) + call Zero2TwoPi(Angle_out) + + END SUBROUTINE Angles_ExtrapInterp1_R4 +!======================================================================= + !< This routine extrapolates or interpolates between angles + SUBROUTINE Angles_ExtrapInterp1_R8(Angle1, Angle2, tin, Angle_out, tin_out) + REAL(R8Ki), INTENT(IN ) :: Angle1 !< Angle at t1 > t2 + REAL(R8Ki), INTENT(IN ) :: Angle2 !< Angle at t2 + REAL(DbKi), INTENT(IN ) :: tin(:) !< Times associated with the inputs + REAL(R8Ki), INTENT(INOUT) :: Angle_out !< Input at tin_out + REAL(DbKi), INTENT(IN ) :: tin_out !< time to be extrap/interp'd to + + ! local variables + INTEGER(IntKi), parameter :: order = 1 ! order of polynomial fit (max 2) + REAL(DbKi) :: t(SIZE(tin)) ! Times associated with the inputs + REAL(DbKi) :: t_out ! Time to which to be extrap/interpd + + REAL(DbKi) :: scaleFactor ! temporary for extrapolation/interpolation + REAL(R8Ki) :: Angle2_mod + + ! we'll subtract a constant from the times to resolve some + ! numerical issues when t gets large (and to simplify the equations) + t = tin - tin(1) + t_out = tin_out - tin(1) + + ! ! some error checking: + ! + ! if ( size(t) .ne. order+1) then + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp1: size(t) must equal 2.' + ! RETURN + ! end if + ! + !IF ( EqualRealNos( t(1), t(2) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp1: t(1) must not equal t(2) to avoid a division-by-zero error.' + ! RETURN + !END IF + + Angle2_mod = Angle2 + call AddOrSub2Pi( Angle1, Angle2_mod ) + + Angle_out = Angle1 + (Angle2_mod - Angle1) * t_out / t(2) + call Zero2TwoPi(Angle_out) + + END SUBROUTINE Angles_ExtrapInterp1_R8 +!======================================================================= + !< This routine extrapolates or interpolates between angles + SUBROUTINE Angles_ExtrapInterp1_R16(Angle1, Angle2, tin, Angle_out, tin_out) + REAL(QuKi), INTENT(IN ) :: Angle1 !< Angle at t1 > t2 + REAL(QuKi), INTENT(IN ) :: Angle2 !< Angle at t2 + REAL(DbKi), INTENT(IN ) :: tin(:) !< Times associated with the inputs + REAL(QuKi), INTENT(INOUT) :: Angle_out !< Input at tin_out + REAL(DbKi), INTENT(IN ) :: tin_out !< time to be extrap/interp'd to + + ! local variables + INTEGER(IntKi), parameter :: order = 1 ! order of polynomial fit (max 2) + REAL(DbKi) :: t(SIZE(tin)) ! Times associated with the inputs + REAL(DbKi) :: t_out ! Time to which to be extrap/interpd + + REAL(DbKi) :: scaleFactor ! temporary for extrapolation/interpolation + REAL(QuKi) :: Angle2_mod + + ! we'll subtract a constant from the times to resolve some + ! numerical issues when t gets large (and to simplify the equations) + t = tin - tin(1) + t_out = tin_out - tin(1) + + ! ! some error checking: + ! + ! if ( size(t) .ne. order+1) then + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp1: size(t) must equal 2.' + ! RETURN + ! end if + ! + !IF ( EqualRealNos( t(1), t(2) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp1: t(1) must not equal t(2) to avoid a division-by-zero error.' + ! RETURN + !END IF + + Angle2_mod = Angle2 + call AddOrSub2Pi( Angle1, Angle2_mod ) + + Angle_out = Angle1 + (Angle2_mod - Angle1) * t_out / t(2) + call Zero2TwoPi(Angle_out) + + END SUBROUTINE Angles_ExtrapInterp1_R16 +!======================================================================= + !< This routine extrapolates or interpolates between angles + SUBROUTINE Angles_ExtrapInterp2_R4(Angle1, Angle2, Angle3, tin, Angle_out, tin_out ) + REAL(SiKi), INTENT(IN ) :: Angle1 !< Angle at t1 > t2 > t3 + REAL(SiKi), INTENT(IN ) :: Angle2 !< Angle at t2 > t3 + REAL(SiKi), INTENT(IN ) :: Angle3 !< Angle at t3 + REAL(DbKi), INTENT(IN ) :: tin(:) !< Times associated with the inputs + REAL(SiKi), INTENT(INOUT) :: Angle_out !< Input at tin_out + REAL(DbKi), INTENT(IN ) :: tin_out !< time to be extrap/interp'd to + + ! local variables + INTEGER(IntKi), parameter :: order = 2 ! order of polynomial fit (max 2) + REAL(DbKi) :: t(SIZE(tin)) ! Times associated with the inputs + REAL(DbKi) :: t_out ! Time to which to be extrap/interpd + + REAL(DbKi) :: scaleFactor ! temporary for extrapolation/interpolation + REAL(SiKi) :: Angle2_mod + REAL(SiKi) :: Angle3_mod + + ! we'll subtract a constant from the times to resolve some + ! numerical issues when t gets large (and to simplify the equations) + t = tin - tin(1) + t_out = tin_out - tin(1) + + ! ! some error checking: + ! + !if ( size(t) .ne. order+1) then + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: size(t) must equal 3.' + ! RETURN + !end if + ! + !IF ( EqualRealNos( t(1), t(2) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: t(1) must not equal t(2) to avoid a division-by-zero error.' + ! RETURN + !END IF + !IF ( EqualRealNos( t(2), t(3) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: t(2) must not equal t(3) to avoid a division-by-zero error.' + ! RETURN + !END IF + !IF ( EqualRealNos( t(1), t(3) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: t(1) must not equal t(3) to avoid a division-by-zero error.' + ! RETURN + !END IF + + Angle2_mod = Angle2 + Angle3_mod = Angle3 + call AddOrSub2Pi( Angle1, Angle2_mod ) + call AddOrSub2Pi( Angle2_mod, Angle3_mod ) + + scaleFactor = t_out / ( t(2) * t(3) * (t(2) - t(3)) ) + + Angle_out = Angle1 & + + ( t(3)**2 * (Angle1 - Angle2_mod) + t(2)**2*(-Angle1 + Angle3_mod) ) * scaleFactor & + + ( (t(2)-t(3))*Angle1 + t(3)*Angle2_mod - t(2)*Angle3_mod ) *scaleFactor * t_out + + call Zero2TwoPi(Angle_out) + + END SUBROUTINE Angles_ExtrapInterp2_R4 +!======================================================================= + !< This routine extrapolates or interpolates between angles + SUBROUTINE Angles_ExtrapInterp2_R8(Angle1, Angle2, Angle3, tin, Angle_out, tin_out) + REAL(R8Ki), INTENT(IN ) :: Angle1 !< Angle at t1 > t2 > t3 + REAL(R8Ki), INTENT(IN ) :: Angle2 !< Angle at t2 > t3 + REAL(R8Ki), INTENT(IN ) :: Angle3 !< Angle at t3 + REAL(DbKi), INTENT(IN ) :: tin(:) !< Times associated with the inputs + REAL(R8Ki), INTENT(INOUT) :: Angle_out !< Input at tin_out + REAL(DbKi), INTENT(IN ) :: tin_out !< time to be extrap/interp'd to + + ! local variables + INTEGER(IntKi), parameter :: order = 2 ! order of polynomial fit (max 2) + REAL(DbKi) :: t(SIZE(tin)) ! Times associated with the inputs + REAL(DbKi) :: t_out ! Time to which to be extrap/interpd + + REAL(DbKi) :: scaleFactor ! temporary for extrapolation/interpolation + REAL(R8Ki) :: Angle2_mod + REAL(R8Ki) :: Angle3_mod + + ! we'll subtract a constant from the times to resolve some + ! numerical issues when t gets large (and to simplify the equations) + t = tin - tin(1) + t_out = tin_out - tin(1) + + ! some error checking: + + !if ( size(t) .ne. order+1) then + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: size(t) must equal 3.' + ! RETURN + !end if + ! + !IF ( EqualRealNos( t(1), t(2) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: t(1) must not equal t(2) to avoid a division-by-zero error.' + ! RETURN + !END IF + !IF ( EqualRealNos( t(2), t(3) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: t(2) must not equal t(3) to avoid a division-by-zero error.' + ! RETURN + !END IF + !IF ( EqualRealNos( t(1), t(3) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: t(1) must not equal t(3) to avoid a division-by-zero error.' + ! RETURN + !END IF + + Angle2_mod = Angle2 + Angle3_mod = Angle3 + call AddOrSub2Pi( Angle1, Angle2_mod ) + call AddOrSub2Pi( Angle2_mod, Angle3_mod ) + + scaleFactor = t_out / ( t(2) * t(3) * (t(2) - t(3)) ) + + Angle_out = Angle1 & + + ( t(3)**2 * (Angle1 - Angle2_mod) + t(2)**2*(-Angle1 + Angle3_mod) ) * scaleFactor & + + ( (t(2)-t(3))*Angle1 + t(3)*Angle2_mod - t(2)*Angle3_mod ) *scaleFactor * t_out + call Zero2TwoPi(Angle_out) + + END SUBROUTINE Angles_ExtrapInterp2_R8 +!======================================================================= + !< This routine extrapolates or interpolates between angles + SUBROUTINE Angles_ExtrapInterp2_R16(Angle1, Angle2, Angle3, tin, Angle_out, tin_out ) + REAL(QuKi), INTENT(IN ) :: Angle1 !< Angle at t1 > t2 > t3 + REAL(QuKi), INTENT(IN ) :: Angle2 !< Angle at t2 > t3 + REAL(QuKi), INTENT(IN ) :: Angle3 !< Angle at t3 + REAL(DbKi), INTENT(IN ) :: tin(:) !< Times associated with the inputs + REAL(QuKi), INTENT(INOUT) :: Angle_out !< Input at tin_out + REAL(DbKi), INTENT(IN ) :: tin_out !< time to be extrap/interp'd to + + ! local variables + INTEGER(IntKi), parameter :: order = 2 ! order of polynomial fit (max 2) + REAL(DbKi) :: t(SIZE(tin)) ! Times associated with the inputs + REAL(DbKi) :: t_out ! Time to which to be extrap/interpd + + REAL(DbKi) :: scaleFactor ! temporary for extrapolation/interpolation + REAL(QuKi) :: Angle2_mod + REAL(QuKi) :: Angle3_mod + + ! we'll subtract a constant from the times to resolve some + ! numerical issues when t gets large (and to simplify the equations) + t = tin - tin(1) + t_out = tin_out - tin(1) + + ! some error checking: + + !if ( size(t) .ne. order+1) then + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: size(t) must equal 3.' + ! RETURN + !end if + ! + !IF ( EqualRealNos( t(1), t(2) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: t(1) must not equal t(2) to avoid a division-by-zero error.' + ! RETURN + !END IF + !IF ( EqualRealNos( t(2), t(3) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: t(2) must not equal t(3) to avoid a division-by-zero error.' + ! RETURN + !END IF + !IF ( EqualRealNos( t(1), t(3) ) ) THEN + ! ErrStat = ErrID_Fatal + ! ErrMsg = 'Angles_ExtrapInterp2: t(1) must not equal t(3) to avoid a division-by-zero error.' + ! RETURN + !END IF + + Angle2_mod = Angle2 + Angle3_mod = Angle3 + call AddOrSub2Pi( Angle1, Angle2_mod ) + call AddOrSub2Pi( Angle2_mod, Angle3_mod ) + + scaleFactor = t_out / ( t(2) * t(3) * (t(2) - t(3)) ) + + Angle_out = Angle1 & + + ( t(3)**2 * (Angle1 - Angle2_mod) + t(2)**2*(-Angle1 + Angle3_mod) ) * scaleFactor & + + ( (t(2)-t(3))*Angle1 + t(3)*Angle2_mod - t(2)*Angle3_mod ) *scaleFactor * t_out + call Zero2TwoPi(Angle_out) + + END SUBROUTINE Angles_ExtrapInterp2_R16 !======================================================================= END MODULE NWTC_Num diff --git a/modules/openfast-registry/src/Makefile b/modules/openfast-registry/src/Makefile deleted file mode 100644 index 921149cd0e..0000000000 --- a/modules/openfast-registry/src/Makefile +++ /dev/null @@ -1,67 +0,0 @@ -ifeq ($(OS),Windows_NT) - ifeq ($(OSTYPE),cygwin) - RM=rm -f - else - RM=del - endif -else - RM = rm -f -endif -.SUFFIXES: .c .o - -# i586-mingw32msvc-gcc -#CC_TOOLS = i586-mingw32msvc-gcc -CC_TOOLS = gcc -DEST_DIR = .. -CFLAGS = #-ansi -LDFLAGS = -DEBUG = -g -OBJ = registry.o \ - my_strtok.o \ - reg_parse.o \ - data.o \ - type.o \ - misc.o \ - sym.o \ - symtab_gen.o \ - gen_module_files.o \ - gen_c_types.o - -# marco's: all : $(OBJ) -$(DEST_DIR)/registry.exe : $(OBJ) - $(CC_TOOLS) -o $(DEST_DIR)/registry.exe $(DEBUG) $(LDFLAGS) $(OBJ) - -.c.o : - $(CC_TOOLS) $(CFLAGS) -c $(DEBUG) $< - -clean clena: - $(RM) $(OBJ) gen_comms.c standard.o - -superclean : clean - $(RM) $(DEST_DIR)/registry.exe Registry_tmp.* - -# regenerate this list with "makedepend -Y *.c" - -# DO NOT DELETE THIS LINE -- make depend depends on it. - -gen_module_files.o: protos.h registry.h data.h FAST_preamble.h type.o - -data.o: registry.h protos.h data.h -gen_allocs.o: protos.h registry.h data.h -gen_args.o: protos.h registry.h data.h -gen_scalar_derefs.o: protos.h registry.h data.h -gen_config.o: protos.h registry.h data.h -gen_defs.o: protos.h registry.h data.h -gen_mod_state_descr.o: protos.h registry.h data.h -gen_model_data_ord.o: protos.h registry.h data.h -gen_scalar_indices.o: protos.h registry.h data.h -gen_wrf_io.o: protos.h registry.h data.h -misc.o: protos.h registry.h data.h -my_strtok.o: registry.h protos.h data.h -reg_parse.o: registry.h protos.h data.h -registry.o: protos.h registry.h data.h Template_data.c Template_registry.c -sym.o: sym.h -type.o: registry.h protos.h data.h -gen_interp.o: registry.h protos.h data.h -gen_streams.o: registry.h protos.h data.h -gen_c_types.o: registry.h protos.h data.h diff --git a/modules/openfast-registry/src/data.h b/modules/openfast-registry/src/data.h index 80c0101bd9..bc81980c73 100644 --- a/modules/openfast-registry/src/data.h +++ b/modules/openfast-registry/src/data.h @@ -37,7 +37,7 @@ typedef struct node_struct { /* CTRL */ - int gen_wrapper ; + int gen_periodic ; struct node_struct * next ; /* fields used by rconfig nodes */ diff --git a/modules/openfast-registry/src/gen_c_types.c b/modules/openfast-registry/src/gen_c_types.c index 1e329624ce..74bd14d662 100644 --- a/modules/openfast-registry/src/gen_c_types.c +++ b/modules/openfast-registry/src/gen_c_types.c @@ -377,7 +377,10 @@ gen_c_module( FILE * fph, node_t * ModName ) fprintf(fph," %s * %s ; ",C_type( r->type->mapsto), r->name ) ; fprintf(fph," int %s_Len ;",r->name ) ; } else { - char *p = r->type->mapsto, buf[10]; + char *p = r->type->mapsto; + char buf[10]; +// bjj: this assumes all character strings are defined with numeric lengths +// It should be modified to allow use of parameters, too. (and parameters defined in the registry should also be defined in the .h file) while (*p) { if (isdigit(*p)) { long val = strtol(p, &p, 10); @@ -385,6 +388,8 @@ gen_c_module( FILE * fph, node_t * ModName ) } else { p++; } + + } if (strcmp(C_type(r->type->mapsto), "char") == 0 ){ // if it's a char we need to add the array size if (r->ndims == 0) diff --git a/modules/openfast-registry/src/gen_module_files.c b/modules/openfast-registry/src/gen_module_files.c index 8251772bfc..99834f83b5 100644 --- a/modules/openfast-registry/src/gen_module_files.c +++ b/modules/openfast-registry/src/gen_module_files.c @@ -33,13 +33,20 @@ gen_copy_c2f( FILE *fp , // *.f90 file we are writting to remove_nickname(ModName->nickname,inout,nonick) ; append_nickname((is_a_fast_interface_type(inoutlong))?ModName->nickname:"",inoutlong,addnick) ; - fprintf(fp," SUBROUTINE %s_C2Fary_Copy%s( %sData, ErrStat, ErrMsg )\n", ModName->nickname, nonick,nonick ); + fprintf(fp," SUBROUTINE %s_C2Fary_Copy%s( %sData, ErrStat, ErrMsg, SkipPointers )\n", ModName->nickname, nonick,nonick ); fprintf(fp," TYPE(%s), INTENT(INOUT) :: %sData\n" , addnick, nonick ); fprintf(fp," INTEGER(IntKi), INTENT( OUT) :: ErrStat\n" ); fprintf(fp," CHARACTER(*), INTENT( OUT) :: ErrMsg\n" ); + fprintf(fp," LOGICAL,OPTIONAL,INTENT(IN ) :: SkipPointers\n" ); fprintf(fp," ! \n" ); + fprintf(fp," LOGICAL :: SkipPointers_local\n"); fprintf(fp," ErrStat = ErrID_None\n" ); - fprintf(fp," ErrMsg = \"\"\n" ); + fprintf(fp," ErrMsg = \"\"\n\n" ); + fprintf(fp," IF (PRESENT(SkipPointers)) THEN\n"); + fprintf(fp," SkipPointers_local = SkipPointers\n"); + fprintf(fp," ELSE\n"); + fprintf(fp," SkipPointers_local = .false.\n"); + fprintf(fp," END IF\n"); sprintf(tmp,"%s",addnick) ; @@ -55,11 +62,13 @@ gen_copy_c2f( FILE *fp , // *.f90 file we are writting to } else { if ( is_pointer(r) ) { fprintf(fp,"\n ! -- %s %s Data fields\n",r->name,nonick) ; - fprintf(fp," IF ( .NOT. C_ASSOCIATED( %sData%%C_obj%%%s ) ) THEN\n",nonick,r->name) ; - fprintf(fp," NULLIFY( %sData%%%s )\n",nonick,r->name) ; - fprintf(fp," ELSE\n") ; - fprintf(fp," CALL C_F_POINTER(%sData%%C_obj%%%s, %sData%%%s, (/%sData%%C_obj%%%s_Len/))\n",nonick,r->name,nonick,r->name,nonick,r->name) ; - fprintf(fp," END IF\n") ; + fprintf(fp," IF ( .NOT. SkipPointers_local ) THEN\n"); + fprintf(fp," IF ( .NOT. C_ASSOCIATED( %sData%%C_obj%%%s ) ) THEN\n",nonick,r->name) ; + fprintf(fp," NULLIFY( %sData%%%s )\n",nonick,r->name) ; + fprintf(fp," ELSE\n") ; + fprintf(fp," CALL C_F_POINTER(%sData%%C_obj%%%s, %sData%%%s, (/%sData%%C_obj%%%s_Len/))\n",nonick,r->name,nonick,r->name,nonick,r->name) ; + fprintf(fp," END IF\n") ; + fprintf(fp, " END IF\n"); } else if (!has_deferred_dim(r, 0)) { if (!strcmp(r->type->mapsto, "REAL(ReKi)") || @@ -86,6 +95,87 @@ gen_copy_c2f( FILE *fp , // *.f90 file we are writting to return(0) ; } +int +gen_copy_f2c(FILE *fp, // *.f90 file we are writting to + const node_t *ModName, // module name + char *inout, // character string written out + char *inoutlong) // not sure what this is used for +{ + node_t *q, *r; + char tmp[NAMELEN]; + char addnick[NAMELEN]; + char nonick[NAMELEN]; + + remove_nickname(ModName->nickname, inout, nonick); + append_nickname((is_a_fast_interface_type(inoutlong)) ? ModName->nickname : "", inoutlong, addnick); + fprintf(fp, " SUBROUTINE %s_F2C_Copy%s( %sData, ErrStat, ErrMsg, SkipPointers )\n", ModName->nickname, nonick, nonick); + fprintf(fp, " TYPE(%s), INTENT(INOUT) :: %sData\n", addnick, nonick); + fprintf(fp, " INTEGER(IntKi), INTENT( OUT) :: ErrStat\n"); + fprintf(fp, " CHARACTER(*), INTENT( OUT) :: ErrMsg\n"); + fprintf(fp, " LOGICAL,OPTIONAL,INTENT(IN ) :: SkipPointers\n"); + fprintf(fp, " ! \n"); + fprintf(fp, " LOGICAL :: SkipPointers_local\n"); + fprintf(fp, " ErrStat = ErrID_None\n"); + fprintf(fp, " ErrMsg = \"\"\n\n"); + fprintf(fp, " IF (PRESENT(SkipPointers)) THEN\n"); + fprintf(fp, " SkipPointers_local = SkipPointers\n"); + fprintf(fp, " ELSE\n"); + fprintf(fp, " SkipPointers_local = .false.\n"); + fprintf(fp, " END IF\n"); + + sprintf(tmp, "%s", addnick); + + if ((q = get_entry(make_lower_temp(tmp), ModName->module_ddt_list)) == NULL) + { + fprintf(stderr, "Registry warning: generating %s_F2C_Copy%s: cannot find definition for %s\n", ModName->nickname, nonick, tmp); + } + else { + for (r = q->fields; r; r = r->next) + { + if (r->type != NULL) { + if (r->type->type_type == DERIVED) { // && ! r->type->usefrom + fprintf(stderr, "Registry WARNING: derived data type %s of type %s is not passed through F-C interface\n", r->name, r->type->name); + } + else { + if (is_pointer(r)) { + fprintf(fp, "\n ! -- %s %s Data fields\n", r->name, nonick); + fprintf(fp, " IF ( .NOT. SkipPointers_local ) THEN\n"); + fprintf(fp, " IF ( .NOT. %s(%sData%%%s)) THEN \n", assoc_or_allocated(r), nonick, r->name); + fprintf(fp, " %sData%%c_obj%%%s_Len = 0\n", nonick, r->name); + fprintf(fp, " %sData%%c_obj%%%s = C_NULL_PTR\n", nonick, r->name); + fprintf(fp, " ELSE\n"); + fprintf(fp, " %sData%%c_obj%%%s_Len = SIZE(%sData%%%s)\n", nonick, r->name, nonick, r->name); + fprintf(fp, " IF (%sData%%c_obj%%%s_Len > 0) &\n", nonick, r->name); + fprintf(fp, " %sData%%c_obj%%%s = C_LOC( %sData%%%s( LBOUND(%sData%%%s,1) ) ) \n", nonick, r->name, nonick, r->name, nonick, r->name ); + fprintf(fp, " END IF\n"); + fprintf(fp, " END IF\n"); + } + else if (!has_deferred_dim(r, 0)) { + if (!strcmp(r->type->mapsto, "REAL(ReKi)") || + !strcmp(r->type->mapsto, "REAL(SiKi)") || + !strcmp(r->type->mapsto, "REAL(DbKi)") || + !strcmp(r->type->mapsto, "REAL(R8Ki)") || + !strcmp(r->type->mapsto, "INTEGER(IntKi)") || + !strcmp(r->type->mapsto, "LOGICAL")) + { + fprintf(fp, " %sData%%C_obj%%%s = %sData%%%s\n", nonick, r->name, nonick, r->name); + } + else { // characters need to be copied differently + if (r->ndims == 0) { + //fprintf(stderr, "Registry WARNING: character data type %s of type %s is not passed through F-C interface\n", r->name, r->type->name); + fprintf(fp, " %sData%%C_obj%%%s = TRANSFER(%sData%%%s, %sData%%C_obj%%%s )\n", nonick, r->name, nonick, r->name, nonick, r->name); + } + } + } + } + } + } + } + + fprintf(fp, " END SUBROUTINE %s_F2C_Copy%s\n\n", ModName->nickname, nonick); + return(0); +} + int gen_copy( FILE * fp, const node_t * ModName, char * inout, char * inoutlong, const node_t * q_in ) @@ -190,13 +280,14 @@ gen_copy( FILE * fp, const node_t * ModName, char * inout, char * inoutlong, con fprintf(fp, " Dst%sData%%%s = Src%sData%%%s\n",nonick,r->name,nonick,r->name) ; if (sw_ccode && !is_pointer(r)){ - if (!strcmp(r->type->mapsto, "REAL(ReKi)") || - !strcmp(r->type->mapsto, "REAL(SiKi)") || - !strcmp(r->type->mapsto, "REAL(DbKi)") || - !strcmp(r->type->mapsto, "REAL(R8Ki)") || - !strcmp(r->type->mapsto, "INTEGER(IntKi)") || - !strcmp(r->type->mapsto, "LOGICAL") || - r->ndims == 0) + //if (!strcmp(r->type->mapsto, "REAL(ReKi)") || + // !strcmp(r->type->mapsto, "REAL(SiKi)") || + // !strcmp(r->type->mapsto, "REAL(DbKi)") || + // !strcmp(r->type->mapsto, "REAL(R8Ki)") || + // !strcmp(r->type->mapsto, "INTEGER(IntKi)") || + // !strcmp(r->type->mapsto, "LOGICAL") || + // r->ndims == 0) + if ( r->ndims == 0 ) // scalar of any type OR a character array { // fprintf(fp, " Dst%sData%%C_obj%%%s = Dst%sData%%%s\n", nonick, r->name, nonick, r->name); fprintf(fp, " Dst%sData%%C_obj%%%s = Src%sData%%C_obj%%%s\n", nonick, r->name, nonick, r->name); @@ -221,10 +312,10 @@ void gen_pack( FILE * fp, const node_t * ModName, char * inout, char *inoutlong ) { - char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN], addnick[NAMELEN], nonick[NAMELEN] ; - char nonick2[NAMELEN]; + char tmp[NAMELEN], tmp2[NAMELEN], addnick[NAMELEN], nonick[NAMELEN] ; + char nonick2[NAMELEN], indent[NAMELEN], mainIndent[6]; node_t *q, * r ; - int frst, d; + int frst, d, i; remove_nickname(ModName->nickname,inout,nonick) ; append_nickname((is_a_fast_interface_type(inoutlong))?ModName->nickname:"",inoutlong,addnick) ; @@ -416,26 +507,26 @@ gen_pack( FILE * fp, const node_t * ModName, char * inout, char *inoutlong ) for ( r = q->fields ; r ; r = r->next ) { - if (has_deferred_dim(r, 0)){ - // store whether the data type is allocated and the bounds of each dimension - fprintf(fp, " IF ( .NOT. %s(InData%%%s) ) THEN\n", assoc_or_allocated(r), r->name); - fprintf(fp, " IntKiBuf( Int_Xferred ) = 0\n"); // not allocated - fprintf(fp, " Int_Xferred = Int_Xferred + 1\n"); - //fprintf(fp, " IntKiBuf( Int_Xferred:Int_Xferred+2*%d-1 ) = 0\n", r->ndims, r->name); - //fprintf(fp, " Int_Xferred = Int_Xferred + 2*%d\n", r->ndims); - fprintf(fp, " ELSE\n"); - fprintf(fp, " IntKiBuf( Int_Xferred ) = 1\n"); // allocated - fprintf(fp, " Int_Xferred = Int_Xferred + 1\n"); - for (d = 1; d <= r->ndims; d++) { - fprintf(fp, " IntKiBuf( Int_Xferred ) = LBOUND(InData%%%s,%d)\n", r->name, d); - fprintf(fp, " IntKiBuf( Int_Xferred + 1) = UBOUND(InData%%%s,%d)\n", r->name, d); - fprintf(fp, " Int_Xferred = Int_Xferred + 2\n"); - } - fprintf(fp, "\n"); - sprintf(tmp3, " IF (SIZE(InData%%%s)>0)", r->name); - } - else{ - sprintf(tmp3, " "); + if (has_deferred_dim(r, 0)) { + // store whether the data type is allocated and the bounds of each dimension + fprintf(fp, " IF ( .NOT. %s(InData%%%s) ) THEN\n", assoc_or_allocated(r), r->name); + fprintf(fp, " IntKiBuf( Int_Xferred ) = 0\n"); // not allocated + fprintf(fp, " Int_Xferred = Int_Xferred + 1\n"); + //fprintf(fp, " IntKiBuf( Int_Xferred:Int_Xferred+2*%d-1 ) = 0\n", r->ndims, r->name); + //fprintf(fp, " Int_Xferred = Int_Xferred + 2*%d\n", r->ndims); + fprintf(fp, " ELSE\n"); + fprintf(fp, " IntKiBuf( Int_Xferred ) = 1\n"); // allocated + fprintf(fp, " Int_Xferred = Int_Xferred + 1\n"); + for (d = 1; d <= r->ndims; d++) { + fprintf(fp, " IntKiBuf( Int_Xferred ) = LBOUND(InData%%%s,%d)\n", r->name, d); + fprintf(fp, " IntKiBuf( Int_Xferred + 1) = UBOUND(InData%%%s,%d)\n", r->name, d); + fprintf(fp, " Int_Xferred = Int_Xferred + 2\n"); + } + fprintf(fp, "\n"); + strcpy(mainIndent, " "); + } + else { + strcpy(mainIndent, ""); } @@ -500,63 +591,55 @@ gen_pack( FILE * fp, const node_t * ModName, char * inout, char *inoutlong ) } } - else { // intrinsic data types + else { + // intrinsic data types // do all dimensions of arrays (no need for loop over i%d) - sprintf(tmp2, "SIZE(InData%%%s)", r->name); + strcpy(indent, " "); + strcat(indent, mainIndent); + for (d = r->ndims; d >= 1; d--) { + fprintf(fp, "%s DO i%d = LBOUND(InData%%%s,%d), UBOUND(InData%%%s,%d)\n", indent, d, r->name, d, r->name, d); + strcat(indent, " "); //create an indent + } + if (!strcmp(r->type->mapsto, "REAL(ReKi)") || !strcmp(r->type->mapsto, "REAL(SiKi)")) { - fprintf(fp, " %s ReKiBuf ( Re_Xferred:Re_Xferred+(%s)-1 ) = %sInData%%%s%s\n", - tmp3, (r->ndims>0) ? tmp2 : "1", (r->ndims>0) ? "PACK(" : "", r->name, (r->ndims>0) ? ",.TRUE.)" : ""); - fprintf(fp, " Re_Xferred = Re_Xferred + %s\n", (r->ndims>0) ? tmp2 : "1"); + fprintf(fp, "%s ReKiBuf(Re_Xferred) = InData%%%s%s\n", indent, r->name, dimstr(r->ndims)); + fprintf(fp, "%s Re_Xferred = Re_Xferred + 1\n", indent); } else if (!strcmp(r->type->mapsto, "REAL(DbKi)") || !strcmp(r->type->mapsto, "REAL(R8Ki)")) { - fprintf(fp, " %s DbKiBuf ( Db_Xferred:Db_Xferred+(%s)-1 ) = %sInData%%%s%s\n", - tmp3, (r->ndims>0) ? tmp2 : "1", (r->ndims>0) ? "PACK(" : "", r->name, (r->ndims>0) ? ",.TRUE.)" : ""); - fprintf(fp, " Db_Xferred = Db_Xferred + %s\n", (r->ndims>0) ? tmp2 : "1"); + fprintf(fp, "%s DbKiBuf(Db_Xferred) = InData%%%s%s\n", indent, r->name, dimstr(r->ndims)); + fprintf(fp, "%s Db_Xferred = Db_Xferred + 1\n", indent); } else if (!strcmp(r->type->mapsto, "INTEGER(IntKi)") ) { - fprintf(fp, " %s IntKiBuf ( Int_Xferred:Int_Xferred+(%s)-1 ) = %sInData%%%s%s\n", - tmp3, (r->ndims>0) ? tmp2 : "1", (r->ndims>0) ? "PACK(" : "", r->name, (r->ndims>0) ? ",.TRUE.)" : ""); - fprintf(fp, " Int_Xferred = Int_Xferred + %s\n", (r->ndims>0) ? tmp2 : "1"); + fprintf(fp, "%s IntKiBuf(Int_Xferred) = InData%%%s%s\n", indent, r->name, dimstr(r->ndims)); + fprintf(fp, "%s Int_Xferred = Int_Xferred + 1\n", indent); } else if (!strcmp(r->type->mapsto, "LOGICAL") ) { - fprintf(fp, " %s IntKiBuf ( Int_Xferred:Int_Xferred+%s-1 ) = TRANSFER(%s InData%%%s %s, IntKiBuf(1), %s)\n", - tmp3, (r->ndims>0) ? tmp2 : "1", (r->ndims>0) ? "PACK(" : "", r->name, (r->ndims>0) ? ",.TRUE.)" : "", - (r->ndims>0) ? tmp2 : "1"); - fprintf(fp, " Int_Xferred = Int_Xferred + %s\n", (r->ndims>0) ? tmp2 : "1"); + fprintf(fp, "%s IntKiBuf(Int_Xferred) = TRANSFER(InData%%%s%s, IntKiBuf(1))\n", indent, r->name, dimstr(r->ndims)); + fprintf(fp, "%s Int_Xferred = Int_Xferred + 1\n", indent); } else /*if (!strcmp(r->type->mapsto, "CHARACTER")) */{ - for (d = r->ndims; d >= 1; d--) { - fprintf(fp, " DO i%d = LBOUND(InData%%%s,%d), UBOUND(InData%%%s,%d)\n", d, r->name, d, r->name, d); - } + fprintf(fp, "%s DO I = 1, LEN(InData%%%s)\n", indent, r->name); + fprintf(fp, "%s IntKiBuf(Int_Xferred) = ICHAR(InData%%%s%s(I:I), IntKi)\n", indent, r->name, dimstr(r->ndims)); + fprintf(fp, "%s Int_Xferred = Int_Xferred + 1\n", indent); + fprintf(fp, "%s END DO ! I\n", indent); - fprintf(fp, " DO I = 1, LEN(InData%%%s)\n", r->name); - fprintf(fp, " IntKiBuf(Int_Xferred) = ICHAR(InData%%%s%s(I:I), IntKi)\n", r->name, dimstr(r->ndims)); - fprintf(fp, " Int_Xferred = Int_Xferred + 1\n"); - fprintf(fp, " END DO ! I\n"); + } - for (d = r->ndims; d >= 1; d--) { - fprintf(fp, " END DO !i%d\n",d); + for (d = r->ndims; d >= 1; d--) { + strcpy(indent, " "); + strcat(indent, mainIndent); + for (i = 1; i < d; i++) { + strcat(indent, " "); } + fprintf(fp, "%s END DO\n", indent); + } -// bjj: this works, but will produce errors about the source being smaller than the result, thus leaving garbage in some bytes -#if 0 - fprintf(fp, " IntKiBuf ( Int_Xferred:Int_Xferred+%s*LEN(InData%%%s)-1 ) = TRANSFER(%s InData%%%s %s, IntKiBuf(1), %s*LEN(InData%%%s))\n", - (r->ndims>0) ? tmp2 : "1", r->name, - (r->ndims>0) ? "PACK(" : "", r->name, (r->ndims>0) ? ",.TRUE.)" : "", - (r->ndims>0) ? tmp2 : "1", r->name); - fprintf(fp, " Int_Xferred = Int_Xferred + %s*LEN(InData%%%s)\n", (r->ndims>0) ? tmp2 : "1", r->name); -#endif - } /* - else - { - fprintf(fp, "! missing buffer for %s\n", r->name); - }*/ } if (has_deferred_dim(r, 0)){ @@ -571,9 +654,9 @@ gen_pack( FILE * fp, const node_t * ModName, char * inout, char *inoutlong ) void gen_unpack( FILE * fp, const node_t * ModName, char * inout, char * inoutlong ) { - char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN], addnick[NAMELEN], nonick[NAMELEN], nonick2[NAMELEN]; + char tmp[NAMELEN], tmp2[NAMELEN], indent[NAMELEN], addnick[NAMELEN], nonick[NAMELEN], nonick2[NAMELEN], mainIndent[6]; node_t *q, * r ; - int d ; + int d, i ; remove_nickname(ModName->nickname,inout,nonick) ; append_nickname((is_a_fast_interface_type(inoutlong))?ModName->nickname:"",inoutlong,addnick) ; @@ -599,12 +682,6 @@ gen_unpack( FILE * fp, const node_t * ModName, char * inout, char * inoutlong ) fprintf(fp," INTEGER(IntKi) :: Db_Xferred\n") ; fprintf(fp," INTEGER(IntKi) :: Int_Xferred\n") ; fprintf(fp," INTEGER(IntKi) :: i\n") ; - fprintf(fp," LOGICAL :: mask0\n"); - fprintf(fp," LOGICAL, ALLOCATABLE :: mask1(:)\n"); - fprintf(fp," LOGICAL, ALLOCATABLE :: mask2(:,:)\n"); - fprintf(fp," LOGICAL, ALLOCATABLE :: mask3(:,:,:)\n") ; - fprintf(fp," LOGICAL, ALLOCATABLE :: mask4(:,:,:,:)\n") ; - fprintf(fp," LOGICAL, ALLOCATABLE :: mask5(:,:,:,:,:)\n") ; for (d = 1; d <= q->max_ndims; d++){ fprintf(fp," INTEGER(IntKi) :: i%d, i%d_l, i%d_u ! bounds (upper/lower) for an array dimension %d\n", d, d, d, d); } @@ -659,18 +736,16 @@ gen_unpack( FILE * fp, const node_t * ModName, char * inout, char * inoutlong ) fprintf(fp, " IF (OutData%%c_obj%%%s_Len > 0) &\n", r->name); fprintf(fp, " OutData%%c_obj%%%s = C_LOC( OutData%%%s(i1_l) ) \n", r->name, r->name); } - - sprintf(tmp3, " IF (SIZE(OutData%%%s)>0)", r->name); + strcpy(mainIndent, " "); } else{ - sprintf(tmp3, " "); - for (d = 1; d <= r->ndims; d++) { fprintf(fp, " i%d_l = LBOUND(OutData%%%s,%d)\n", d, r->name, d); fprintf(fp, " i%d_u = UBOUND(OutData%%%s,%d)\n", d, r->name, d); sprintf(tmp2, ",i%d_l:i%d_u", d, d); strcat(tmp, tmp2); } + strcpy(mainIndent, ""); } if (!strcmp(r->type->name, "meshtype") || @@ -751,122 +826,73 @@ gen_unpack( FILE * fp, const node_t * ModName, char * inout, char * inoutlong ) } } - else if (r->ndims > 0){ //non-scalar intrinsic data types (arrays) - fprintf(fp, " ALLOCATE(mask%d(%s),STAT=ErrStat2)\n", r->ndims, (char*)&(tmp[1])); - fprintf(fp, " IF (ErrStat2 /= 0) THEN \n"); - fprintf(fp, " CALL SetErrStat(ErrID_Fatal, 'Error allocating mask%d.', ErrStat, ErrMsg,RoutineName)\n", r->ndims); - fprintf(fp, " RETURN\n"); - fprintf(fp, " END IF\n"); - fprintf(fp, " mask%d = .TRUE. \n", r->ndims); + else + { + strcpy(indent, " "); + strcat(indent, mainIndent); + for (d = r->ndims; d >= 1; d--) { + fprintf(fp, "%s DO i%d = LBOUND(OutData%%%s,%d), UBOUND(OutData%%%s,%d)\n", indent, d, r->name, d, r->name, d); + strcat(indent, " "); //create an indent + } - // do all dimensions of arrays (no need for loop over i%d) - sprintf(tmp2, "SIZE(OutData%%%s)", r->name); - if (!strcmp(r->type->mapsto, "REAL(ReKi)")) { - if (is_pointer(r)) { // bjj: this isn't very generic, but it's quick and will work for all current cases - fprintf(fp, " %s OutData%%%s = REAL( UNPACK(ReKiBuf( Re_Xferred:Re_Xferred+(%s)-1 ), mask%d, 0.0_ReKi ), C_FLOAT)\n", - tmp3, r->name, tmp2, r->ndims); + if (!strcmp(r->type->mapsto, "REAL(ReKi)") || + !strcmp(r->type->mapsto, "REAL(SiKi)")) { + if (sw_ccode && is_pointer(r)) { + fprintf(fp, "%s OutData%%%s%s = REAL(ReKiBuf(Re_Xferred), C_FLOAT)\n", indent, r->name, dimstr(r->ndims)); + } + else if (!strcmp(r->type->mapsto, "REAL(SiKi)")) { + fprintf(fp, "%s OutData%%%s%s = REAL(ReKiBuf(Re_Xferred), SiKi)\n", indent, r->name, dimstr(r->ndims)); } else { - fprintf(fp, " %s OutData%%%s = UNPACK(ReKiBuf( Re_Xferred:Re_Xferred+(%s)-1 ), mask%d, 0.0_ReKi )\n", - tmp3, r->name, tmp2, r->ndims); + fprintf(fp, "%s OutData%%%s%s = ReKiBuf(Re_Xferred)\n", indent, r->name, dimstr(r->ndims)); } - fprintf(fp, " Re_Xferred = Re_Xferred + %s\n", tmp2); - } - else if (!strcmp(r->type->mapsto, "REAL(SiKi)")) - { - fprintf(fp, " %s OutData%%%s = REAL( UNPACK(ReKiBuf( Re_Xferred:Re_Xferred+(%s)-1 ), mask%d, 0.0_ReKi ), SiKi)\n", - tmp3, r->name, tmp2, r->ndims); - fprintf(fp, " Re_Xferred = Re_Xferred + %s\n", tmp2); + fprintf(fp, "%s Re_Xferred = Re_Xferred + 1\n", indent); } - else if (!strcmp(r->type->mapsto, "REAL(DbKi)")) { - if (is_pointer(r)) { // bjj: this isn't very generic, but it's quick and will work for all current cases - fprintf(fp, " %s OutData%%%s = REAL( UNPACK(DbKiBuf( Db_Xferred:Db_Xferred+(%s)-1 ), mask%d, 0.0_DbKi ), C_DOUBLE)\n", - tmp3, r->name, tmp2, r->ndims); + else if (!strcmp(r->type->mapsto, "REAL(DbKi)") || + !strcmp(r->type->mapsto, "REAL(R8Ki)")) { + if (sw_ccode && is_pointer(r)) { + fprintf(fp, "%s OutData%%%s%s = REAL(DbKiBuf(Db_Xferred), C_DOUBLE)\n", indent, r->name, dimstr(r->ndims)); + } + else if (!strcmp(r->type->mapsto, "REAL(R8Ki)")) { + fprintf(fp, "%s OutData%%%s%s = REAL(DbKiBuf(Db_Xferred), R8Ki)\n", indent, r->name, dimstr(r->ndims)); } else { - fprintf(fp, " %s OutData%%%s = UNPACK(DbKiBuf( Db_Xferred:Db_Xferred+(%s)-1 ), mask%d, 0.0_DbKi )\n", - tmp3, r->name, (r->ndims > 0) ? tmp2 : "1", r->ndims); + fprintf(fp, "%s OutData%%%s%s = DbKiBuf(Db_Xferred)\n", indent, r->name, dimstr(r->ndims)); } - fprintf(fp, " Db_Xferred = Db_Xferred + %s\n", tmp2); - } - else if (!strcmp(r->type->mapsto, "REAL(R8Ki)")) - { - fprintf(fp, " %s OutData%%%s = REAL( UNPACK(DbKiBuf( Db_Xferred:Db_Xferred+(%s)-1 ), mask%d, 0.0_DbKi ), R8Ki)\n", - tmp3, r->name, tmp2, r->ndims); - fprintf(fp, " Db_Xferred = Db_Xferred + %s\n", tmp2); + fprintf(fp, "%s Db_Xferred = Db_Xferred + 1\n", indent); } else if (!strcmp(r->type->mapsto, "INTEGER(IntKi)")) { - fprintf(fp, " %s OutData%%%s = UNPACK( IntKiBuf ( Int_Xferred:Int_Xferred+(%s)-1 ), mask%d, 0_IntKi )\n", - tmp3, r->name, (r->ndims>0) ? tmp2 : "1", r->ndims); - fprintf(fp, " Int_Xferred = Int_Xferred + %s\n", tmp2); + fprintf(fp, "%s OutData%%%s%s = IntKiBuf(Int_Xferred)\n", indent, r->name, dimstr(r->ndims)); + fprintf(fp, "%s Int_Xferred = Int_Xferred + 1\n", indent); } else if (!strcmp(r->type->mapsto, "LOGICAL")) { - //fprintf(fp, " %s OutData%%%s = TRANSFER( UNPACK( IntKiBuf ( Int_Xferred:Int_Xferred+(%s)-1 ), mask%d, 0 ), OutData%%%s)\n", - fprintf(fp, " %s OutData%%%s = UNPACK( TRANSFER( IntKiBuf ( Int_Xferred:Int_Xferred+(%s)-1 ), OutData%%%s), mask%d,.TRUE.)\n", - tmp3, r->name, (r->ndims>0) ? tmp2 : "1", r->name, r->ndims); - fprintf(fp, " Int_Xferred = Int_Xferred + %s\n", tmp2); + fprintf(fp, "%s OutData%%%s%s = TRANSFER(IntKiBuf(Int_Xferred), OutData%%%s%s)\n", indent, r->name, dimstr(r->ndims), r->name, dimstr(r->ndims)); + fprintf(fp, "%s Int_Xferred = Int_Xferred + 1\n", indent); } - else /*if (!strcmp(r->type->mapsto, "CHARACTER")) */{ - - for (d = r->ndims; d >= 1; d--) { - fprintf(fp, " DO i%d = LBOUND(OutData%%%s,%d), UBOUND(OutData%%%s,%d)\n", d, r->name, d, r->name, d); - } + else /*if (!strcmp(r->type->mapsto, "CHARACTER")) */ { - fprintf(fp, " DO I = 1, LEN(OutData%%%s)\n", r->name); - fprintf(fp, " OutData%%%s%s(I:I) = CHAR(IntKiBuf(Int_Xferred))\n", r->name, dimstr(r->ndims)); - fprintf(fp, " Int_Xferred = Int_Xferred + 1\n"); - fprintf(fp, " END DO ! I\n"); + fprintf(fp, "%s DO I = 1, LEN(OutData%%%s)\n", indent, r->name); + fprintf(fp, "%s OutData%%%s%s(I:I) = CHAR(IntKiBuf(Int_Xferred))\n", indent, r->name, dimstr(r->ndims)); + fprintf(fp, "%s Int_Xferred = Int_Xferred + 1\n", indent); + fprintf(fp, "%s END DO ! I\n", indent); - for (d = r->ndims; d >= 1; d--) { - fprintf(fp, " END DO !i%d\n", d); - } - } - - fprintf(fp, " DEALLOCATE(mask%d)\n", r->ndims); - - } - else { - // scalar intrinsic data types - // do all dimensions of arrays (no need for loop over i%d) - if (!strcmp(r->type->mapsto, "REAL(ReKi)")) { - fprintf(fp, " OutData%%%s = ReKiBuf( Re_Xferred )\n", r->name); - fprintf(fp, " Re_Xferred = Re_Xferred + 1\n"); - } - else if (!strcmp(r->type->mapsto, "REAL(SiKi)")) - { - fprintf(fp, " OutData%%%s = REAL( ReKiBuf( Re_Xferred ), SiKi) \n", r->name); - fprintf(fp, " Re_Xferred = Re_Xferred + 1\n"); - } - else if (!strcmp(r->type->mapsto, "REAL(DbKi)")) { - fprintf(fp, " OutData%%%s = DbKiBuf( Db_Xferred ) \n", r->name); - fprintf(fp, " Db_Xferred = Db_Xferred + 1\n"); - } - else if (!strcmp(r->type->mapsto, "REAL(R8Ki)")) { - fprintf(fp, " OutData%%%s = REAL( DbKiBuf( Db_Xferred ), R8Ki) \n", r->name); - fprintf(fp, " Db_Xferred = Db_Xferred + 1\n"); - } - else if (!strcmp(r->type->mapsto, "INTEGER(IntKi)")) { - fprintf(fp, " OutData%%%s = IntKiBuf( Int_Xferred ) \n", r->name); - fprintf(fp, " Int_Xferred = Int_Xferred + 1\n"); } - else if (!strcmp(r->type->mapsto, "LOGICAL")) { - fprintf(fp, " OutData%%%s = TRANSFER( IntKiBuf( Int_Xferred ), mask0 )\n", r->name); - fprintf(fp, " Int_Xferred = Int_Xferred + 1\n"); - } - - else /*if (!strcmp(r->type->mapsto, "CHARACTER")) */{ - fprintf(fp, " DO I = 1, LEN(OutData%%%s)\n", r->name); - fprintf(fp, " OutData%%%s(I:I) = CHAR(IntKiBuf(Int_Xferred))\n", r->name); - fprintf(fp, " Int_Xferred = Int_Xferred + 1\n"); - fprintf(fp, " END DO ! I\n"); + for (d = r->ndims; d >= 1; d--) { + strcpy(indent, " "); + strcat(indent, mainIndent); + for (i = 1; i < d; i++) { + strcat(indent, " "); + } + fprintf(fp, "%s END DO\n", indent); } -// need to move this (scalars and strings) to the %c_obj% type, too! +// need to move scalars and strings to the %c_obj% type, too! // compare with copy routine - if (sw_ccode && !has_deferred_dim(r, 0)) { + + if (sw_ccode && !is_pointer(r) && r->ndims == 0) { if (!strcmp(r->type->mapsto, "REAL(ReKi)") || !strcmp(r->type->mapsto, "REAL(SiKi)") || !strcmp(r->type->mapsto, "REAL(DbKi)") || @@ -877,9 +903,7 @@ gen_unpack( FILE * fp, const node_t * ModName, char * inout, char * inoutlong ) fprintf(fp, " OutData%%C_obj%%%s = OutData%%%s\n", r->name, r->name); } else { // characters need to be copied differently - if (r->ndims == 0){ - fprintf(fp, " OutData%%C_obj%%%s = TRANSFER(OutData%%%s, OutData%%C_obj%%%s )\n", r->name, r->name, r->name); - } + fprintf(fp, " OutData%%C_obj%%%s = TRANSFER(OutData%%%s, OutData%%C_obj%%%s )\n", r->name, r->name, r->name); } } @@ -1000,7 +1024,7 @@ void gen_extint_order(FILE *fp, const node_t *ModName, char * typnm, char * uy, node_t *q, *r1 ; int j ; int mesh = 0 ; - char derefrecurse[NAMELEN],dex[NAMELEN],tmp[NAMELEN] ; + char derefrecurse[NAMELEN],tmp[NAMELEN] ; if ( recurselevel > MAXRECURSE ) { fprintf(stderr,"REGISTRY ERROR: too many levels of array subtypes\n") ; exit(9) ; @@ -1028,24 +1052,19 @@ void gen_extint_order(FILE *fp, const node_t *ModName, char * typnm, char * uy, } } } else if ( !strcmp( r->type->mapsto, "MeshType" ) ) { - strcpy(dex,"") ; for ( j = r->ndims ; j > 0 ; j-- ) { - fprintf(fp, " DO i%d%d = LBOUND(%s_out%s%%%s,%d),UBOUND(%s_out%s%%%s,%d)\n", 0, 1, uy, deref, r->name, j, uy, deref, r->name, j); - if ( j == r->ndims ) strcat(dex,"(") ; - sprintf(tmp,"i%d%d",0,j) ; - if ( j == 1 ) strcat(tmp,")") ; else strcat(tmp,",") ; - strcat(dex,tmp) ; + fprintf(fp, " DO i%d%d = LBOUND(%s_out%s%%%s,%d),UBOUND(%s_out%s%%%s,%d)\n", 0, j, uy, deref, r->name, j, uy, deref, r->name, j); } if ( order == 0 ) { - fprintf(fp, " CALL MeshCopy(%s(1)%s%%%s%s, %s_out%s%%%s%s, MESH_UPDATECOPY, ErrStat2, ErrMsg2 )\n", uy, deref, r->name, dex - , uy, deref, r->name, dex); + fprintf(fp, " CALL MeshCopy(%s(1)%s%%%s%s, %s_out%s%%%s%s, MESH_UPDATECOPY, ErrStat2, ErrMsg2 )\n", uy, deref, r->name, dimstr(r->ndims) + , uy, deref, r->name, dimstr(r->ndims)); } else if ( order == 1 ) { fprintf(fp," CALL MeshExtrapInterp1(%s(1)%s%%%s%s, %s(2)%s%%%s%s, tin, %s_out%s%%%s%s, tin_out, ErrStat2, ErrMsg2 )\n" - , uy, deref, r->name, dex, uy, deref, r->name, dex, uy, deref, r->name, dex); + , uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); } else if ( order == 2 ) { fprintf(fp," CALL MeshExtrapInterp2(%s(1)%s%%%s%s, %s(2)%s%%%s%s, %s(3)%s%%%s%s, tin, %s_out%s%%%s%s, tin_out, ErrStat2, ErrMsg2 )\n" - , uy, deref, r->name, dex, uy, deref, r->name, dex, uy, deref, r->name, dex, uy, deref, r->name, dex); + , uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); } fprintf(fp, " CALL SetErrStat(ErrStat2, ErrMsg2, ErrStat, ErrMsg,RoutineName)\n"); fprintf(fp, " IF (ErrStat>=AbortErrLev) RETURN\n"); @@ -1058,19 +1077,19 @@ void gen_extint_order(FILE *fp, const node_t *ModName, char * typnm, char * uy, char nonick2[NAMELEN] ; remove_nickname(r->type->module->nickname,r->type->name,nonick2) ; - strcpy(dex,"") ; + strcpy(dimstr(r->ndims),"") ; for ( j = r->ndims ; j >= 1 ; j-- ) { - fprintf(fp, " DO i%d%d = LBOUND(%s_out%s%%%s,%d), UBOUND(%s_out%s%%%s,%d)\n", 0, 1, uy, deref, r->name, j, uy, deref, r->name, j); - if ( j == r->ndims ) strcat(dex,"(") ; + fprintf(fp, " DO i%d%d = LBOUND(%s_out%s%%%s,%d), UBOUND(%s_out%s%%%s,%d)\n", 0, j, uy, deref, r->name, j, uy, deref, r->name, j); + if ( j == r->ndims ) strcat(dimstr(r->ndims),"(") ; sprintf(tmp,"i%d%d",0,j) ; if ( j == 1 ) strcat(tmp,")") ; else strcat(tmp,",") ; - strcat(dex,tmp) ; + strcat(dimstr(r->ndims),tmp) ; } fprintf(fp," CALL %s_%s_ExtrapInterp( %s%s%%%s%s, tin, %s_out%s%%%s%s, tin_out, ErrStat2, ErrMsg2 )\n", r->type->module->nickname,fast_interface_type_shortname(nonick2) - , uy, deref, r->name, dex, uy, deref, r->name, dex); + , uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); fprintf(fp," CALL SetErrStat(ErrStat2, ErrMsg2, ErrStat, ErrMsg,RoutineName)\n"); fprintf(fp," IF (ErrStat>=AbortErrLev) RETURN\n"); @@ -1139,9 +1158,9 @@ void gen_extint_order(FILE *fp, const node_t *ModName, char * typnm, char * uy, #endif void gen_extint_order(FILE *fp, const node_t *ModName, char * typnm, char * uy, const int order, node_t *r, char * deref, int recurselevel) { node_t *q, *r1; - int j; + int i, j; int mesh = 0; - char derefrecurse[NAMELEN], dex[NAMELEN], tmp[NAMELEN]; + char derefrecurse[NAMELEN], indent[NAMELEN]; if (recurselevel > MAXRECURSE) { fprintf(stderr, "REGISTRY ERROR: too many levels of array subtypes\n"); exit(9); @@ -1155,8 +1174,6 @@ void gen_extint_order(FILE *fp, const node_t *ModName, char * typnm, char * uy, } if (r->type->type_type == DERIVED) { - - if ((q = get_entry(make_lower_temp(r->type->name), ModName->module_ddt_list)) != NULL) { for (r1 = q->fields; r1; r1 = r1->next) { @@ -1175,27 +1192,22 @@ void gen_extint_order(FILE *fp, const node_t *ModName, char * typnm, char * uy, else { - strcpy(dex, ""); for (j = r->ndims; j > 0; j--) { - fprintf(fp, " DO i%d%d = LBOUND(%s_out%s%%%s,%d),UBOUND(%s_out%s%%%s,%d)\n", 0, 1, uy, deref, r->name, j, uy, deref, r->name, j); - if (j == r->ndims) strcat(dex, "("); - sprintf(tmp, "i%d%d", 0, j); - if (j == 1) strcat(tmp, ")"); else strcat(tmp, ","); - strcat(dex, tmp); + fprintf(fp, " DO i%d = LBOUND(%s_out%s%%%s,%d),UBOUND(%s_out%s%%%s,%d)\n", j, uy, deref, r->name, j, uy, deref, r->name, j); } if (!strcmp(r->type->mapsto, "MeshType")) { if (order == 0) { - fprintf(fp, " CALL MeshCopy(%s1%s%%%s%s, %s_out%s%%%s%s, MESH_UPDATECOPY, ErrStat2, ErrMsg2 )\n", uy, deref, r->name, dex - , uy, deref, r->name, dex); + fprintf(fp, " CALL MeshCopy(%s1%s%%%s%s, %s_out%s%%%s%s, MESH_UPDATECOPY, ErrStat2, ErrMsg2 )\n", uy, deref, r->name, dimstr(r->ndims) + , uy, deref, r->name, dimstr(r->ndims)); } else if (order == 1) { fprintf(fp, " CALL MeshExtrapInterp1(%s1%s%%%s%s, %s2%s%%%s%s, tin, %s_out%s%%%s%s, tin_out, ErrStat2, ErrMsg2 )\n" - , uy, deref, r->name, dex, uy, deref, r->name, dex, uy, deref, r->name, dex); + , uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); } else if (order == 2) { fprintf(fp, " CALL MeshExtrapInterp2(%s1%s%%%s%s, %s2%s%%%s%s, %s3%s%%%s%s, tin, %s_out%s%%%s%s, tin_out, ErrStat2, ErrMsg2 )\n" - , uy, deref, r->name, dex, uy, deref, r->name, dex, uy, deref, r->name, dex, uy, deref, r->name, dex); + , uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); } } else { @@ -1204,17 +1216,17 @@ void gen_extint_order(FILE *fp, const node_t *ModName, char * typnm, char * uy, if (order == 0) { fprintf(fp, " CALL %s_Copy%s(%s1%s%%%s%s, %s_out%s%%%s%s, MESH_UPDATECOPY, ErrStat2, ErrMsg2 )\n", r->type->module->nickname, fast_interface_type_shortname(nonick2) - , uy, deref, r->name, dex, uy, deref, r->name, dex); + , uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); } else if (order == 1) { fprintf(fp, " CALL %s_%s_ExtrapInterp1( %s1%s%%%s%s, %s2%s%%%s%s, tin, %s_out%s%%%s%s, tin_out, ErrStat2, ErrMsg2 )\n", r->type->module->nickname, fast_interface_type_shortname(nonick2) - , uy, deref, r->name, dex, uy, deref, r->name, dex, uy, deref, r->name, dex); + , uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); } else if (order == 2) { fprintf(fp, " CALL %s_%s_ExtrapInterp2( %s1%s%%%s%s, %s2%s%%%s%s, %s3%s%%%s%s, tin, %s_out%s%%%s%s, tin_out, ErrStat2, ErrMsg2 )\n", r->type->module->nickname, fast_interface_type_shortname(nonick2) - , uy, deref, r->name, dex, uy, deref, r->name, dex, uy, deref, r->name, dex, uy, deref, r->name, dex); + , uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); } } @@ -1230,67 +1242,59 @@ void gen_extint_order(FILE *fp, const node_t *ModName, char * typnm, char * uy, !strcmp(r->type->mapsto, "REAL(SiKi)") || !strcmp(r->type->mapsto, "REAL(R8Ki)") || !strcmp(r->type->mapsto, "REAL(DbKi)")) { - if (r->ndims == 0) { - } - else if (r->ndims == 1 && order > 0) { - fprintf(fp, " ALLOCATE(b1(SIZE(%s_out%s%%%s,1)))\n", uy, deref, r->name); - fprintf(fp, " ALLOCATE(c1(SIZE(%s_out%s%%%s,1)))\n", uy, deref, r->name); - } - else if (r->ndims == 2 && order > 0) { - fprintf(fp, " ALLOCATE(b2(SIZE(%s_out%s%%%s,1),SIZE(%s_out%s%%%s,2) ))\n", uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " ALLOCATE(c2(SIZE(%s_out%s%%%s,1),SIZE(%s_out%s%%%s,2) ))\n", uy, deref, r->name, uy, deref, r->name); - } - else if (r->ndims == 3 && order > 0) { - fprintf(fp, " ALLOCATE(b3(SIZE(%s_out%s%%%s,1),SIZE(%s_out%s%%%s,2), &\n", uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " SIZE(%s_out%s%%%s,3) ))\n", uy, deref, r->name); - fprintf(fp, " ALLOCATE(c3(SIZE(%s_out%s%%%s,1),SIZE(%s_out%s%%%s,2), &\n", uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " SIZE(%s_out%s%%%s,3) ))\n", uy, deref, r->name); - } - else if (r->ndims == 4 && order > 0) { - fprintf(fp, " ALLOCATE(b4(SIZE(%s_out%s%%%s,1),SIZE(%s_out%s%%%s,2), &\n", uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " SIZE(%s_out%s%%%s,3),SIZE(%s_out%s%%%s,4) ))\n", uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " ALLOCATE(c4(SIZE(%s_out%s%%%s,1),SIZE(%s_out%s%%%s,2), &\n", uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " SIZE(%s_out%s%%%s,3),SIZE(%s_out%s%%%s,4) ))\n", uy, deref, r->name, uy, deref, r->name); - } - else if (r->ndims == 5 && order > 0) { - fprintf(fp, " ALLOCATE(b5(SIZE(%s_out%s%%%s,1),SIZE(%s_out%s%%%s,2), &\n", uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " SIZE(%s_out%s%%%s,3),SIZE(%s_out%s%%%s,4), &\n", uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " SIZE(%s_out%s%%%s,5) ))\n", uy, deref, r->name); - fprintf(fp, " ALLOCATE(c5(SIZE(%s_out%s%%%s,1),SIZE(%s_out%s%%%s,2), &\n", uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " SIZE(%s_out%s%%%s,3),SIZE(%s_out%s%%%s,4), &\n", uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " SIZE(%s_out%s%%%s,5) ))\n", uy, deref, r->name); - } - else { - if (order > 0) fprintf(stderr, "Registry WARNING: too many dimensions for %s%%%s\n", deref, r->name); - } + if (order == 0) { + //bjj: this should probably have some "IF ALLOCATED" statements around it, but we're just calling + // the copy routine fprintf(fp, " %s_out%s%%%s = %s1%s%%%s\n", uy, deref, r->name, uy, deref, r->name); } - else if (order == 1) { - fprintf(fp, " b%d = -(%s1%s%%%s - %s2%s%%%s)/t(2)\n", r->ndims, uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " %s_out%s%%%s = %s1%s%%%s + b%d * t_out\n", uy, deref, r->name, uy, deref, r->name, r->ndims); - } - else if (order == 2) { - fprintf(fp, " b%d = (t(3)**2*(%s1%s%%%s - %s2%s%%%s) + t(2)**2*(-%s1%s%%%s + %s3%s%%%s))/(t(2)*t(3)*(t(2) - t(3)))\n", - r->ndims, uy, deref, r->name, uy, deref, r->name, uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " c%d = ( (t(2)-t(3))*%s1%s%%%s + t(3)*%s2%s%%%s - t(2)*%s3%s%%%s ) / (t(2)*t(3)*(t(2) - t(3)))\n", - r->ndims, uy, deref, r->name, uy, deref, r->name, uy, deref, r->name); - fprintf(fp, " %s_out%s%%%s = %s1%s%%%s + b%d * t_out + c%d * t_out**2\n" - , uy, deref, r->name, uy, deref, r->name, r->ndims, r->ndims); - } - if (r->ndims >= 1 && order > 0) { - fprintf(fp, " DEALLOCATE(b%d)\n", r->ndims); - fprintf(fp, " DEALLOCATE(c%d)\n", r->ndims); + else + strcpy(indent, ""); + for (j = r->ndims; j > 0; j--) { + fprintf(fp, "%s DO i%d = LBOUND(%s_out%s%%%s,%d),UBOUND(%s_out%s%%%s,%d)\n", indent, j, uy, deref, r->name, j, uy, deref, r->name, j); + strcat(indent, " "); //create an indent + } + + if (order == 1) { + if (r->gen_periodic) { + fprintf(fp, "%s CALL Angles_ExtrapInterp( %s1%s%%%s%s, %s2%s%%%s%s, tin, %s_out%s%%%s%s, tin_out )\n", + indent, uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); + } + else { + fprintf(fp, "%s b = -(%s1%s%%%s%s - %s2%s%%%s%s)\n", indent, uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); + fprintf(fp, "%s %s_out%s%%%s%s = %s1%s%%%s%s + b * ScaleFactor\n", indent, uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); + }; + } + if (order == 2) { + if (r->gen_periodic) { + fprintf(fp, "%s CALL Angles_ExtrapInterp( %s1%s%%%s%s, %s2%s%%%s%s, %s3%s%%%s%s, tin, %s_out%s%%%s%s, tin_out )\n", + indent, uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); + } + else { + fprintf(fp, "%s b = (t(3)**2*(%s1%s%%%s%s - %s2%s%%%s%s) + t(2)**2*(-%s1%s%%%s%s + %s3%s%%%s%s))* scaleFactor\n", + indent, uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); + fprintf(fp, "%s c = ( (t(2)-t(3))*%s1%s%%%s%s + t(3)*%s2%s%%%s%s - t(2)*%s3%s%%%s%s ) * scaleFactor\n", + indent, uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); + fprintf(fp, "%s %s_out%s%%%s%s = %s1%s%%%s%s + b + c * t_out\n", + indent, uy, deref, r->name, dimstr(r->ndims), uy, deref, r->name, dimstr(r->ndims)); + } + } + for (j = r->ndims; j >= 1; j--) { + strcpy(indent, ""); + for (i = 1; i < j; i++) { + strcat(indent, " "); + } + fprintf(fp, "%s END DO\n", indent); + } } - } // check if this is an allocatable array: if (r->ndims > 0 && has_deferred_dim(r, 0)) { fprintf(fp, "END IF ! check if allocated\n"); } - } -} + +} // gen_extint_order void calc_extint_order(FILE *fp, const node_t *ModName, node_t *r, int recurselevel, int *max_ndims, int *max_nrecurs, int *max_alloc_ndims) { node_t *q, *r1 ; @@ -1327,6 +1331,7 @@ void calc_extint_order(FILE *fp, const node_t *ModName, node_t *r, int recursele !strcmp(r->type->mapsto, "REAL(R8Ki)") || !strcmp(r->type->mapsto, "REAL(DbKi)")) { if (/*order > 0 &&*/ r->ndims > *max_alloc_ndims) *max_alloc_ndims = r->ndims; + if (r->ndims > *max_ndims)* max_ndims = r->ndims; } @@ -1541,11 +1546,9 @@ fprintf(fp," END IF\n") ; #endif void -gen_ExtrapInterp1(FILE *fp, const node_t * ModName, char * typnm, char * typnmlong, char * uy, const int max_ndims, const int max_nrecurs, const int max_alloc_ndims) +gen_ExtrapInterp1(FILE *fp, const node_t * ModName, char * typnm, char * typnmlong, char * xtypnm, char * uy, const int max_ndims, const int max_nrecurs, const int max_alloc_ndims, const node_t *q) { - char nonick[NAMELEN]; - char *ddtname; - node_t *q, *r; + node_t *r; int i, j; fprintf(fp, "\n"); @@ -1563,43 +1566,21 @@ gen_ExtrapInterp1(FILE *fp, const node_t * ModName, char * typnm, char * typnmlo fprintf(fp, "\n"); - fprintf(fp, " TYPE(%s_%s), INTENT(INOUT) :: %s1 ! %s at t1 > t2\n", ModName->nickname, typnmlong, uy, typnm); - fprintf(fp, " TYPE(%s_%s), INTENT(INOUT) :: %s2 ! %s at t2 \n", ModName->nickname, typnmlong, uy, typnm); - fprintf(fp, " REAL(DbKi), INTENT(IN ) :: tin(2) ! Times associated with the %ss\n", typnm); + fprintf(fp, " TYPE(%s_%s), INTENT(%s) :: %s1 ! %s at t1 > t2\n", ModName->nickname, typnmlong, (q->containsPtr == 1) ? "INOUT" : "IN", uy, typnm); + fprintf(fp, " TYPE(%s_%s), INTENT(%s) :: %s2 ! %s at t2 \n", ModName->nickname, typnmlong, (q->containsPtr == 1) ? "INOUT" : "IN", uy, typnm); + fprintf(fp, " REAL(%s), INTENT(IN ) :: tin(2) ! Times associated with the %ss\n", xtypnm, typnm); fprintf(fp, " TYPE(%s_%s), INTENT(INOUT) :: %s_out ! %s at tin_out\n", ModName->nickname, typnmlong, uy, typnm); - fprintf(fp, " REAL(DbKi), INTENT(IN ) :: tin_out ! time to be extrap/interp'd to\n"); + fprintf(fp, " REAL(%s), INTENT(IN ) :: tin_out ! time to be extrap/interp'd to\n", xtypnm); fprintf(fp, " INTEGER(IntKi), INTENT( OUT) :: ErrStat ! Error status of the operation\n"); fprintf(fp, " CHARACTER(*), INTENT( OUT) :: ErrMsg ! Error message if ErrStat /= ErrID_None\n"); fprintf(fp, " ! local variables\n"); - fprintf(fp, " REAL(DbKi) :: t(2) ! Times associated with the %ss\n", typnm); - fprintf(fp, " REAL(DbKi) :: t_out ! Time to which to be extrap/interpd\n"); + fprintf(fp, " REAL(%s) :: t(2) ! Times associated with the %ss\n", xtypnm, typnm); + fprintf(fp, " REAL(%s) :: t_out ! Time to which to be extrap/interpd\n", xtypnm); fprintf(fp, " CHARACTER(*), PARAMETER :: RoutineName = '%s_%s_ExtrapInterp1'\n", ModName->nickname, typnm); - if (max_alloc_ndims >= 0){ - fprintf(fp, " REAL(DbKi) :: b0 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi) :: c0 ! temporary for extrapolation/interpolation\n"); - if (max_alloc_ndims >= 1){ - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:) :: b1 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:) :: c1 ! temporary for extrapolation/interpolation\n"); - if (max_alloc_ndims >= 2){ - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:) :: b2 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:) :: c2 ! temporary for extrapolation/interpolation\n"); - if (max_alloc_ndims >= 3){ - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:) :: b3 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:) :: c3 ! temporary for extrapolation/interpolation\n"); - if (max_alloc_ndims >= 4){ - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:,:) :: b4 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:,:) :: c4 ! temporary for extrapolation/interpolation\n"); - if (max_alloc_ndims >= 5){ - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:,:,:):: b5 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:,:,:):: c5 ! temporary for extrapolation/interpolation\n"); - } // 5 - } // 4 - } // 3 - } // 2 - } // 1 - } // 0 + fprintf(fp, " REAL(DbKi) :: b ! temporary for extrapolation/interpolation\n"); + fprintf(fp, " REAL(DbKi) :: ScaleFactor ! temporary for extrapolation/interpolation\n"); fprintf(fp, " INTEGER(IntKi) :: ErrStat2 ! local errors\n"); fprintf(fp, " CHARACTER(ErrMsgLen) :: ErrMsg2 ! local errors\n"); for (j = 1; j <= max_ndims; j++) { @@ -1607,6 +1588,9 @@ gen_ExtrapInterp1(FILE *fp, const node_t * ModName, char * typnm, char * typnmlo fprintf(fp, " INTEGER :: i%d%d ! dim%d level %d counter variable for arrays of ddts\n", i, j, j, i); } } + for (j = 1; j <= max_ndims; j++) { + fprintf(fp, " INTEGER :: i%d ! dim%d counter variable for arrays\n", j, j); + } fprintf(fp, " ! Initialize ErrStat\n"); fprintf(fp, " ErrStat = ErrID_None\n"); @@ -1620,37 +1604,27 @@ gen_ExtrapInterp1(FILE *fp, const node_t * ModName, char * typnm, char * typnmlo fprintf(fp, " IF ( EqualRealNos( t(1), t(2) ) ) THEN\n"); fprintf(fp, " CALL SetErrStat(ErrID_Fatal, 't(1) must not equal t(2) to avoid a division-by-zero error.', ErrStat, ErrMsg,RoutineName)\n"); fprintf(fp, " RETURN\n"); - fprintf(fp, " END IF\n"); + fprintf(fp, " END IF\n\n"); + fprintf(fp, " ScaleFactor = t_out / t(2)\n"); - for (q = ModName->module_ddt_list; q; q = q->next) + for (r = q->fields; r; r = r->next) { - if (q->usefrom == 0) { - ddtname = q->name; - remove_nickname(ModName->nickname, ddtname, nonick); - if (!strcmp(nonick, make_lower_temp(typnmlong))) { - for (r = q->fields; r; r = r->next) - { - // recursive - gen_extint_order(fp, ModName, typnm, uy, 1, r, "", 0); - } - } - } + // recursive + gen_extint_order(fp, ModName, typnm, uy, 1, r, "", 0); } + fprintf(fp, " END SUBROUTINE %s_%s_ExtrapInterp1\n", ModName->nickname, typnm); fprintf(fp, "\n"); } void -gen_ExtrapInterp2(FILE *fp, const node_t * ModName, char * typnm, char * typnmlong, char * uy, const int max_ndims, const int max_nrecurs, const int max_alloc_ndims) +gen_ExtrapInterp2(FILE *fp, const node_t * ModName, char * typnm, char * typnmlong, char * xtypnm, char * uy, const int max_ndims, const int max_nrecurs, const int max_alloc_ndims, const node_t *q) { - char nonick[NAMELEN]; - char *ddtname; - node_t *q, *r; + node_t *r; int i, j; - fprintf(fp, "\n"); fprintf(fp, " SUBROUTINE %s_%s_ExtrapInterp2(%s1, %s2, %s3, tin, %s_out, tin_out, ErrStat, ErrMsg )\n", ModName->nickname, typnm, uy, uy, uy, uy); fprintf(fp, "!\n"); @@ -1667,45 +1641,23 @@ gen_ExtrapInterp2(FILE *fp, const node_t * ModName, char * typnm, char * typnmlo fprintf(fp, "!..................................................................................................................................\n"); fprintf(fp, "\n"); - - fprintf(fp, " TYPE(%s_%s), INTENT(INOUT) :: %s1 ! %s at t1 > t2 > t3\n", ModName->nickname, typnmlong, uy, typnm); - fprintf(fp, " TYPE(%s_%s), INTENT(INOUT) :: %s2 ! %s at t2 > t3\n", ModName->nickname, typnmlong, uy, typnm); - fprintf(fp, " TYPE(%s_%s), INTENT(INOUT) :: %s3 ! %s at t3\n", ModName->nickname, typnmlong, uy, typnm); - fprintf(fp, " REAL(DbKi), INTENT(IN ) :: tin(3) ! Times associated with the %ss\n", typnm); + fprintf(fp, " TYPE(%s_%s), INTENT(%s) :: %s1 ! %s at t1 > t2 > t3\n", ModName->nickname, typnmlong, (q->containsPtr == 1) ? "INOUT" : "IN", uy, typnm); + fprintf(fp, " TYPE(%s_%s), INTENT(%s) :: %s2 ! %s at t2 > t3\n", ModName->nickname, typnmlong, (q->containsPtr == 1) ? "INOUT" : "IN", uy, typnm); + fprintf(fp, " TYPE(%s_%s), INTENT(%s) :: %s3 ! %s at t3\n", ModName->nickname, typnmlong, (q->containsPtr == 1) ? "INOUT" : "IN", uy, typnm); + fprintf(fp, " REAL(%s), INTENT(IN ) :: tin(3) ! Times associated with the %ss\n", xtypnm, typnm); fprintf(fp, " TYPE(%s_%s), INTENT(INOUT) :: %s_out ! %s at tin_out\n", ModName->nickname, typnmlong, uy, typnm); - fprintf(fp, " REAL(DbKi), INTENT(IN ) :: tin_out ! time to be extrap/interp'd to\n"); - fprintf(fp, " INTEGER(IntKi), INTENT( OUT) :: ErrStat ! Error status of the operation\n"); + fprintf(fp, " REAL(%s), INTENT(IN ) :: tin_out ! time to be extrap/interp'd to\n", xtypnm); + + fprintf(fp, " INTEGER(IntKi), INTENT( OUT) :: ErrStat ! Error status of the operation\n" ); fprintf(fp, " CHARACTER(*), INTENT( OUT) :: ErrMsg ! Error message if ErrStat /= ErrID_None\n"); fprintf(fp, " ! local variables\n"); - fprintf(fp, " REAL(DbKi) :: t(3) ! Times associated with the %ss\n", typnm); - fprintf(fp, " REAL(DbKi) :: t_out ! Time to which to be extrap/interpd\n"); + fprintf(fp, " REAL(%s) :: t(3) ! Times associated with the %ss\n", xtypnm, typnm); + fprintf(fp, " REAL(%s) :: t_out ! Time to which to be extrap/interpd\n", xtypnm); fprintf(fp, " INTEGER(IntKi) :: order ! order of polynomial fit (max 2)\n"); - - if (max_alloc_ndims >= 0){ - fprintf(fp, " REAL(DbKi) :: b0 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi) :: c0 ! temporary for extrapolation/interpolation\n"); - if (max_alloc_ndims >= 1){ - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:) :: b1 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:) :: c1 ! temporary for extrapolation/interpolation\n"); - if (max_alloc_ndims >= 2){ - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:) :: b2 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:) :: c2 ! temporary for extrapolation/interpolation\n"); - if (max_alloc_ndims >= 3){ - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:) :: b3 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:) :: c3 ! temporary for extrapolation/interpolation\n"); - if (max_alloc_ndims >= 4){ - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:,:) :: b4 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:,:) :: c4 ! temporary for extrapolation/interpolation\n"); - if (max_alloc_ndims >= 5){ - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:,:,:):: b5 ! temporary for extrapolation/interpolation\n"); - fprintf(fp, " REAL(DbKi),ALLOCATABLE,DIMENSION(:,:,:,:,:):: c5 ! temporary for extrapolation/interpolation\n"); - } // 5 - } // 4 - } // 3 - } // 2 - } // 1 - } // 0 + fprintf(fp, " REAL(DbKi) :: b ! temporary for extrapolation/interpolation\n"); + fprintf(fp, " REAL(DbKi) :: c ! temporary for extrapolation/interpolation\n"); + fprintf(fp, " REAL(DbKi) :: ScaleFactor ! temporary for extrapolation/interpolation\n"); fprintf(fp, " INTEGER(IntKi) :: ErrStat2 ! local errors\n"); fprintf(fp, " CHARACTER(ErrMsgLen) :: ErrMsg2 ! local errors\n"); fprintf(fp, " CHARACTER(*), PARAMETER :: RoutineName = '%s_%s_ExtrapInterp2'\n", ModName->nickname, typnm); @@ -1714,6 +1666,9 @@ gen_ExtrapInterp2(FILE *fp, const node_t * ModName, char * typnm, char * typnmlo fprintf(fp, " INTEGER :: i%d%d ! dim%d level %d counter variable for arrays of ddts\n", i, j, j, i); } } + for (j = 1; j <= max_ndims; j++) { + fprintf(fp, " INTEGER :: i%d ! dim%d counter variable for arrays\n", j, j); + } fprintf(fp, " ! Initialize ErrStat\n"); fprintf(fp, " ErrStat = ErrID_None\n"); fprintf(fp, " ErrMsg = \"\"\n"); @@ -1733,21 +1688,16 @@ gen_ExtrapInterp2(FILE *fp, const node_t * ModName, char * typnm, char * typnmlo fprintf(fp, " ELSE IF ( EqualRealNos( t(1), t(3) ) ) THEN\n"); fprintf(fp, " CALL SetErrStat(ErrID_Fatal, 't(1) must not equal t(3) to avoid a division-by-zero error.', ErrStat, ErrMsg,RoutineName)\n"); fprintf(fp, " RETURN\n"); - fprintf(fp, " END IF\n"); + fprintf(fp, " END IF\n\n"); - for (q = ModName->module_ddt_list; q; q = q->next) + fprintf(fp, " ScaleFactor = t_out / (t(2) * t(3) * (t(2) - t(3)))\n"); + + + + for (r = q->fields; r; r = r->next) { - if (q->usefrom == 0) { - ddtname = q->name; - remove_nickname(ModName->nickname, ddtname, nonick); - if (!strcmp(nonick, make_lower_temp(typnmlong))) { - for (r = q->fields; r; r = r->next) - { - // recursive - gen_extint_order(fp, ModName, typnm, uy, 2, r, "", 0); - } - } - } + // recursive + gen_extint_order(fp, ModName, typnm, uy, 2, r, "", 0); } @@ -1757,7 +1707,7 @@ gen_ExtrapInterp2(FILE *fp, const node_t * ModName, char * typnm, char * typnmlo void -gen_ExtrapInterp(FILE *fp, const node_t * ModName, char * typnm, char * typnmlong) +gen_ExtrapInterp(FILE *fp, const node_t * ModName, char * typnm, char * typnmlong, char * xtypnm) { char nonick[NAMELEN]; char *ddtname; char uy[2]; @@ -1771,88 +1721,91 @@ gen_ExtrapInterp(FILE *fp, const node_t * ModName, char * typnm, char * typnmlon strcpy(uy, "u"); } - fprintf(fp, "\n"); - fprintf(fp, " SUBROUTINE %s_%s_ExtrapInterp(%s, t, %s_out, t_out, ErrStat, ErrMsg )\n", ModName->nickname, typnm, uy, uy); - fprintf(fp, "!\n"); - fprintf(fp, "! This subroutine calculates a extrapolated (or interpolated) %s %s_out at time t_out, from previous/future time\n", typnm, uy); - fprintf(fp, "! values of %s (which has values associated with times in t). Order of the interpolation is given by the size of %s\n", uy, uy); - fprintf(fp, "!\n"); - fprintf(fp, "! expressions below based on either\n"); - fprintf(fp, "!\n"); - fprintf(fp, "! f(t) = a\n"); - fprintf(fp, "! f(t) = a + b * t, or\n"); - fprintf(fp, "! f(t) = a + b * t + c * t**2\n"); - fprintf(fp, "!\n"); - fprintf(fp, "! where a, b and c are determined as the solution to\n"); - fprintf(fp, "! f(t1) = %s1, f(t2) = %s2, f(t3) = %s3 (as appropriate)\n", uy, uy, uy); - fprintf(fp, "!\n"); - fprintf(fp, "!..................................................................................................................................\n"); - fprintf(fp, "\n"); - - - fprintf(fp, " TYPE(%s_%s), INTENT(INOUT) :: %s(:) ! %s at t1 > t2 > t3\n", ModName->nickname, typnmlong, uy, typnm); - fprintf(fp, " REAL(DbKi), INTENT(IN ) :: t(:) ! Times associated with the %ss\n", typnm); - //jm Modified from INTENT( OUT) to INTENT(INOUT) to prevent ALLOCATABLE array arguments in the DDT - //jm from being maliciously deallocated through the call.See Sec. 5.1.2.7 of bonehead Fortran 2003 standard - fprintf(fp, " TYPE(%s_%s), INTENT(INOUT) :: %s_out ! %s at tin_out\n", ModName->nickname, typnmlong, uy, typnm); - fprintf(fp, " REAL(DbKi), INTENT(IN ) :: t_out ! time to be extrap/interp'd to\n"); - fprintf(fp, " INTEGER(IntKi), INTENT( OUT) :: ErrStat ! Error status of the operation\n"); - fprintf(fp, " CHARACTER(*), INTENT( OUT) :: ErrMsg ! Error message if ErrStat /= ErrID_None\n"); - fprintf(fp, " ! local variables\n"); - fprintf(fp, " INTEGER(IntKi) :: order ! order of polynomial fit (max 2)\n"); - fprintf(fp, " INTEGER(IntKi) :: ErrStat2 ! local errors\n"); - fprintf(fp, " CHARACTER(ErrMsgLen) :: ErrMsg2 ! local errors\n"); - fprintf(fp, " CHARACTER(*), PARAMETER :: RoutineName = '%s_%s_ExtrapInterp'\n", ModName->nickname, typnm); - fprintf(fp, " ! Initialize ErrStat\n"); - fprintf(fp, " ErrStat = ErrID_None\n"); - fprintf(fp, " ErrMsg = \"\"\n"); - fprintf(fp, " if ( size(t) .ne. size(%s)) then\n", uy); - fprintf(fp, " CALL SetErrStat(ErrID_Fatal,'size(t) must equal size(%s)',ErrStat,ErrMsg,RoutineName)\n",uy); - fprintf(fp, " RETURN\n"); - fprintf(fp, " endif\n"); - - fprintf(fp, " order = SIZE(%s) - 1\n", uy); - - fprintf(fp, " IF ( order .eq. 0 ) THEN\n"); - fprintf(fp, " CALL %s_Copy%s(%s(1), %s_out, MESH_UPDATECOPY, ErrStat2, ErrMsg2 )\n", ModName->nickname, typnm, uy, uy); - fprintf(fp, " CALL SetErrStat(ErrStat2, ErrMsg2, ErrStat, ErrMsg,RoutineName)\n"); - fprintf(fp, " ELSE IF ( order .eq. 1 ) THEN\n"); - fprintf(fp, " CALL %s_%s_ExtrapInterp1(%s(1), %s(2), t, %s_out, t_out, ErrStat2, ErrMsg2 )\n", ModName->nickname, typnm, uy, uy, uy); - fprintf(fp, " CALL SetErrStat(ErrStat2, ErrMsg2, ErrStat, ErrMsg,RoutineName)\n"); - fprintf(fp, " ELSE IF ( order .eq. 2 ) THEN\n"); - fprintf(fp, " CALL %s_%s_ExtrapInterp2(%s(1), %s(2), %s(3), t, %s_out, t_out, ErrStat2, ErrMsg2 )\n", ModName->nickname, typnm, uy, uy, uy, uy); - fprintf(fp, " CALL SetErrStat(ErrStat2, ErrMsg2, ErrStat, ErrMsg,RoutineName)\n"); - fprintf(fp, " ELSE \n"); - fprintf(fp, " CALL SetErrStat(ErrID_Fatal,'size(%s) must be less than 4 (order must be less than 3).',ErrStat,ErrMsg,RoutineName)\n", uy); - fprintf(fp, " RETURN\n"); - fprintf(fp, " ENDIF \n"); - - fprintf(fp, " END SUBROUTINE %s_%s_ExtrapInterp\n", ModName->nickname, typnm); - fprintf(fp, "\n"); - - - max_ndims = 0; // ModName->module_ddt_list->max_ndims; //bjj: this is max for module, not for typnmlong - max_nrecurs = 0; // MAXRECURSE; - max_alloc_ndims = 0; - for (q = ModName->module_ddt_list; q; q = q->next) { if (q->usefrom == 0) { ddtname = q->name; remove_nickname(ModName->nickname, ddtname, nonick); if (!strcmp(nonick, make_lower_temp(typnmlong))) { + + fprintf(fp, "\n"); + fprintf(fp, " SUBROUTINE %s_%s_ExtrapInterp(%s, t, %s_out, t_out, ErrStat, ErrMsg )\n", ModName->nickname, typnm, uy, uy); + fprintf(fp, "!\n"); + fprintf(fp, "! This subroutine calculates a extrapolated (or interpolated) %s %s_out at time t_out, from previous/future time\n", typnm, uy); + fprintf(fp, "! values of %s (which has values associated with times in t). Order of the interpolation is given by the size of %s\n", uy, uy); + fprintf(fp, "!\n"); + fprintf(fp, "! expressions below based on either\n"); + fprintf(fp, "!\n"); + fprintf(fp, "! f(t) = a\n"); + fprintf(fp, "! f(t) = a + b * t, or\n"); + fprintf(fp, "! f(t) = a + b * t + c * t**2\n"); + fprintf(fp, "!\n"); + fprintf(fp, "! where a, b and c are determined as the solution to\n"); + fprintf(fp, "! f(t1) = %s1, f(t2) = %s2, f(t3) = %s3 (as appropriate)\n", uy, uy, uy); + fprintf(fp, "!\n"); + fprintf(fp, "!..................................................................................................................................\n"); + fprintf(fp, "\n"); + + + fprintf(fp, " TYPE(%s_%s), INTENT(%s) :: %s(:) ! %s at t1 > t2 > t3\n", ModName->nickname, typnmlong, (q->containsPtr == 1) ? "INOUT" : "IN", uy, typnm); + fprintf(fp, " REAL(%s), INTENT(IN ) :: t(:) ! Times associated with the %ss\n", xtypnm, typnm); + //jm Modified from INTENT( OUT) to INTENT(INOUT) to prevent ALLOCATABLE array arguments in the DDT + //jm from being maliciously deallocated through the call.See Sec. 5.1.2.7 of bonehead Fortran 2003 standard + fprintf(fp, " TYPE(%s_%s), INTENT(INOUT) :: %s_out ! %s at tin_out\n", ModName->nickname, typnmlong, uy, typnm); + fprintf(fp, " REAL(%s), INTENT(IN ) :: t_out ! time to be extrap/interp'd to\n", xtypnm); + fprintf(fp, " INTEGER(IntKi), INTENT( OUT) :: ErrStat ! Error status of the operation\n"); + fprintf(fp, " CHARACTER(*), INTENT( OUT) :: ErrMsg ! Error message if ErrStat /= ErrID_None\n"); + fprintf(fp, " ! local variables\n"); + fprintf(fp, " INTEGER(IntKi) :: order ! order of polynomial fit (max 2)\n"); + fprintf(fp, " INTEGER(IntKi) :: ErrStat2 ! local errors\n"); + fprintf(fp, " CHARACTER(ErrMsgLen) :: ErrMsg2 ! local errors\n"); + fprintf(fp, " CHARACTER(*), PARAMETER :: RoutineName = '%s_%s_ExtrapInterp'\n", ModName->nickname, typnm); + fprintf(fp, " ! Initialize ErrStat\n"); + fprintf(fp, " ErrStat = ErrID_None\n"); + fprintf(fp, " ErrMsg = \"\"\n"); + fprintf(fp, " if ( size(t) .ne. size(%s)) then\n", uy); + fprintf(fp, " CALL SetErrStat(ErrID_Fatal,'size(t) must equal size(%s)',ErrStat,ErrMsg,RoutineName)\n",uy); + fprintf(fp, " RETURN\n"); + fprintf(fp, " endif\n"); + + fprintf(fp, " order = SIZE(%s) - 1\n", uy); + + fprintf(fp, " IF ( order .eq. 0 ) THEN\n"); + fprintf(fp, " CALL %s_Copy%s(%s(1), %s_out, MESH_UPDATECOPY, ErrStat2, ErrMsg2 )\n", ModName->nickname, typnm, uy, uy); + fprintf(fp, " CALL SetErrStat(ErrStat2, ErrMsg2, ErrStat, ErrMsg,RoutineName)\n"); + fprintf(fp, " ELSE IF ( order .eq. 1 ) THEN\n"); + fprintf(fp, " CALL %s_%s_ExtrapInterp1(%s(1), %s(2), t, %s_out, t_out, ErrStat2, ErrMsg2 )\n", ModName->nickname, typnm, uy, uy, uy); + fprintf(fp, " CALL SetErrStat(ErrStat2, ErrMsg2, ErrStat, ErrMsg,RoutineName)\n"); + fprintf(fp, " ELSE IF ( order .eq. 2 ) THEN\n"); + fprintf(fp, " CALL %s_%s_ExtrapInterp2(%s(1), %s(2), %s(3), t, %s_out, t_out, ErrStat2, ErrMsg2 )\n", ModName->nickname, typnm, uy, uy, uy, uy); + fprintf(fp, " CALL SetErrStat(ErrStat2, ErrMsg2, ErrStat, ErrMsg,RoutineName)\n"); + fprintf(fp, " ELSE \n"); + fprintf(fp, " CALL SetErrStat(ErrID_Fatal,'size(%s) must be less than 4 (order must be less than 3).',ErrStat,ErrMsg,RoutineName)\n", uy); + fprintf(fp, " RETURN\n"); + fprintf(fp, " ENDIF \n"); + + fprintf(fp, " END SUBROUTINE %s_%s_ExtrapInterp\n", ModName->nickname, typnm); + fprintf(fp, "\n"); + + + max_ndims = 0; // ModName->module_ddt_list->max_ndims; //bjj: this is max for module, not for typnmlong + max_nrecurs = 0; // MAXRECURSE; + max_alloc_ndims = 0; + for (r = q->fields; r; r = r->next) { // recursive calc_extint_order(fp, ModName, r, 0, &max_ndims, &max_nrecurs, &max_alloc_ndims); } + + gen_ExtrapInterp1(fp, ModName, typnm, typnmlong, xtypnm, uy, max_ndims, max_nrecurs, max_alloc_ndims, q); + gen_ExtrapInterp2(fp, ModName, typnm, typnmlong, xtypnm, uy, max_ndims, max_nrecurs, max_alloc_ndims, q); + } } } - gen_ExtrapInterp1(fp, ModName, typnm, typnmlong, uy, max_ndims, max_nrecurs, max_alloc_ndims); - gen_ExtrapInterp2(fp, ModName, typnm, typnmlong, uy, max_ndims, max_nrecurs, max_alloc_ndims); } @@ -2146,13 +2099,13 @@ gen_module( FILE * fp , node_t * ModName, char * prog_ver ) // bjj: we need to make sure these types map to reals, too tmp[0] = '\0' ; - if (*q->mapsto) remove_nickname( ModName->nickname, make_lower_temp(q->mapsto) , tmp ) ; + if (*q->mapsto ) remove_nickname( ModName->nickname, make_lower_temp(q->mapsto) , tmp ) ; if ( must_have_real_or_double(tmp) ) checkOnlyReals( q->mapsto, r ); } else { tmp[0] = '\0' ; - if (*q->mapsto) remove_nickname( ModName->nickname, make_lower_temp(q->mapsto) , tmp ) ; + if (*q->mapsto ) remove_nickname( ModName->nickname, make_lower_temp(q->mapsto) , tmp ) ; if ( must_have_real_or_double(tmp) ) { if ( strncmp(r->type->mapsto,"REAL",4) ) { fprintf(stderr,"Registry warning: %s contains a field (%s) whose type is not real or double: %s\n", @@ -2275,6 +2228,7 @@ gen_module( FILE * fp , node_t * ModName, char * prog_ver ) gen_unpack( fp, ModName, ddtname, ddtnamelong ) ; if ( sw_ccode ) { gen_copy_c2f( fp, ModName, ddtname, ddtnamelong ) ; + gen_copy_f2c(fp, ModName, ddtname, ddtnamelong); } } @@ -2283,9 +2237,13 @@ gen_module( FILE * fp , node_t * ModName, char * prog_ver ) // gen_modname_pack( fp, ModName ) ; // gen_modname_unpack( fp, ModName ) ; // gen_rk4( fp, ModName ) ; - if (!sw_noextrap){ - gen_ExtrapInterp( fp, ModName, "Input", "InputType" ) ; - gen_ExtrapInterp( fp, ModName, "Output", "OutputType" ) ; + + if (strcmp(make_lower_temp(ModName->name), "airfoilinfo") == 0) { // make interpolation routines for AirfoilInfo module + gen_ExtrapInterp(fp, ModName, "Output", "OutputType","ReKi"); + gen_ExtrapInterp(fp, ModName, "UA_BL_Type", "UA_BL_Type", "ReKi"); + } else if (!sw_noextrap) { + gen_ExtrapInterp(fp, ModName, "Input", "InputType", "DbKi"); + gen_ExtrapInterp(fp, ModName, "Output", "OutputType", "DbKi"); } fprintf(fp,"END MODULE %s_Types\n",ModName->name ) ; @@ -2406,6 +2364,15 @@ char * dimstr( int d ) retval = " REGISTRY ERROR TOO MANY DIMS " ; } return(retval) ; + + //strcpy(dex, ""); + //strcat(dex, "("); + //for (j = 1; j <= d; j++) { + // sprintf(tmp, "i%d%d", 0, j); + // strcat(dex, tmp); + // if (j == d) strcat(dex, ")"); else strcat(dex, ","); + //} + } char * dimstr_c( int d ) diff --git a/modules/openfast-registry/src/reg_parse.c b/modules/openfast-registry/src/reg_parse.c index 0ec9f3c7db..37d457abc2 100644 --- a/modules/openfast-registry/src/reg_parse.c +++ b/modules/openfast-registry/src/reg_parse.c @@ -95,7 +95,7 @@ pre_parse( char * dir, FILE * infile, FILE * outfile, int usefrom_sw ) // See if it might be in the current directory sprintf( include_file_name , "%s", p ) ; // first name in line from registry file, without the include or usefrom for ( p2 = include_file_name ; !( *p2 == ' ' || *p2 == '\t' || *p2 == '\n' ) && *p2 != '\0' ; p2++ ) {} - *p2 = '\0' ; // drop tailing white space + *p2 = '\0' ; // drop tailing white space if ( (q=index(include_file_name,'\n')) != NULL ) *q = '\0' ; if (( include_fp = fopen( include_file_name , "r" )) != NULL ) { foundit = 1 ; goto gotit ; } @@ -269,7 +269,7 @@ pre_parse( char * dir, FILE * infile, FILE * outfile, int usefrom_sw ) -normal: +//normal: /* otherwise output the line as is */ fprintf(outfile,"%s\n",parseline_save) ; parseline[0] = '\0' ; /* reset parseline */ @@ -284,8 +284,8 @@ reg_parse( FILE * infile ) /* Had to increase size for SOA from 4096 to 7000, Manish Shrivastava 2010 */ char inln[INLN_SIZE], parseline[PARSELINE_SIZE] ; char *p ; - char *tokens[MAXTOKENS], *ditto[MAXTOKENS] ; - int i ; + char *tokens[MAXTOKENS],*ditto[MAXTOKENS] ; + int i ; int defining_state_field, defining_rconfig_field, defining_i1_field ; parseline[0] = '\0' ; @@ -449,7 +449,6 @@ reg_parse( FILE * infile ) strcpy(field_struct->units,"-") ; if ( strcmp( tokens[FIELD_UNITS], "-" ) ) /* that is, if not equal "-" */ { strcpy( field_struct->units , tokens[FIELD_UNITS] ) ; } - #ifdef OVERSTRICT if ( field_struct->type != NULL ) if ( field_struct->type->type_type == DERIVED && field_struct->ndims > 0 ) @@ -615,27 +614,19 @@ set_dim_len ( char * dimspec , node_t * dim_entry ) int set_ctrl( char *ctrl , node_t * field_struct ) -// process CTRL keys -- only 'h' (hidden) and 'e' (exposed). Default is not to generate a wrapper, -// so something must be specified, either h or e +// process CTRL keys -- only '2pi' (interpolation of values with 2pi period). Default is no special interpolation. { - char prev = '\0' ; - char x ; char tmp[NAMELEN] ; char *p ; - int i ; strcpy(tmp,ctrl) ; if (( p = index(tmp,'=') ) != NULL ) { *p = '\0' ; } - for ( i = 0 ; i < strlen(tmp) ; i++ ) - { - x = tolower(tmp[i]) ; - if ( x == 'h' ) { - field_struct->gen_wrapper = WRAP_HIDDEN_FIELD ; - } else if ( x == 'e' ) { - field_struct->gen_wrapper = WRAP_EXPOSED_FIELD ; - } else { - field_struct->gen_wrapper = WRAP_NONE ; /* default */ - } + if (!strcmp(make_lower_temp(tmp), "2pi")) { + field_struct->gen_periodic = PERIOD_2PI; + } + else { + field_struct->gen_periodic = PERIOD_NONE; } + return(0) ; } diff --git a/modules/openfast-registry/src/registry.h b/modules/openfast-registry/src/registry.h index 0356025fb2..524bbe7e1a 100644 --- a/modules/openfast-registry/src/registry.h +++ b/modules/openfast-registry/src/registry.h @@ -23,9 +23,9 @@ enum type_type { SIMPLE , DERIVED } ; enum proc_orient { ALL_Z_ON_PROC , ALL_X_ON_PROC , ALL_Y_ON_PROC } ; /* wrapping options */ -#define WRAP_HIDDEN_FIELD 2 -#define WRAP_EXPOSED_FIELD 1 -#define WRAP_NONE 0 +#define PERIOD_2PI 2 +#define PERIOD_OTHER 1 +#define PERIOD_NONE 0 /* node_kind mask settings */