module bias_predictors !$$$ module documentation block ! . . . . ! module: bias_predictors ! prgmmr: tremolet ! ! abstract: define predictors and basic operators ! ! program history log: ! 2007-04-16 tremolet - initial code ! 2009-08-14 lueken - update documentation ! ! subroutines included: ! sub setup_predictors ! sub allocate_preds ! sub deallocate_preds ! sub assign_scalar2preds ! sub assign_preds2preds ! ! variable definitions: ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block use kinds, only: r_kind,i_kind use constants, only : izero,ione,zero implicit none save private public predictors, allocate_preds, deallocate_preds, & & assignment(=), setup_predictors type predictors real(r_kind), pointer :: values(:) => NULL() real(r_kind), pointer :: predr(:) => NULL() real(r_kind), pointer :: predp(:) => NULL() logical :: lallocated = .false. end type predictors integer(i_kind) :: nrclen,nsclen,npclen logical :: llinit = .false. ! ---------------------------------------------------------------------- INTERFACE ASSIGNMENT (=) MODULE PROCEDURE assign_scalar2preds, assign_preds2preds END INTERFACE ! ---------------------------------------------------------------------- contains ! ---------------------------------------------------------------------- subroutine setup_predictors(krclen,ksclen,kpclen) !$$$ subprogram documentation block ! . . . . ! subprogram: setup_predictors ! prgmmr: org: date: ! ! abstract: ! ! program history log: ! 2009-08-04 lueken - added subprogram doc block ! ! input argument list: ! krclen ! ksclen ! kpclen ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none integer(i_kind), intent(in ) :: krclen,ksclen,kpclen nrclen=krclen nsclen=ksclen npclen=kpclen llinit = .true. return end subroutine setup_predictors ! ---------------------------------------------------------------------- subroutine allocate_preds(yst) !$$$ subprogram documentation block ! . . . . ! subprogram: allocate_preds ! prgmmr: org: date: ! ! abstract: ! ! program history log: ! 2009-08-04 lueken - added subprogram doc block ! ! input argument list: ! yst ! ! output argument list: ! yst ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(predictors), intent(inout) :: yst integer(i_kind) :: ii if (yst%lallocated) then write(6,*) ' allocate_preds: vector already allocated' call stop2(102) end if ALLOCATE(yst%values(nrclen)) yst%values = zero ii=izero yst%predr => yst%values(ii+ione:ii+nsclen) ii=ii+nsclen yst%predp => yst%values(ii+ione:ii+npclen) ii=ii+npclen if (ii/=nrclen) then write(6,*)' allocate_preds: error length',ii,nrclen call stop2(103) end if yst%lallocated = .true. return end subroutine allocate_preds ! ---------------------------------------------------------------------- subroutine deallocate_preds(yst) !$$$ subprogram documentation block ! . . . . ! subprogram: deallocate_preds ! prgmmr: org: date: ! ! abstract: ! ! program history log: ! 2009-08-04 lueken - added subprogram doc block ! ! input argument list: ! yst ! ! output argument list: ! yst ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(predictors), intent(inout) :: yst if (yst%lallocated) then NULLIFY(yst%predr) NULLIFY(yst%predp) DEALLOCATE(yst%values) yst%lallocated = .false. else write(6,*) 'deallocate_preds warning: trying to dealloc() vector not allocated' endif return end subroutine deallocate_preds ! ---------------------------------------------------------------------- subroutine assign_scalar2preds(yst,pval) !$$$ subprogram documentation block ! . . . . ! subprogram: assign_scalar2preds ! prgmmr: org: date: ! ! abstract: ! ! program history log: ! 2009-08-04 lueken - added subprogram doc block ! ! input argument list: ! yst ! pval ! ! output argument list: ! yst ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(predictors), intent(inout) :: yst real(r_kind) , intent(in ) :: pval integer(i_kind) :: ii DO ii=1,nrclen yst%values(ii)=pval ENDDO return end subroutine assign_scalar2preds ! ---------------------------------------------------------------------- subroutine assign_preds2preds(yst,xst) !$$$ subprogram documentation block ! . . . . ! subprogram: assign_preds2preds ! prgmmr: org: date: ! ! abstract: ! ! program history log: ! 2009-08-04 lueken - added subprogram doc block ! ! input argument list: ! yst ! xst ! ! output argument list: ! yst ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block implicit none type(predictors), intent(inout) :: yst type(predictors), intent(in ) :: xst integer(i_kind) :: ii DO ii=1,nrclen yst%values(ii)=xst%values(ii) ENDDO return end subroutine assign_preds2preds ! ---------------------------------------------------------------------- end module bias_predictors