text:
!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine dfluxs(inpc,textpart,set,istartset,iendset,
     &     ialset,nset,nelemload,sideload,xload,nload,nload_,
     &     ielmat,ntmat_,iamload,
     &     amname,nam,lakon,ne,dflux_flag,istep,istat,n,iline,ipol,inl,
     &     ipoinp,inp,nam_,namtot_,namta,amta,ipoinpc,mi,idefload,
     &     iamplitudedefault,namtot,ier)
!
!     reading the input deck: *DFLUX
!
      implicit none
!
      logical dflux_flag,surface
!
      character*1 inpc(*)
      character*8 lakon(*)
      character*20 sideload(*),label
      character*80 amname(*),amplitude
      character*81 set(*),elset
      character*132 textpart(16)
!
      integer istartset(*),iendset(*),ialset(*),nelemload(2,*),mi(*),
     &     ielmat(mi(3),*),nset,nload,nload_,ntmat_,istep,istat,n,i,j,l,
     &     key,idefload(*),ier,iamload(2,*),nam,iamplitude,ipos,ne,
     &     iline,ipol,inl,ipoinp(2,*),id,
     &     inp(3,*),nam_,namtot,namtot_,namta(3,*),idelay,isector,
     &     ipoinpc(0:*),iamplitudedefault
!
      real*8 xload(2,*),xmagnitude,amta(2,*)
!
      iamplitude=iamplitudedefault
      idelay=0
      isector=0
      surface=.false.
!
      if(istep.lt.1) then
        write(*,*) '*ERROR reading *DFLUX: *DFLUX should only be used'
        write(*,*) '  within a STEP'
        ier=1
        return
      endif
!
      do i=2,n
        if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.dflux_flag)) then
          do j=1,nload
            if((sideload(j)(1:1).eq.'S').or.
     &           (sideload(j)(1:2).eq.'BF')) then
              sideload(j)(3:4)='  '
              xload(1,j)=0.d0
            endif
          enddo
        elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then
          read(textpart(i)(11:90),'(a80)') amplitude
          do j=nam,1,-1
            if(amname(j).eq.amplitude) then
              iamplitude=j
              exit
            endif
          enddo
          if(j.eq.0) then
            write(*,*)'*ERROR reading *DFLUX: nonexistent amplitude'
            write(*,*) '  '
            call inputerror(inpc,ipoinpc,iline,
     &           "*DFLUX%",ier)
            return
          endif
          iamplitude=j
        elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN
          if(idelay.ne.0) then
            write(*,*)
     &           '*ERROR reading *DFLUX: the parameter TIME DELAY'
            write(*,*) '       is used twice in the same keyword'
            write(*,*) '       '
            call inputerror(inpc,ipoinpc,iline,
     &           "*DFLUX%",ier)
            return
          else
            idelay=1
          endif
          nam=nam+1
          if(nam.gt.nam_) then
            write(*,*) '*ERROR reading *DFLUX: increase nam_'
            ier=1
            return
          endif
          amname(nam)='
     &'
          if(iamplitude.eq.0) then
            write(*,*) '*ERROR reading *DFLUX: time delay must be'
            write(*,*) '       preceded by the amplitude parameter'
            ier=1
            return
          endif
          namta(3,nam)=sign(iamplitude,namta(3,iamplitude))
          iamplitude=nam
          namtot=namtot+1
          if(namtot.gt.namtot_) then
            write(*,*) '*ERROR dfluxes: increase namtot_'
            ier=1
            return
          endif
          namta(1,nam)=namtot
          namta(2,nam)=namtot
          read(textpart(i)(11:30),'(f20.0)',iostat=istat)
     &         amta(1,namtot)
          if(istat.gt.0) then
            call inputerror(inpc,ipoinpc,iline,
     &           "*DFLUX%",ier)
            return
          endif
        else
          write(*,*)
     &         '*WARNING reading *DFLUX: parameter not recognized:'
          write(*,*) '         ',
     &         textpart(i)(1:index(textpart(i),' ')-1)
          call inputwarning(inpc,ipoinpc,iline,
     &         "*DFLUX%")
        endif
      enddo
!
      do
        call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
     &       ipoinp,inp,ipoinpc)
        if((istat.lt.0).or.(key.eq.1)) return
!
        read(textpart(2)(1:20),'(a20)',iostat=istat) label
!
!     compatibility with ABAQUS for shells
!
        if(label(2:4).eq.'NEG') label(2:4)='1  '
        if(label(2:4).eq.'POS') label(2:4)='2  '
!
!     for plane stress elements: 'N' and 'P' are converted
!     into '5' and '6' and further down in '1' and '2'
!
        if(label(2:2).eq.'N') label(2:2)='5'
        if(label(2:2).eq.'P') label(2:2)='6'
!
        read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagnitude
!
        if(istat.gt.0) then
          call inputerror(inpc,ipoinpc,iline,
     &         "*DFLUX%",ier)
          return
        endif
        if(((label(1:2).ne.'S1').and.(label(1:2).ne.'S2').and.
     &       (label(1:2).ne.'S0').and.
     &       (label(1:2).ne.'S3').and.(label(1:2).ne.'S4').and.
     &       (label(1:2).ne.'S5').and.(label(1:2).ne.'S6').and.
     &       (label(1:2).ne.'BF').and.(label(1:2).ne.'S ')).or.
     &       ((label(3:4).ne.'  ').and.(label(3:4).ne.'NU'))) then
          call inputerror(inpc,ipoinpc,iline,
     &         "*DFLUX%",ier)
          return
        endif
!
        read(textpart(1)(1:10),'(i10)',iostat=istat) l
        if(istat.eq.0) then
          if(l.gt.ne) then
            write(*,*) '*ERROR reading *DFLUX: element ',l
            write(*,*) '       is not defined'
            ier=1
            return
          endif
!
          if((lakon(l)(1:2).eq.'CP').or.
     &         (lakon(l)(2:2).eq.'A').or.
     &         (lakon(l)(7:7).eq.'E').or.
     &         (lakon(l)(7:7).eq.'S').or.
     &         (lakon(l)(7:7).eq.'A')) then
            if(label(1:2).eq.'S1') then
              label(1:2)='S3'
            elseif(label(1:2).eq.'S2') then
              label(1:2)='S4'
            elseif(label(1:2).eq.'S3') then
              label(1:2)='S5'
            elseif(label(1:2).eq.'S4') then
              label(1:2)='S6'
            elseif(label(1:2).eq.'S5') then
              label(1:2)='S1'
            elseif(label(1:2).eq.'S6') then
              label(1:2)='S2'
            endif
c          elseif((lakon(l)(1:1).eq.'B').or.
c     &           (lakon(l)(7:7).eq.'B')) then
c          elseif((lakon(l)(1:1).eq.'S').or.
c     &           (lakon(l)(7:7).eq.'L')) then
          endif
          call loadadd(l,label,xmagnitude,nelemload,sideload,
     &         xload,nload,nload_,iamload,iamplitude,
     &         nam,isector,idefload)
        else
          read(textpart(1)(1:80),'(a80)',iostat=istat) elset
          elset(81:81)=' '
          ipos=index(elset,' ')
          elset(ipos:ipos)='E'
c          do i=1,nset
c            if(set(i).eq.elset) exit
c          enddo
          call cident81(set,elset,nset,id)
          i=nset+1
          if(id.gt.0) then
            if(elset.eq.set(id)) then
              i=id
            endif
          endif
          if(i.gt.nset) then
!
!     check for facial surface
!
            surface=.true.
            elset(ipos:ipos)='T'
c            do i=1,nset
c              if(set(i).eq.elset) exit
c            enddo
            call cident81(set,elset,nset,id)
            i=nset+1
            if(id.gt.0) then
              if(elset.eq.set(id)) then
                i=id
              endif
            endif
            if(i.gt.nset) then
              elset(ipos:ipos)=' '
              write(*,*) '*ERROR reading *DFLUX: element set '
              write(*,*) '       or facial surface ',elset
              write(*,*) '       has not yet been defined. '
              call inputerror(inpc,ipoinpc,iline,
     &             "*DFLUX%",ier)
              return
            endif
          endif
!
          l=ialset(istartset(i))
          if(surface) then
            write(label(2:2),'(i1)') l-10*(l/10)
            l=l/10
          endif
!
          if((lakon(l)(1:2).eq.'CP').or.
     &         (lakon(l)(2:2).eq.'A').or.
     &         (lakon(l)(7:7).eq.'E').or.
     &         (lakon(l)(7:7).eq.'S').or.
     &         (lakon(l)(7:7).eq.'A')) then
            if(label(1:2).eq.'S1') then
              label(1:2)='S3'
            elseif(label(1:2).eq.'S2') then
              label(1:2)='S4'
            elseif(label(1:2).eq.'S3') then
              label(1:2)='S5'
            elseif(label(1:2).eq.'S4') then
              label(1:2)='S6'
            elseif(label(1:2).eq.'S5') then
              label(1:2)='S1'
            elseif(label(1:2).eq.'S6') then
              label(1:2)='S2'
            endif
c          elseif((lakon(l)(1:1).eq.'B').or.
c     &           (lakon(l)(7:7).eq.'B')) then
c          elseif((lakon(l)(1:1).eq.'S').or.
c     &           (lakon(l)(7:7).eq.'L')) then
          endif
          do j=istartset(i),iendset(i)
            if(ialset(j).gt.0) then
              l=ialset(j)
              if(surface) then
                write(label(2:2),'(i1)') l-10*(l/10)
                l=l/10
              endif
              call loadadd(l,label,xmagnitude,nelemload,sideload,
     &             xload,nload,nload_,iamload,iamplitude,
     &             nam,isector,idefload)
            else
              l=ialset(j-2)
              do
                l=l-ialset(j)
                if(l.ge.ialset(j-1)) exit
                call loadadd(l,label,xmagnitude,nelemload,
     &               sideload,xload,nload,nload_,
     &               iamload,iamplitude,nam,isector,idefload)
              enddo
            endif
          enddo
        endif
      enddo
!
      return
      end

max_stars_repo_name: alleindrach/calculix-desktop

max_issues_repo_name: alleindrach/calculix-desktop

max_forks_repo_name: alleindrach/calculix-desktop


text:
! This file is part of DASH.
! SPDX-Identifier: MIT
!
! Copyright 2003 Cambridge Crystallographic Data Centre
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
!*****************************************************************************
!
      SUBROUTINE DealWithWizardWindowSingleCrystalData1

      USE WINTERACTER
      USE dash_gui_resources
      USE VARIABLES

      IMPLICIT NONE

      INCLUDE 'Lattice.inc'

      LOGICAL, EXTERNAL :: Confirm

      CALL PushActiveWindowID
      CALL SelectDASHDialog(IDD_SX_Page1)
      SELECT CASE (EventType)
        CASE (PushButton) ! one of the buttons was pushed
          SELECT CASE (EventInfo%VALUE1)
            CASE (IDCLOSE, IDCANCEL)
              CALL EndWizard
              CALL Download_SpaceGroup(IDD_SX_Page1)
              CALL Download_Cell_Constants(IDD_SX_Page1)
            CASE (IDBACK)
              CALL Download_SpaceGroup(IDD_SX_Page1)
              CALL Download_Cell_Constants(IDD_SX_Page1)
              CALL WizardWindowShow(IDD_Polyfitter_Wizard_01)
            CASE (IDNEXT)
              CALL Download_SpaceGroup(IDD_PW_Page1)
              CALL Download_Cell_Constants(IDD_PW_Page1)
              CALL CheckUnitCellConsistency
              IF (NumberSGTable .EQ. LPosSG(LatBrav)) CALL WarningMessage('Space-group symmetry has not been reset.')
              CALL WizardWindowShow(IDD_SX_Page1a)
            CASE (IDAPPLY)
              CALL Download_SpaceGroup(IDD_SX_Page1)
              CALL Download_Cell_Constants(IDD_SX_Page1)
              CALL CheckUnitCellConsistency
            CASE (IDB_Delabc)
              CALL Clear_UnitCell_WithConfirmation
            CASE (IDBBROWSE) ! Read unit cell
              CALL UnitCellParametersFileBrowse
          END SELECT
        CASE (FieldChanged)
          SELECT CASE (EventInfo%VALUE1)
            CASE (IDF_a_latt)
              CALL DASHWDialogGetReal(IDF_a_latt, CellPar(1))
              CALL UpdateCell
              CALL CheckUnitCellConsistency
            CASE (IDF_b_latt)
              CALL DASHWDialogGetReal(IDF_b_latt, CellPar(2))
              CALL UpdateCell
              CALL CheckUnitCellConsistency
            CASE (IDF_c_latt)
              CALL DASHWDialogGetReal(IDF_c_latt, CellPar(3))
              CALL UpdateCell
              CALL CheckUnitCellConsistency
            CASE (IDF_alp_latt)
              CALL DASHWDialogGetReal(IDF_alp_latt, CellPar(4))
              CALL UpdateCell
              CALL CheckUnitCellConsistency
            CASE (IDF_bet_latt)
              CALL DASHWDialogGetReal(IDF_bet_latt, CellPar(5))
              CALL UpdateCell
              CALL CheckUnitCellConsistency
            CASE (IDF_gam_latt)
              CALL DASHWDialogGetReal(IDF_gam_latt, CellPar(6))
              CALL UpdateCell
              CALL CheckUnitCellConsistency
            CASE (IDF_Crystal_System_Menu)
              CALL DASHWDialogGetMenu(IDF_Crystal_System_Menu, LatBrav)
              CALL Upload_CrystalSystem
              CALL Generate_TicMarks
            CASE (IDF_Space_Group_Menu)
              CALL Download_SpaceGroup(IDD_SX_Page1)
              CALL Generate_TicMarks
          END SELECT
      END SELECT
      CALL PopActiveWindowID

      END SUBROUTINE DealWithWizardWindowSingleCrystalData1
!
!*****************************************************************************
!
      SUBROUTINE DealWithWizardWindowSingleCrystalData1a ! Resolution

      USE WINTERACTER
      USE dash_gui_resources
      USE VARIABLES

      IMPLICIT NONE

      LOGICAL ELECDI
      COMMON /USEELE / ELECDI

      LOGICAL, EXTERNAL :: DASHWDialogGetCheckBoxLogical

      CALL PushActiveWindowID
      CALL SelectDASHDialog(IDD_SX_Page1a)
      SELECT CASE (EventType)
        CASE (PushButton) ! one of the buttons was pushed
          SELECT CASE (EventInfo%VALUE1)
            CASE (IDCLOSE, IDCANCEL)
              CALL EndWizard
            CASE (IDBACK)
              CALL WizardWindowShow(IDD_SX_Page1)
            CASE (IDNEXT)
              CALL SelectDASHDialog(IDD_ViewPawley)
              CALL WDialogPutReal(IDF_MaxResolution, SXMaxResolution)
              CALL SelectDASHDialog(IDD_SX_Page2)
!              ELECDI = DASHWDialogGetCheckBoxLogical(IDF_ElectronDiffraction)
              CALL WDialogFieldStateLogical(IDNEXT, .FALSE.)
              PastPawley = .TRUE.

              CALL WizardWindowShow(IDD_SX_Page2)
          END SELECT
      END SELECT
      CALL PopActiveWindowID

      END SUBROUTINE DealWithWizardWindowSingleCrystalData1a
!
!*****************************************************************************
!
      SUBROUTINE DealWithWizardWindowSingleCrystalData2

      USE WINTERACTER
      USE dash_gui_resources
      USE VARIABLES

      IMPLICIT NONE

      INCLUDE 'GLBVAR.INC'
      INCLUDE 'Lattice.inc'

      INTEGER, EXTERNAL :: HKLFFileBrowse, HKLFFileOpen
      LOGICAL, EXTERNAL :: SaveProject
      CHARACTER(LEN=MaxPathLength) CTEMP
      INTEGER iErr

      CALL PushActiveWindowID
      CALL SelectDASHDialog(IDD_SX_Page2)
      SELECT CASE (EventType)
        CASE (PushButton) ! one of the buttons was pushed
          SELECT CASE (EventInfo%VALUE1)
            CASE (IDBACK)
              CALL WizardWindowShow(IDD_SX_Page1a)
            CASE (IDNEXT)
              IF (SaveProject()) CALL ShowWizardWindowZmatrices
            CASE (IDCANCEL, IDCLOSE)
              CALL EndWizard
            CASE (ID_PW_DF_Open)
              CALL DASHWDialogGetString(IDF_PW_DataFileName_String, CTEMP)
              iErr = HKLFFileOpen(CTEMP)
              CALL WDialogFieldStateLogical(IDNEXT, iErr .EQ. 0)
            CASE (IDBBROWSE)
              iErr = HKLFFileBrowse()
! Don't change if the user pressed 'Cancel' (ISTAT = 2)
              IF      (iErr .EQ. 0) THEN
                CALL WDialogFieldState(IDNEXT, Enabled)
              ELSE IF (iErr .EQ. 1) THEN
                CALL WDialogFieldState(IDNEXT, Disabled)
              ENDIF
          END SELECT
      END SELECT
      CALL PopActiveWindowID

      END SUBROUTINE DealWithWizardWindowSingleCrystalData2
!
!*****************************************************************************
!
      INTEGER FUNCTION HKLFFileBrowse()
!
! This routine lets the user browse a directory for an HKLF file.
! If a valid file has been selected, it will be opened automatically.
! Effectively, this routine is just a wrap around a file_open routine
! such that it lets the user visually select a file first.
!
! 0 = OK
! 1 = error
! 2 = user pressed cancel.
!
      USE WINTERACTER
      USE VARIABLES

      IMPLICIT NONE

      INTEGER, EXTERNAL :: HKLFFileOpen
      CHARACTER(LEN=60) FILTER
      INTEGER           IFLAGS, IFTYPE
      CHARACTER(LEN=MaxPathLength) tFileName

      HKLFFileBrowse = 1
      IFLAGS = LoadDialog + DirChange + PromptOn + AppendExt
      FILTER = ALL_FILES_FILTER//&
               'SHELX .hkl files (*.hkl)|*.hkl|'
      tFileName = ' '
! IFTYPE specifies which of the file types in the list is the default
      IFTYPE = 2
      CALL WSelectFile(FILTER,IFLAGS,tFileName,'Open single crystal data file',IFTYPE)
! Did the user press cancel?
      IF (WInfoDialog(ExitButtonCommon) .NE. CommonOK) THEN
        HKLFFileBrowse = 2
        RETURN
      ENDIF
! Note that up to this point, none of the global variables had changed. Baling out was no problem.
! Try to open the file. This can be removed, of course, and relocated to places in the code where
! the current subroutine is called.
! Actually, that is how it works in practice under Windows (try 'Start' -> 'Run...' -> 'Browse...'
! it will not actually open the file, just select it).
      HKLFFileBrowse = HKLFFileOpen(tFileName)

      END FUNCTION HKLFFileBrowse
!
!*****************************************************************************
!
      INTEGER FUNCTION HKLFFileOpen(TheFileName)
!
! This routine tries to open an HKLF file.
!
! INPUT   : TheFileName = the file name
!
! 0 = OK
! 1 = error
!
      USE dash_gui_resources
      USE WINTERACTER
      USE VARIABLES

      IMPLICIT NONE

      CHARACTER*(*), INTENT (IN   ) :: TheFileName

      INTEGER, EXTERNAL :: HKLFFileLoad
      LOGICAL FExists
      INTEGER KLEN

      HKLFFileOpen = 1
      KLEN = LEN_TRIM(TheFileName)
      IF (KLEN .EQ. 0) RETURN
      INQUIRE(FILE=TheFileName(1:KLEN),EXIST=FExists)
      IF (.NOT. FExists) THEN
        CALL ErrorMessage("The file "//TheFileName(1:KLEN)//" does not exist!")
        RETURN
      ENDIF
! This is the point of no return: the selected file will be new file, valid data or not
! Change global variable FNAME
      FNAME = TheFileName
      IF (HKLFFileLoad(FNAME(1:KLEN)) .NE. 0) RETURN
! Next line is necessary due to the way ScrUpdateFileName in SDIFileLoad works
      FNAME = TheFileName
      IF (NoData) THEN
        CALL ErrorMessage("Could not read the hkl file "//FNAME(1:KLEN)//&
                          CHAR(13)//"successfully.")
        RETURN
      ENDIF
! Disable Pawley refinement button
      CALL SetModeMenuState(-1,-1)
      CALL WindowOutStatusBar(1, FNAME)

      ! @@ ??
! Update the file name
      CALL SelectDASHDialog(IDD_SX_Page2)
      CALL WDialogPutString(IDF_PW_DataFileName_String, FNAME(1:KLEN))
      HKLFFileOpen = 0

      END FUNCTION HKLFFileOpen
!
!*****************************************************************************
!
      INTEGER FUNCTION HKLFFileLoad(TheFileName)
!
! Gets single crystal data and generates a false diffraction pattern
!
! 0 = OK
! 1 = error
!
      USE dash_gui_resources
      USE VARIABLES
      USE ATMVAR
      USE REFVAR

      IMPLICIT NONE

      CHARACTER*(*), INTENT (IN   ) :: TheFileName

      INCLUDE 'params.inc'
      INCLUDE 'GLBVAR.INC'

      REAL            PI, RAD, DEG, TWOPI, FOURPI, PIBY2, ALOG2, SQL2X8, VALMUB
      COMMON /CONSTA/ PI, RAD, DEG, TWOPI, FOURPI, PIBY2, ALOG2, SQL2X8, VALMUB

      INTEGER         KKOR
      REAL                  WTIJ
      INTEGER                             IKKOR,         JKKOR
      COMMON /CHISTO/ KKOR, WTIJ(MCHIHS), IKKOR(MCHIHS), JKKOR(MCHIHS)

      INTEGER         jHKL
      REAL                            WTJ,         AJOBS
      COMMON /SXFSTO/ jHKL(3,MFCSTO), WTJ(MFCSTO), AJOBS(MFCSTO)

      INTEGER          NFITA, IFITA
      REAL                                 WTSA
      COMMON /CHISTOP/ NFITA, IFITA(MOBS), WTSA(MOBS)

      INTEGER          NBIN, LBIN
      REAL                         XBIN,       YOBIN,       YCBIN,       YBBIN,       EBIN
      COMMON /PROFBIN/ NBIN, LBIN, XBIN(MOBS), YOBIN(MOBS), YCBIN(MOBS), YBBIN(MOBS), EBIN(MOBS)

      INTEGER         KNIPT
      REAL                            PIKVAL
      COMMON /FPINF1/ KNIPT(MaxKTem,MOBS), PIKVAL(MaxKTem,MOBS)

      INTEGER         KREFT
      COMMON /FPINF2/ KREFT(MOBS)

      REAL             PAWLEYCHISQ, RWPOBS, RWPEXP
      COMMON /PRCHISQ/ PAWLEYCHISQ, RWPOBS, RWPEXP

      LOGICAL           Is_SX
      COMMON  / SXCOM / Is_SX

      LOGICAL, EXTERNAL :: DASHWDialogGetCheckBoxLogical
      INTEGER ISIG5, IArgKK
      INTEGER KXIMIN(MOBS), KXIMAX(MOBS)
      INTEGER KK, I, NLIN, iR, jR, J, K, hFile
      INTEGER KTEM, K1, K2
      REAL    ARGIMIN, ARGIMAX, ARGISTP, ARGT, FWHM, C0, Gaussian !, Lorentzian
      CHARACTER*150 LINE
      LOGICAL RecalculateESDs, IgnoreLT, AvgFriedelPairs
      REAL    CutOff
      LOGICAL Keep(1:MFCSTO)

      HKLFFileLoad = 1
      hFile = 121
      CALL PushActiveWindowID
      CALL SelectDASHDialog(IDD_SX_Page2)
      RecalculateESDs = DASHWDialogGetCheckBoxLogical(IDF_RecalcESDs)
      IgnoreLT = DASHWDialogGetCheckBoxLogical(IDF_IgnLT)
      IF (IgnoreLT) CALL DASHWDialogGetReal(IDF_CutOff, CutOff)
      AvgFriedelPairs = DASHWDialogGetCheckBoxLogical(IDF_AvgFriedelPairs)
      CALL PopActiveWindowID
      Is_SX = .TRUE.
      OPEN(hFile, FILE=TheFileName, STATUS='OLD', ERR=998)
      iR = 1
      DO KK = 1, MFCSTO
        READ(hFile, '(A)', END=100, ERR=998) LINE
        NLIN = LEN_TRIM(LINE)
        IF (LEN_TRIM(LINE) .NE. 0) THEN
!C SHELX .hkl files are terminated by a line containing h = k = l = 0 or h = k = l = 99
          READ(LINE(1:NLIN), *, END=998, ERR=998) (jHKL(I,iR),I=1,3)
          IF (((jHKL(1,iR) .EQ.  0) .AND. &
               (jHKL(2,iR) .EQ.  0) .AND. &
               (jHKL(3,iR) .EQ.  0)) .OR. &
              ((jHKL(1,iR) .EQ. 99) .AND. &
               (jHKL(2,iR) .EQ. 99) .AND. &
               (jHKL(3,iR) .EQ. 99)))     &
               GOTO 100
!C No cross correlation ...
          READ(LINE(1:NLIN), *, END=998, ERR=998) (jHKL(I,iR),I=1,3), AJOBS(iR), WTJ(iR)
!C F2 and sig(F2)
          IF (RecalculateESDs) WTJ(iR) = MAX(MAX(4.4, SQRT(MAX(0.0, AJOBS(iR)))), WTJ(iR))
          IF (.NOT. (IgnoreLT .AND. ((AJOBS(iR)/WTJ(iR)) .LT. CutOff))) THEN
            WTJ(iR) = 1.0 / WTJ(iR)
            iR = iR + 1
          ENDIF
        ENDIF
      ENDDO
  100 NumOfRef = iR-1
      IF (NumOfRef .EQ. 0) THEN
        CALL ErrorMessage("No reflections found.")
        RETURN
      ENDIF
! Average Friedel related pairs
      DO iR = 1, NumOfRef
        Keep(iR) = .TRUE.
      ENDDO
      IF (AvgFriedelPairs) THEN
        DO iR = 1, NumOfRef-1
          IF (Keep(iR)) THEN
            DO jR = iR+1, NumOfRef
              IF (Keep(jR)) THEN
                IF (((jHKL(1,iR) .EQ. -jHKL(1,jR)) .AND. &
                     (jHKL(2,iR) .EQ. -jHKL(2,jR)) .AND. &
                     (jHKL(3,iR) .EQ. -jHKL(3,jR))) .OR. &
                    ((jHKL(1,iR) .EQ.  jHKL(1,jR)) .AND. &
                     (jHKL(2,iR) .EQ.  jHKL(2,jR)) .AND. &
                     (jHKL(3,iR) .EQ.  jHKL(3,jR)))) THEN
                  AJOBS(iR) = (AJOBS(iR) + AJOBS(jR)) / 2.0
                  WTJ(iR) = 1.0/SQRT((1.0/WTJ(iR))**2 + (1.0/WTJ(jR))**2)
                  Keep(jR) = .FALSE.
                ENDIF
              ENDIF
            ENDDO
          ENDIF
        ENDDO
      ENDIF
!C We've got the lattice constants, symmetry etc. already.
!C Let's order the reflections in increasing 2 theta and fill the array ArgKK
      CALL OrderReflections(Keep)
      DO iR = 1, NumOfRef
        IKKOR(iR) = iR
        JKKOR(iR) = iR
      ENDDO
      KKOR = NumOfRef
      DO iR = 1, NumOfRef
!C No correlation, so II .EQ. JJ by definition.
        WTIJ(iR) = WTI(iR) * WTI(iR)
      ENDDO
      CLOSE(hFile)
!C Now synthesise a simple diffraction pattern at 1 Angstrom
      NBIN = 5000
      ARGIMIN = RefArgK(1)-1.0
      ARGIMAX = RefArgK(NumOfRef)+1.0
      ARGISTP = (ARGIMAX-ARGIMIN)/FLOAT(NBIN-1)
      FWHM = 6.0 * ARGISTP
      C0 = 4.0 * LOG(2.0)
      ISIG5 = 30
      DO I = 1, NBIN
        KXIMIN(I) = 0
      ENDDO
      DO K = 1, NumOfRef
        IArgKK = 1 + NINT((RefArgK(K)-ARGIMIN)/ARGISTP)
        DO I = MAX(1, IArgKK-ISIG5), MIN(5000, IArgKK+ISIG5)
          IF (KXIMIN(I) .EQ. 0) KXIMIN(I) = K
          KXIMAX(I) = K
        ENDDO
      ENDDO
      NFITA = 0
      DO I = 1, NBIN
        XBIN(I) = ARGIMIN + FLOAT(I-1)*ARGISTP
        YOBIN(I) = 0.0
        YCBIN(I) = 0.0
        YBBIN(I) = 0.0
        EBIN(I)  = 0.0
        IF (KXIMIN(I) .EQ. 0) THEN
!C No peaks at this point
          EBIN(I) = 1.0
          WTSA(I) = 1.0
          KREFT(I) = 0
        ELSE
          NFITA = NFITA + 1
          IFITA(NFITA) = I
          KREFT(I) = MIN(MaxPik, 1 + KXIMAX(I) - KXIMIN(I))
          J = 0
          DO K = KXIMIN(I), KXIMAX(I)
            ARGT = (XBIN(I)-RefArgK(K)) / (FWHM)
            J = J + 1
!C JCC - needs bound check on J here
            IF ( J .GT. MaxPik ) GOTO 567

            KNIPT(J,I) = K
            Gaussian = (SQRT(C0)/(FWHM*SQRT(PI))) * EXP(-C0*(ARGT**2))
        !    Lorentzian = (2.0/(PI*FWHM)) * (1.0/(1.0+(4.0*(ARGT**2))))
            ! Now use a pseudo-Voigt
            PIKVAL(J,I) =  Gaussian !0.125*Lorentzian + 0.875*Gaussian
            YOBIN(I) = YOBIN(I) + AIOBS(K)*PIKVAL(J,I)
          ENDDO
          EBIN(I) = MAX(1.0, 0.1*ABS(YOBIN(I)))
          WTSA(I) = 1.0 / EBIN(I)**2
        ENDIF
      ENDDO
!C Write out a fake .pik file
      OPEN(UNIT=hFile, FILE='polyp.pik', STATUS='UNKNOWN', ERR=999)
      DO I = 1, NBIN
        KTEM = KREFT(I)
        WRITE(hFile,*) XBIN(I), YOBIN(I), EBIN(I), KTEM
        K1 = KXIMIN(I)
        K2 = KXIMAX(I)
        IF (KTEM.GT.0) WRITE (hFile,*) (KNIPT(KK,I),PIKVAL(KK,I),KK=1,KTEM)
      ENDDO
      CLOSE(hFile)
!C Write out a fake .hcv file
      OPEN(UNIT=hFile, FILE='polyp.hcv', STATUS='UNKNOWN', ERR=999)
      DO iR = 1, NumOfRef
        WRITE(hFile,101) (iHKL(I,iR),I=1,3), AIOBS(iR), WTI(iR), iR
  101   FORMAT (3I5,1X,F12.3,1X,F12.4,1X,I5)
      ENDDO
      CLOSE(hFile)
      CALL Clear_BackGround
      NoData = .FALSE.
      CALL GetProfileLimits
      CALL Get_IPMaxMin
      CALL Set_Wavelength(1.0)
      PAWLEYCHISQ = 1.0
      CALL SelectDASHDialog(IDD_ViewPawley)
 !     CALL WDialogPutReal(IDF_Sigma1,PeakShapeSigma(1),'(F10.4)')
 !     CALL WDialogPutReal(IDF_Sigma2,PeakShapeSigma(2),'(F10.4)')
 !     CALL WDialogPutReal(IDF_Gamma1,PeakShapeGamma(1),'(F10.4)')
 !     CALL WDialogPutReal(IDF_Gamma2,PeakShapeGamma(2),'(F10.4)')
      CALL WDialogPutInteger(IDF_Pawley_Cycle_NumPts, NBIN)
      CALL WDialogPutInteger(IDF_Pawley_Cycle_NumRefs, NumOfRef)
      CALL WDialogPutReal(IDF_Pawley_Cycle_ChiSq, PAWLEYCHISQ, '(F12.3)')
      CALL GET_LOGREF
      IPTYPE = 1
      CALL Profile_Plot
      CALL sa_SetOutputFiles(TheFileName)
      HKLFFileLoad = 0
      RETURN
  998 CLOSE(hFile)
      CALL ErrorMessage("Error opening .hkl file.")
      RETURN
  999 CLOSE(hFile)
      CALL ErrorMessage("Error writing .pik/.hcv file.")
      RETURN
  567 CLOSE(hFile)
      CALL ErrorMessage("Error writing .pik/.hcv file: Bounds exceeded ")

      END FUNCTION HKLFFileLoad
!
!*****************************************************************************
!
      SUBROUTINE OrderReflections(Keep)

! Calculates 2 theta for every reflection.

      IMPLICIT NONE

      LOGICAL, INTENT (IN   ) :: Keep(*)

      INCLUDE 'GLBVAR.INC'
      INCLUDE 'Lattice.inc'

      INTEGER         ICRYDA, NTOTAL,    NYZ, NTOTL, INREA,       ICDN,       IERR, IO10
      LOGICAL                                                                             SDREAD
      COMMON /CARDRC/ ICRYDA, NTOTAL(9), NYZ, NTOTL, INREA(26,9), ICDN(26,9), IERR, IO10, SDREAD

      INTEGER         LPT, LUNI
      COMMON /IOUNIT/ LPT, LUNI

      CHARACTER*6 xxx
      CHARACTER*10 fname_2

      INTEGER     msymmin
      PARAMETER ( msymmin = 10 )
      INTEGER            nsymmin
      REAL                        symmin
      CHARACTER*20                                           symline
      COMMON /symgencmn/ nsymmin, symmin(1:4,1:4,1:msymmin), symline(1:msymmin)

      INTEGER         IBMBER
      COMMON /CCSLER/ IBMBER

      INTEGER iSym, I

      IBMBER = 0
      OPEN(42,file='polyo.ccl',status='unknown')
      WRITE(42,4210)
 4210 FORMAT('N Determining reflection order ')
      IF (NumberSGTable .GE. 1) THEN
        CALL DecodeSGSymbol(SGShmStr(NumberSGTable))
        IF (nsymmin .GT. 0) THEN
          DO iSym = 1, nsymmin
            WRITE(42,4235) symline(iSym)
 4235       FORMAT('S ',A)
          ENDDO
        ENDIF
      ENDIF
      WRITE(42,4240) (cellpar(I),I=1,6)
 4240 FORMAT('C ',6f10.5)
      CLOSE(42)
      fname_2 = 'polyo'
      xxx = 'ORDREF'
      CALL FORORD(xxx, fname_2, Keep)
      CALL CLOFIL(ICRYDA)
      CALL CLOFIL(IO10)
      CALL CLOFIL(LPT)

      END SUBROUTINE OrderReflections
!
!*****************************************************************************
!
      SUBROUTINE FORORD(pname,filnmr,Keep)

      USE WINTERACTER
      USE dash_gui_resources
      USE REFVAR
      USE VARIABLES
#ifdef __G95__
      USE FOR_G95
#endif

      IMPLICIT NONE

      LOGICAL, INTENT (IN   ) :: Keep(*)

      CHARACTER*6 PNAME
      CHARACTER*10 filnmr

      INCLUDE 'params.inc'

      REAL            STHMXX,    STHL, SINTH, COSTH, SSQRD, TWSNTH,    DSTAR2, TWOTHD
      COMMON /BRAGG / STHMXX(5), STHL, SINTH, COSTH, SSQRD, TWSNTH(5), DSTAR2, TWOTHD(5)

      INTEGER         NINIT, NBATCH, NSYSTM
      LOGICAL                                MULFAS, MULSOU, MULONE
      COMMON /GLOBAL/ NINIT, NBATCH, NSYSTM, MULFAS, MULSOU, MULONE

      CHARACTER*10 filnam_root
      COMMON /commun/ filnam_root

      INTEGER         IBMBER
      COMMON /CCSLER/ IBMBER

      INTEGER         jHKL
      REAL                            WTJ,         AJOBS
      COMMON /SXFSTO/ jHKL(3,MFCSTO), WTJ(MFCSTO), AJOBS(MFCSTO)

      INTEGER, EXTERNAL :: PREFIN
      INTEGER IDummy

      REAL   DStarTem(MFCSTO)
      INTEGER iR, jR, I, hFile
      INTEGER iOrdTem(MFCSTO), KK
      REAL    H(1:3), DERS(1:6), ArgKKtem(MFCSTO), cut_off_2theta

      filnam_root = filnmr
      NINIT = 1
      IDummy = PREFIN(PNAME)
      CALL SYMOP
      CALL RECIP
      IF (IBMBER .NE. 0) RETURN
      CALL OPSYM(1)
      DO iR = 1, NumOfRef
        DO I = 1, 3
          H(i) = FLOAT(jHKL(I,iR))
        ENDDO
        CALL CELDER(H, DERS)
!C wavelength = 1 Angstrom
        IF (sthl .LT. -1.0) THEN
          sthl = -1.0
          CALL DebugErrorMessage("sthl .LT. -1.0")
        ENDIF
        IF (sthl .GT. 1.0) THEN
          sthl = 1.0
          CALL DebugErrorMessage("sthl .GT. 1.0")
        ENDIF
        ArgKKtem(iR) = 2.0 * ASIND(sthl)
        DStarTem(iR) = 2.0 * sthl
      ENDDO
      CALL Sort_Real(ArgKKtem, iOrdTem, NumOfRef)
      cut_off_2theta = 2.0 * ASIND(1.0/(2.0*SXMaxResolution))
      KK = 0
      DO iR = 1, NumOfRef
        jR = iOrdTem(iR)
        IF (Keep(jR)) THEN
          IF (ArgKKTem(jR) .LE. cut_off_2theta) THEN
            KK = KK + 1
            AIOBS(KK) = AJOBS(jR)
            WTi(KK) = WTj(jR)
            DSTAR(KK) = dstartem(jR)
            RefArgK(KK) = ArgKKTem(jR)
            DO I = 1, 3
              iHKL(I,KK) = jHKL(i,jR)
            ENDDO
          ENDIF
        ENDIF
      ENDDO
      NumOfRef = KK
!C Write out a fake .tic file
      hFile = 121
      OPEN(UNIT=hFile,FILE='polyp.tic',STATUS='UNKNOWN',ERR=999)
      DO iR = 1, NumOfRef
        WRITE(hFile,*,ERR=999) (iHKL(I,iR),I=1,3), RefArgK(iR), DSTAR(iR)
      ENDDO
      CLOSE(hFile)
      RETURN
  999 CLOSE(hFile)
      CALL ErrorMessage("Error writing .tic file.")

      END SUBROUTINE FORORD
!
!*****************************************************************************
!

max_stars_repo_name: ccdc-opensource/dash

max_issues_repo_name: ccdc-opensource/dash

max_forks_repo_name: ccdc-opensource/dash


text: MULTF(I,J)=I*J

ext: f

max_issues_repo_name: seanwallawalla-forks/RosettaCodeData

max_forks_repo_name: seanwallawalla-forks/RosettaCodeData


text:
!!
!! ASSIGNMENT TO ALLOCATABLE ARRAY NOT WORKING
!!
!! The following example fails with a runtime error when making an
!! assignment to an allocatable lhs array.  This is standard conforming
!! and should work, and it does work for non-polymorphic rhs vectors,
!! but something is going wrong in this type-is stanza.
!!
!! Note: must use -assume realloc_lhs (or -standard-semantics) to get
!! standard-conforming behavior.
!!
!! % ifort --version
!! ifort (IFORT) 14.0.2 20140120
!!
!! % ifort -assume realloc_lhs intel-bug-20140424.f90
!! % ./a.out
!! preparing to assign [1,2] to allocatable lhs array
!! forrtl: severe (174): SIGSEGV, segmentation fault occurred
!! Image              PC                Routine            Line        Source
!! a.out              0000000000473C59  Unknown               Unknown  Unknown
!! a.out              000000000047252E  Unknown               Unknown  Unknown
!! a.out              0000000000427C92  Unknown               Unknown  Unknown
!! a.out              00000000004077E3  Unknown               Unknown  Unknown
!! a.out              000000000040C39B  Unknown               Unknown  Unknown
!! libpthread.so.0    0000003FA980F750  Unknown               Unknown  Unknown
!! a.out              00000000004031EF  Unknown               Unknown  Unknown
!! a.out              0000000000402C96  Unknown               Unknown  Unknown
!! libc.so.6          0000003FA8C21D65  Unknown               Unknown  Unknown
!! a.out              0000000000402B89  Unknown               Unknown  Unknown
!!

module any_vector_type

  type :: any_vector
    class(*), allocatable :: value(:)
  contains
    procedure :: get_int_value
  end type

contains

  subroutine get_int_value (this, value)
    class(any_vector), intent(in) :: this
    integer, allocatable :: value(:)
    select type (v => this%value)
    type is (integer)
      print '(a,i0,",",i0,a)', 'preparing to assign [', v, '] to allocatable lhs array'
      value = v ! SHOULD ALLOCATE THE LHS IF NEEDED BEFORE ASSIGNING
      print *, 'successful'
    end select
  end subroutine

end module

program main

  use any_vector_type

  type(any_vector) :: a
  integer, allocatable :: x(:)

  allocate(a%value(2), source=[1,2])
  call a%get_int_value (x)

end program

max_stars_repo_name: dhnza/fortran-compiler-tests

max_issues_repo_name: dhnza/fortran-compiler-tests

max_forks_repo_name: dhnza/fortran-compiler-tests


      subroutine pl_fert (jj, ifrt, frt_kg, fertop)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine applies N and P specified by date and
!!    amount in the management file (.mgt)
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    SWAT: Erfc

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use mgt_operations_module
      use fertilizer_data_module
      use basin_module
      use organic_mineral_mass_module
      use hru_module, only : ihru, fertn, fertp, fertnh3, fertno3, fertorgn, fertorgp, fertp,  &
        fertsolp

      implicit none

      real, parameter :: rtof=0.5         !none          |weighting factor used to partition the
                                          !              |organic N & P concentration of septic effluent
                                          !              |between the fresh organic and the stable
                                          !              |organic pools
      integer :: j                        !none          |counter
      integer :: l                        !none          |counter
      integer, intent (in) :: jj          !none          |counter
      integer, intent (in) :: ifrt        !              |fertilizer type from fert data base
      integer, intent (in) :: fertop      !              |
      real, intent (in) :: frt_kg         !kg/ha         |amount of fertilizer applied
      real :: xx                          !              |
      real :: gc                          !none          |fraction of ground covered by plant foliage
      real :: gc1                         !              |
      real :: swf                         !cfu           |fraction of manure containing active colony forming units
      real :: frt_t                       !              |

      !!added by zhang
      !!======================
      real :: X1, X8, X10, XXX, YY, ZZ, XZ, YZ, RLN, orgc_f

      j = ihru

      X1 = 0.
      X8 = 0.
      X10 = 0.
      XXX = 0.
      YY = 0.
      ZZ = 0.
      XZ = 0.
      YZ = 0.
      RLN = 0.
      orgc_f = 0.
      !!added by zhang
      !!======================

      !j = jj

      do l = 1, 2
        xx = 0.
        if (l == 1) then
          xx = chemapp_db(fertop)%surf_frac
        else
          xx = 1. - chemapp_db(fertop)%surf_frac
        endif

        soil1(j)%mn(l)%no3 = soil1(j)%mn(l)%no3 + xx * frt_kg *          &
            (1. - fertdb(ifrt)%fnh3n) * fertdb(ifrt)%fminn

        if (bsn_cc%cswat == 0) then
        soil1(j)%tot(l)%n = soil1(j)%tot(l)%n + rtof * xx * frt_kg *   &
                       fertdb(ifrt)%forgn
        soil1(j)%hs(l)%n = soil1(j)%hs(l)%n + (1. - rtof) * xx * &
            frt_kg * fertdb(ifrt)%forgn
        soil1(j)%tot(l)%p = soil1(j)%tot(l)%p + rtof * xx * frt_kg *   &
                       fertdb(ifrt)%forgp
        soil1(j)%hp(l)%p = soil1(j)%hp(l)%p + (1. - rtof)*xx*frt_kg *  &
                       fertdb(ifrt)%forgp
        end if
	  if (bsn_cc%cswat == 1) then
	  soil1(j)%man(l)%c = soil1(j)%man(l)%c + xx * frt_kg *            &
      		fertdb(ifrt)%forgn * 10.
	  soil1(j)%man(l)%n = soil1(j)%man(l)%n + xx * frt_kg *            &
      		fertdb(ifrt)%forgn
	  soil1(j)%man(l)%p = soil1(j)%man(l)%p + xx * frt_kg *            &
      		fertdb(ifrt)%forgp
	  end if

        !!By Zhang for C/N cycling
        !!===========================
	  if (bsn_cc%cswat == 2) then
        soil1(j)%tot(l)%p = soil1(j)%tot(l)%p + rtof * xx *           &
            frt_kg * fertdb(ifrt)%forgp
        soil1(j)%hp(l)%p = soil1(j)%hp(l)%p + (1. - rtof) * xx *  &
            frt_kg * fertdb(ifrt)%forgp

        !!Allocate organic fertilizer to Slow (SWAT_active) N pool;
          soil1(j)%hs(l)%n = soil1(j)%hs(l)%n + (1. - rtof) * xx *  &
                        frt_kg * fertdb(ifrt)%forgn
          soil1(j)%hs(l)%n = soil1(j)%hs(l)%n    !!!same name

          !orgc_f is the fraction of organic carbon in fertilizer
          !for most fertilziers this value is set to 0.
          orgc_f = 0.0
          !X1 is fertlizer applied to layer (kg/ha)
          !xx is fraction of fertilizer applied to layer
          X1 = xx * frt_kg
          !X8: organic carbon applied (kg C/ha)
          X8 = X1 * orgc_f
          !RLN is calculated as a function of C:N ration in fertilizer
          RLN = .175 *(orgc_f)/(fertdb(ifrt)%fminn + fertdb(ifrt)%forgn  &
                                                               + 1.e-5)

          !X10 is the fraction of carbon in fertilizer that is allocated to metabolic litter C pool
          X10 = .85-.018*RLN
          if (X10<0.01) then
            X10 = 0.01
          else
            if (X10 > .7) then
                X10 = .7
            end if
          end if

          !XXX is the amount of organic carbon allocated to metabolic litter C pool
          XXX = X8 * X10
          soil1(j)%meta(l)%c = soil1(j)%meta(l)%c + XXX
          !YY is the amount of fertilizer (including C and N) allocated into metabolic litter SOM pool
          YY = X1 * X10
          soil1(j)%meta(l)%m = soil1(j)%meta(l)%m + YY

          !ZZ is amount of organic N allocated to metabolic litter N pool
          ZZ = X1 *rtof * fertdb(ifrt)%forgn * X10

          soil1(j)%meta(l)%n = soil1(j)%meta(l)%n + ZZ

          !!remaining organic N is llocated to structural litter N pool
          soil1(j)%str(l)%n = soil1(j)%str(l)%n + X1 * fertdb(ifrt)%forgn - ZZ
          !XZ is the amount of organic carbon allocated to structural litter C pool
          XZ = X1 *orgc_f-XXX
          soil1(j)%str(l)%c = soil1(j)%str(l)%c + XZ

          !assuming lignin C fraction of organic carbon to be 0.175; updating lignin amount in strucutral litter pool
          soil1(j)%lig(l)%c = soil1(j)%lig(l)%c + XZ * .175
          !non-lignin part of the structural litter C is also updated;
          soil1(j)%lig(l)%n = soil1(j)%lig(l)%n + XZ * (1.-.175)

          !YZ is the amount of fertilizer (including C and N) allocated into strucutre litter SOM pool
          YZ = X1 - YY
          soil1(j)%str(l)%m = soil1(j)%str(l)%m + YZ
          !assuming lignin fraction of the organic fertilizer allocated into structure litter SOM pool to be 0.175;
          !update lignin weight in structural litter.
          soil1(j)%lig(l)%m = soil1(j)%lig(l)%m + YZ*.175
          soil1(j)%tot(l)%n = soil1(j)%meta(l)%n + soil1(j)%str(l)%n

          !end if

	  end if
        !!By Zhang for C/N cycling
        !!===========================

        soil1(j)%mn(l)%nh4 = soil1(j)%mn(l)%nh4 + xx * frt_kg *          &
            fertdb(ifrt)%fnh3n * fertdb(ifrt)%fminn

        soil1(j)%mp(l)%lab = soil1(j)%mp(l)%lab + xx * frt_kg *          &
            fertdb(ifrt)%fminp

      end do

!! summary calculations
      fertno3 = frt_kg * fertdb(ifrt)%fminn * (1. - fertdb(ifrt)%fnh3n)
      fertnh3 = frt_kg * (fertdb(ifrt)%fminn * fertdb(ifrt)%fnh3n)
      fertorgn = frt_kg * fertdb(ifrt)%forgn
      fertsolp = frt_kg * fertdb(ifrt)%fminp
      fertorgp = frt_kg * fertdb(ifrt)%forgp
      fertn = fertn + frt_kg * (fertdb(ifrt)%fminn +         &
                                                   fertdb(ifrt)%forgn)
      fertp = fertp + frt_kg * (fertdb(ifrt)%fminp +         &
                                                   fertdb(ifrt)%forgp)
      return
      end subroutine pl_fert


! { dg-do run }
! { dg-options "-std=legacy" }
!
! This tests the fix for PR22010, where namelists were not being written to
! and read back from modules.  It checks that namelists from modules that are
! selected by an ONLY declaration work correctly, even when the variables in
! the namelist are not host associated. Note that renaming a namelist by USE
! association is not allowed by the standard and this is trapped in module.c.
!
! Contributed by Paul Thomas  pault@gcc.gnu.org
!
module global
  character*4 :: aa, aaa
  integer :: ii, iii
  real    :: rr, rrr
  namelist /nml1/ aa, ii, rr
  namelist /nml2/ aaa, iii, rrr
contains
  logical function foo()
    foo = (aaa.ne."pqrs").or.(iii.ne.2).or.(rrr.ne.3.5)
  end function foo
end module global
program namelist_use_only
  use global, only : nml1, aa, ii, rr
  use global, only : nml2, rrrr=>rrr, foo
  open (10, status="scratch")
  write (10,'(a)') "&NML1 aa='lmno' ii=1 rr=2.5 /"
  write (10,'(a)') "&NML2 aaa='pqrs' iii=2 rrr=3.5 /"
  rewind (10)
  read (10,nml=nml1,iostat=i)
  if ((i.ne.0).or.(aa.ne."lmno").or.(ii.ne.1).or.(rr.ne.2.5)) STOP 1

  read (10,nml=nml2,iostat=i)
  if ((i.ne.0).or.(rrrr.ne.3.5).or.foo()) STOP 2
  close (10)
end program namelist_use_only


text:
      Function KColFunction(J,M,K,L,R,IColType,JB)        ! Look up col rule, return col choice
      if (icoltype. eq. 1) KColFunction= KTitForTatC(J,M,K,L,R)
      if (icoltype .eq. 2) KColFunction= KTF2TC(J,M,K,L,R)
      if (icoltype .eq. 3) KColFunction= KRandomC(J,M,K,L,R)
      if (icoltype .eq. 4) KColFunction= KPavlovC(J,M,K,L,R, JB)   ! JB is own, col's prev move
      return
      end

max_stars_repo_name: Axelrod-Python/TourExec

max_issues_repo_name: Axelrod-Python/TourExec

max_forks_repo_name: Axelrod-Python/TourExec


text:
      PROGRAM IIR

!***********************************************************************
!* Programmable IIR Filter
!*
!* Programmer:  E. Cheung
!*
!* Language: Fortran
!*
!* Date: 2003/07/18
!***********************************************************************

      ! Headers
      INCLUDE 'uds_str.fi'
      INCLUDE 'uds_fxn.fi'
      INCLUDE 'file.fi'

      ! Variables ______________________________________________________

      RECORD /UDS_Y/  U
      RECORD /UDS_CONTROL/  C
      RECORD /FILE/  HIT, REPORT, OUTPUT_LIST

      LOGICAL ALL_BATCH, NO_BATCH, NO_INCR, ONE_PASS, NEW_HIT, EOF,
     & BATCH, GROUP, NEW_GROUP,
     & DEF_CUTOFF, DEF_ATTENUATION, DEF_STOPF

      INTEGER NUM_ARGS, MAX_ARGS, IOS, IOS_W, I, IFL(5)

      PARAMETER ( MAX_ARGS = 12 )

      REAL FCUT, FATT, FSTP

      DOUBLE PRECISION CUTOFF, ATTENUATION, STOPF, FCUT_DEF, FSTP_DEF

      CHARACTER CL_ARG(0:MAX_ARGS)*255, PROG_NAME*8,
     & TEMPLATE_STR*255, DIR_OUT*255,
     & FILE_NAME*255, OUT_FILE*255, DEF_FILE*255,
     & PROMPT*79,
     & FCUT_C*25, FCUT_DEF_C*7, FATT_C*25,
     & FSTP_DEF_C*7, FSTP_C*25, FILCOD

      ! Initializations
      PROG_NAME = 'IIR'
      CALL FILE_INIT( HIT )
      CALL GET_CL( CL_ARG, NUM_ARGS, MAX_ARGS )
      CALL IIR_CL( CL_ARG, NUM_ARGS, PROG_NAME,
     & DEF_CUTOFF, CUTOFF, DEF_ATTENUATION, ATTENUATION,
     & DEF_STOPF, STOPF )
      CALL PROC_CL( CL_ARG, NUM_ARGS, PROG_NAME, TEMPLATE_STR,
     & ALL_BATCH, NO_BATCH, NO_INCR, REPORT, OUTPUT_LIST, DIR_OUT,
     & ONE_PASS, .TRUE., .TRUE. )
      PROMPT = 'UDS file name/template/hitlist?'
      PROMPT(74:) = '[done]'
      CALL UDS_CONTROL_INIT( C )
      C.CHANFORM = 'Y' ! Only accept Y-series file input

      WRITE( *, '(//28X,A//)' ) '**  IIR Filtering  **'

      ! Read the file name/template/hitlist
  100 CALL FILE_PROMPT( TEMPLATE_STR, PROMPT, DIR_OUT,
     & ONE_PASS, HIT, NEW_HIT, FILE_NAME, EOF )
      IF ( ( FILE_NAME .EQ. ' ' ) .OR. ( EOF ) ) GO TO 199 ! Done

      ! Batch setup
      CALL BAT_SET( ALL_BATCH, NO_BATCH, NEW_HIT, HIT, BATCH )
      CALL GROUP_SET( HIT, NEW_HIT, BATCH, 2, GROUP, NEW_GROUP )

      ! Group prompts
      IF ( NEW_GROUP ) THEN

        ! Get cutoff frequency
  101   IF ( DEF_CUTOFF ) THEN
          FCUT_C = ' '
        ELSE IF ( CUTOFF .GT. 0.D0 ) THEN
          FCUT = REAL( CUTOFF )
          FCUT_C = 'NOT BLANK'
        ELSE
          WRITE( *, '(/A,48X,A/'' >> '',$)' )
     &     ' Cutoff frequency (Hz)?', '[default]'
          READ( *, '(A)', IOSTAT=IOS ) FCUT_C
          IF ( IOS .NE. 0 ) THEN
            CALL MSG_WRITE( '*** Operation skipped', REPORT )
            CALL FILE_DEL( HIT )
            GO TO 190
          END IF
          IF ( FCUT_C .NE. ' ' ) THEN
            READ( FCUT_C, '(BN,F25.0)', IOSTAT=IOS ) FCUT
            IF ( ( IOS .NE. 0 ) .OR. ( FCUT .LE. 0. ) ) THEN
              WRITE( *, * ) '*** Invalid frequency'
              GO TO 101
            END IF
          END IF
        END IF

        ! Get frequency attenuation
  102   IF ( DEF_ATTENUATION ) THEN
          FATT_C = ' '
        ELSE IF ( ATTENUATION .LT. 0.D0 ) THEN
          FATT = REAL( ATTENUATION )
          FATT_C = 'NOT BLANK'
        ELSE
          WRITE( *, '(/A,47X,A/'' >> '',$)' )
     &     ' Frequency attenuation (dB)?', '[-30]'
          READ( *, '(A)', IOSTAT=IOS ) FATT_C
          IF ( IOS .NE. 0 ) THEN
            CALL MSG_WRITE( '*** Operation skipped', REPORT )
            CALL FILE_DEL( HIT )
            GO TO 190
          END IF
          IF ( FATT_C .NE. ' ' ) THEN
            READ( FATT_C, '(BN,F25.0)', IOSTAT=IOS ) FATT
            IF ( ( IOS .NE. 0 ) .OR. ( FATT .GE. 0. ) ) THEN
              WRITE( *, * )
     &         '*** Invalid attenuation - Must be < 0'
              GO TO 102
            END IF
          END IF
        END IF

        ! Get stop frequency
  103   IF ( DEF_STOPF ) THEN
          FSTP_C = ' '
        ELSE IF ( STOPF .GT. 0.D0 ) THEN
          FSTP = REAL( STOPF )
          FSTP_C = 'NOT BLANK'
        ELSE
          WRITE( *, '(/A,45X,A/'' >> '',$)' )
     &     ' Stop frequency (Hz)?', '[2.5 x Cutoff]'
          READ( *, '(A)', IOSTAT=IOS ) FSTP_C
          IF ( IOS .NE. 0 ) THEN
            CALL MSG_WRITE( '*** Operation skipped', REPORT )
            CALL FILE_DEL( HIT )
            GO TO 190
          END IF
          IF ( FSTP_C .NE. ' ' ) THEN
            READ( FSTP_C, '(BN,F25.0)', IOSTAT=IOS ) FSTP
            IF ( ( IOS .NE. 0 ) .OR. ( FSTP .LE. 0. ) ) THEN
              WRITE( *, * ) '*** Invalid stop frequency'
              GO TO 103
            END IF
          END IF
        END IF

      END IF

      ! Read UDS file
      CALL REP_COLS( REPORT )
      CALL UDS_GET( FILE_NAME, U, C, REPORT, IOS )
      IF ( IOS .NE. 0 ) GO TO 190

      ! Check file fields
      IF ( ( U.CURTYP .NE. 'TIME SERIES' ) .OR.
     & ( U.XTYP .NE. 'TIME' ) .OR.
     & ( U.XUNITS .NE. 'SECONDS' ) )
     & CALL MSG_WRITE( '*** WARNING - Not a time series file',
     & REPORT )
      IF ( ( U.NFP .GT. 0 ) .OR. ( U.NLP .LE. 0 ) ) CALL MSG_WRITE(
     & '*** WARNING - Nonstandard x-axis span', REPORT )

      ! Determine default cutoff frequency value
      CALL FREQ_DEF( U, 0.D0, 0.D0, FCUT_DEF, FCUT_DEF_C,
     & FSTP_DEF, FSTP_DEF_C )

      IF ( .NOT. GROUP ) THEN ! Interactive prompts

        ! Get cutoff frequency value
  104   IF ( DEF_CUTOFF ) THEN
          FCUT_C = ' '
          FCUT = REAL( FCUT_DEF )
        ELSE IF ( CUTOFF .GT. 0.D0 ) THEN
          FCUT = REAL( CUTOFF )
          FCUT_C = 'NOT BLANK'
        ELSE
          ! Show file info
          WRITE( *, '(/5X,2A/5X,A,F9.3,A/5X,A,F9.3,A)',
     &     IOSTAT=IOS_W )
     &     ' Sensor Attachment: ', U.SENATT,
     &     ' Prefilter Frequency:   ', U.PREF, ' (Hz)',
     &     ' Last Cutoff Frequency: ', U.FCUT, ' (Hz)'
          WRITE( *, '(/A,48X,A/'' >> '',$)' )
     &     ' Cutoff frequency (Hz)?', '['//FCUT_DEF_C//']'
          READ( *, '(A)', END=190 ) FCUT_C
          IF ( FCUT_C .EQ. ' ' ) THEN
            FCUT = REAL( FCUT_DEF )
          ELSE
            READ( FCUT_C, '(BN,F25.0)', IOSTAT=IOS ) FCUT
            IF ( ( IOS .NE. 0 ) .OR. ( FCUT .LE. 0. ) ) THEN
              WRITE( *, * ) '*** Invalid frequency'
              GO TO 104
            END IF
          END IF
        END IF

        ! Get frequency attenuation
  105   IF ( DEF_ATTENUATION ) THEN
          FATT_C = ' '
        ELSE IF ( ATTENUATION .GT. 0.D0 ) THEN
          FATT = REAL( ATTENUATION )
          FATT_C = 'NOT BLANK'
        ELSE
          WRITE( *, '(/A,47X,A/'' >> '',$)' )
     &     ' Frequency attenuation (dB)?', '[-30]'
          READ( *, '(A)', END=190 ) FATT_C
          IF ( FATT_C .EQ. ' ' ) THEN
            FATT = -30.
          ELSE
            READ( FATT_C, '(BN,F25.0)', IOSTAT=IOS ) FATT
            IF ( ( IOS .NE. 0 ) .OR. ( FATT .GE. 0. ) ) THEN
              WRITE( *, * )
     &         '*** Invalid attenuation - Must be < 0'
              GO TO 105
            END IF
          END IF
        END IF

        ! Get stop frequency
  106   IF ( DEF_STOPF ) THEN
          FSTP_C = ' '
        ELSE IF ( STOPF .GT. 0.D0 ) THEN
          FSTP = REAL( STOPF )
          FSTP_C = 'NOT BLANK'
        ELSE
          WRITE( *, '(/A,50X,A/'' >> '',$)' )
     &     ' Stop frequency (Hz)?',  '['//FSTP_DEF_C//']'
          READ( *, '(A)', END=190 ) FSTP_C
          IF ( FSTP_C .EQ. ' ' ) THEN
            FSTP = REAL( FSTP_DEF )
          ELSE
            READ( FSTP_C, '(BN,F25.0)', IOSTAT=IOS ) FSTP
            IF ( ( IOS .NE. 0 ) .OR. ( FSTP .LE. FCUT ) ) THEN
              WRITE( *, * )
     &         '*** Invalid stop frequency - Must be > cutoff'
              GO TO 106
            END IF
          END IF
        END IF

      ELSE ! Batch

        IF ( FCUT_C .EQ. ' ' ) FCUT = REAL( FCUT_DEF )
        IF ( FATT_C .EQ. ' ' ) FATT = -30.
        IF ( FSTP_C .EQ. ' ' ) FSTP = REAL( FSTP_DEF )

      END IF

      ! Perform filtering
      IF ( FCUT .GT. 0. ) THEN
        IFL(1) = INT( FCUT )
        IFL(2) = INT( FATT )
        IFL(3) = 3
        IFL(4) = INT( FSTP )
        IFL(5) = 0
        CALL IIRFIL( U.Y(U.NFP), U.DEL, U.NLP-U.NFP+1, IFL )
      ELSE
        CALL MSG_WRITE( '*** WARNING - No filtering performed',
     &   REPORT )
      END IF

      ! Prepare output fields
      U.STATUS = 'FILTERED'
      U.HIC = 0.
      U.T1 = 0.
      U.T2 = 0.
      U.HICDTUP = 0.
      U.CLIP3M = 0.
      U.CSI = 0.
      U.FCUT = FCUT
      U.FSTP = FSTP
      IF ( ( ( U.FCOR .GT. 0. ) .AND. ( U.FSTP .GT. U.FCOR ) ) .OR.
     & ( ( U.PREF .GT. 0. ) .AND. ( U.FSTP .GT. .5*U.PREF ) ) ) THEN
        CALL MSG_WRITE( '*** WARNING - Filter causes overlap '//
     &   'distortion with previous filtering', REPORT )
        U.STATUS = 'DISTORTED'
      END IF
      U.FCOR = .5 * FCUT
      U.CD1 = 'IIR Filtered'

      ! Set default output file name
      OUT_FILE = FILE_NAME
      CALL FN_EXTRACT( OUT_FILE )
      CALL FILTER_FLAG( U.CURTYP, U.FCUT, U.FSTP, FILCOD )
      CALL FN_FLAG( OUT_FILE, 'f'//FILCOD, 2, I )
      CALL ADD_PATH( DIR_OUT, OUT_FILE )
      IF ( .NOT. NO_INCR ) CALL FN_INCR( OUT_FILE )
      CALL FN_NAME_EXTRACT( OUT_FILE )
      DEF_FILE = OUT_FILE

      ! Set the output UDS file name
      IF ( .NOT. BATCH ) THEN
  120   WRITE( *, '(/A/3A/'' >> '',$)' )
     &   ' Output UDS file name?',
     &   ' [', DEF_FILE(:L_TRIM(DEF_FILE)), ']'
        READ( *, '(A)', END=190 ) OUT_FILE
        IF ( OUT_FILE .EQ. ' ' ) THEN ! Use default file name
          OUT_FILE = DEF_FILE
        ELSE ! Check file name validity
          CALL ADD_PATH( DIR_OUT, OUT_FILE )
          IF ( .NOT. FN_VALID( OUT_FILE ) ) THEN
            WRITE( *, * ) '*** Invalid file name'
            GO TO 120
          END IF
        END IF
      ELSE ! Batch
        OUT_FILE = DEF_FILE
      END IF

      ! Write the output UDS file
      CALL UDS_PUT( OUT_FILE, U, C, REPORT, OUTPUT_LIST,
     & DIR_OUT, .TRUE., IOS )

      ! Loop for next file
  190 WRITE( *, '(80(''_''))' )
      GO TO 100

      ! Clean up and stop
  199 CALL CLEAN_UP( HIT, REPORT, OUTPUT_LIST, DIR_OUT )

      END

      SUBROUTINE IIR_CL( CL_ARG, NUM_ARGS, PROG_NAME,
     & DEF_CUTOFF, CUTOFF, DEF_ATTENUATION, ATTENUATION,
     & DEF_STOPF, STOPF )

!***********************************************************************
!* Processes the Program-Specific Command Line Arguments
!***********************************************************************

      ! Headers
      INCLUDE 'uds_fxn.fi'

      ! Arguments ______________________________________________________

      CHARACTER*(*) CL_ARG(0:*) ! Command line argument array

      INTEGER NUM_ARGS ! Number of arguments

      CHARACTER*(*) PROG_NAME ! Program name

      LOGICAL DEF_CUTOFF ! Indicates to use default cutoff

      DOUBLE PRECISION CUTOFF ! Cutoff frequency

      LOGICAL DEF_ATTENUATION ! Indicates to use default attenuation

      DOUBLE PRECISION ATTENUATION ! Attenuation

      LOGICAL DEF_STOPF ! Indicates to use default stop frequency

      DOUBLE PRECISION STOPF ! Stop frequency

      ! Variables ______________________________________________________

      INTEGER I, NS, IOS

      CHARACTER ARG*255, C

      ! Process command line arguments
      DEF_CUTOFF = .FALSE.
      CUTOFF = 0.D0
      DEF_ATTENUATION = .FALSE.
      ATTENUATION = 0.D0
      DEF_STOPF = .FALSE.
      STOPF = 0.D0
      DO I = 1, NUM_ARGS
        CALL STR_UPCASE( ARG, CL_ARG(I) )
        C = ARG(1:1)
        IF ( ( C .EQ. '-' ) .OR. ( C .EQ. '/' ) ) THEN
          NS = 2
        ELSE
          NS = 1
        END IF
        IF ( ( ARG(NS:) .EQ. '?' ) .OR.
     &   ( ARG(NS:) .EQ. '??' ) .OR.
     &   ( ARG(NS:) .EQ. 'HELP' ) ) THEN ! Show command line syntax
          CALL SYNTAX_CL( PROG_NAME )
          WRITE( *, '(10X,A)' )
     &     '[CUTOFF=<cutoff_freq>] [ATTEN=<attenuation>] '//
     &     '[STOP=<stop_freq>]'
          IF ( ( ARG(NS:) .EQ. '??' ) .OR.
     &     ( ARG(NS:) .EQ. 'HELP' ) ) THEN ! Show command line help
            CALL HELP_CL( PROG_NAME )
            WRITE( *, '(2(10X,A/),10X,A)' )
     &       '<cutoff_freq> :  '//
     &       'Cutoff frequency (blank => default)',
     &       '<attenuation> :  '//
     &       'Frequency attenuation (dB) [-30]',
     &       '<stop_freq> :  '//
     &       'Stop frequency [2.5 x cutoff]'
          END IF
          STOP ' '
        ELSE IF ( ( ARG(NS:NS+6) .EQ. 'CUTOFF=' ) .OR.
     &   ( ARG(NS:NS+6) .EQ. 'CUTOFF#' ) ) THEN
          IF ( ARG(NS+7:) .EQ. ' ' ) THEN ! Default
            DEF_CUTOFF = .TRUE.
            CUTOFF = 0.D0
          ELSE
            READ( ARG(NS+7:), '(BN,F25.0)', IOSTAT=IOS ) CUTOFF
            IF ( ( IOS .NE. 0 ) .OR. ( CUTOFF .LE. 0.D0 ) ) THEN
              WRITE( *, '(/2A)', IOSTAT=IOS )
     &         ' Illegal cutoff frequency: ',
     &         ARG(NS+7:L_TRIM(ARG))
              CUTOFF = 0.D0
            ELSE
              DEF_CUTOFF = .FALSE.
            END IF
          END IF
          CL_ARG(I) = ' '
        ELSE IF ( ARG(NS:) .EQ. 'CUTOFF' ) THEN ! Default
          DEF_CUTOFF = .TRUE.
          CUTOFF = 0.D0
          CL_ARG(I) = ' '
        ELSE IF ( ( ARG(NS:NS+5) .EQ. 'ATTEN=' ) .OR.
     &   ( ARG(NS:NS+5) .EQ. 'ATTEN#' ) ) THEN
          IF ( ARG(NS+6:) .EQ. ' ' ) THEN ! Default
            DEF_ATTENUATION = .TRUE.
            ATTENUATION = 0.D0
          ELSE
            READ( ARG(NS+6:), '(BN,F25.0)', IOSTAT=IOS ) ATTENUATION
            IF ( ( IOS .NE. 0 ) .OR. ( ATTENUATION .GE. 0.D0 ) ) THEN
              WRITE( *, '(/2A)', IOSTAT=IOS )
     &         ' Illegal frequency attenuation: ',
     &         ARG(NS+6:L_TRIM(ARG))
              ATTENUATION = 0.D0
            ELSE
              DEF_ATTENUATION = .FALSE.
            END IF
          END IF
          CL_ARG(I) = ' '
        ELSE IF ( ARG(NS:) .EQ. 'ATTEN' ) THEN ! Default
          DEF_ATTENUATION = .TRUE.
          ATTENUATION = 0.D0
          CL_ARG(I) = ' '
        ELSE IF ( ( ARG(NS:NS+4) .EQ. 'STOP=' ) .OR.
     &   ( ARG(NS:NS+4) .EQ. 'STOP#' ) ) THEN
          IF ( ARG(NS+5:) .EQ. ' ' ) THEN ! Default
            DEF_STOPF = .TRUE.
            STOPF = 0.D0
          ELSE
            READ( ARG(NS+5:), '(BN,F25.0)', IOSTAT=IOS ) STOPF
            IF ( ( IOS .NE. 0 ) .OR. ( STOPF .LE. 0.D0 ) ) THEN
              WRITE( *, '(/2A)', IOSTAT=IOS )
     &         ' Illegal stop frequency: ',
     &         ARG(NS+5:L_TRIM(ARG))
              STOPF = 0.D0
            ELSE
              DEF_STOPF = .FALSE.
            END IF
          END IF
          CL_ARG(I) = ' '
        ELSE IF ( ARG(NS:) .EQ. 'STOP' ) THEN ! Default
          DEF_STOPF = .TRUE.
          STOPF = 0.D0
          CL_ARG(I) = ' '
        END IF
      END DO

      RETURN
      END

ext: for

max_stars_repo_name: DeadParrot/NHTSA-Tools

max_issues_repo_name: DeadParrot/NHTSA-Tools

max_forks_repo_name: DeadParrot/NHTSA-Tools


text:
	subroutine grafer(it)
	return
	end

max_stars_repo_name: sergev/grafor

max_issues_repo_name: sergev/grafor

max_forks_repo_name: sergev/grafor


text:
! { dg-do run }
program stopper
  real, dimension(5,5,5) :: i
  error stop size(i) ! { dg-shouldfail "ERROR STOP 125" }
end program stopper

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
Angies Beauty Salon is a fullservice beauty salon and is one of several Hair Salons and Barber Shops in Davis. Hair cuts are $15 for men and $17 and up for women. They do highlights, deep conditions, full color and waxing. Walkins are welcome.

In February of 2006 Angies underwent a significant remodel. The business now occupies the front of the building, in addition to the side it had before. Furthermore, they appear to have more windows, new floors, new paint— it looks drastically better. Dare I say, like a real salon.

In 2010, Silvia, Anamaria, and Mela, who had been stylists at Angies Beauty Salon, opened up their own salon  Expressions Hair Design.

To learn about other businesses in Davis that provide professional aesthetic services, visit our Beauty Salons and Barber Shops page.

20051103 00:22:56 nbsp I highly recommend this place the people are really great the prices are remarcable. They are highly skilled profesionals. I came to them with a horrible hair cut that i was give to by roxies which i payed to much for and they fixed it even better than i expected. They do exactly what you want. The salon is very home like so you feel comfortable.  I recomend Anamaria she is wonders with color. Users/SarahMiller

20060101 00:02:02 nbsp Haircuts are great they always do what you ask for. they specialized on highlights, I started going since they open,I have never had any problems. Every where I go make make great comments on my highlights. I really recommend you to try it. angellica torres Users/AngelicaTorres

20060302 17:07:54 nbsp I loved the haircut I got here! Do not be fooled by its ooutward appearence these people are REALLY REALLY great!!!!!!!!!!!!!!! Users/JenniferDhaliwal

20060305 13:36:08 nbsp I had a great experience here. Its a very casual atmosphere, but they do a great job. Id suggest bringing photos or pictures of what youd like to have done, and you cant beat the prices. They also take walkins regularly. Users/KatieBauer

20060417 21:31:34 nbsp I love Angies all of the girls are wonderful and the remodel looks great. Users/JackieCaro

20060627 15:08:05 nbsp After having my haircut ruined at another salon in another state, I decided to go for a cheap haircut in case they couldnt fix it I wouldnt be out too much.  Angies did a great job, I dont know her name but the owner did my hair and it looked great, she worked with the messed up layers and it ended up looking exactly how I had explained it.  She was kind of hard to understand with her hispanic accent, but she knows what she doing and she definitely could get away with charging more for how talented she is. Users/HillaryLaFever

20060805 22:23:53 nbsp I got a fabulous haircut here. I decided to go for a new look and it went here based on the great reviews and the stylist did what I wanted and she told me how to maintain my style. I highly recommend this place. Users/PattyLouieJunior

20060810 13:29:08 nbsp I just got a haircut there and it was the WORST haircut experience I have ever had!  They didnt wash my hair, which was surprising, but not a big deal if the haircut had turned out good.  Then the woman cutting my hair kept talking to her coworker the entire time  I felt like I had to remind her that I was there so she wouldnt forget what she was doing!  All I wanted was for the layers in my hair to be evened out a little, but she made them so much worse, now I have one extremely short layer and one extremely long layer.  I definitely will not go back.   Users/DieterZamboni

20060818 14:58:08 nbsp After moving to Davis I consulted daviswiki for a salon when my hair started to look a little bushy. I usually pay $55 a cut and it takes my stylist like 2 hours to cut my freakin hair. I went down to Angies (30 minutes notice for an appointment) and got a wonderful cut for $13! Sweet! Users/JackeryRoehrig

20060914 15:56:55 nbsp I like this place! They charge very little for good hair cuts. Everyone was very friendly and they didnt require a hairwashing. Users/RathyMarie

20060920 14:01:27 nbsp I was looking for a decent priced hair salon and gave Angies a try. I only paid 90$ got three different hair colors put in and a cut. This is the best price I have ever had for the quality of work she did. Angie was fast and efficient, I was very pleased. It was also fun to listen to all the Espanol.  Users/SonjaSchaff

20070115 21:20:40 nbsp I went in today to cut off 10 of hair for Locks of Love. The woman (Angie, I believe), was amazing. She knew exactly what I wanted and the cut was PERFECT. She knew exactly how to make my hair do exactly what I wanted it to! You might want to make an appointment, though. Also, haircuts are now $14 and up. Mine cost $16 for a shoulderlength cut with some layering. Users/MeganCleary

20070308 15:35:58 nbsp I went in today to layer my hair and it turned out perfect! The lady didnt talk much but I like that she was just concentrating on my hair. For just the layers it cost me $16. Users/NicoleBush

20070402 22:53:37 nbsp Angie’s was recently joined by another great profesional stylist, Mela. She has been cutting my hair for the last seven years. I know her since she used to work at We Care Hair, and let me tell you every time I think I can trust my hair to someone else I always go back to her so she can fix it.  Users/CarlosAlvarado

20070418 18:26:45 nbsp Cut/Color. The staff was exceptional the best experience out of many salon I have been to. Everyone was extremely friendly and I absolutely love my hair! Users/MeagnOwens

20070504 15:53:59 nbsp I went to Angies today just to have the dead ends trimmed off (there were a lot in many layers) and she did a fantastic job! I am trying to grow out my layers, all of which had dead ends and she got rid of them all. And the price: $16! Well, its hard to beat the service for the price! Users/AmberMacdonald

20070504 15:54:18 nbsp Oh, and Angie was my stylist. Users/AmberMacdonald

20070601 22:28:25 nbsp I really enjoy the atmosphere I got my hair cut they dry and style it too Anamarie I think she is the owner was my stylist I really like my cut the price great  I recomend Anamarie. Users/teresa

20070609 12:12:25 nbsp I went a couple of years ago and had a good experience.  I went again today, and it was great.  I didnt even have an appointment, but I didnt have to wait at all, and my hair looks cute. Users/KateBaker

20070803 15:13:08 nbsp I read all the rave reviews, so I popped over to try out Angies for myself. I dont know who my stylist was, but I didnt like my experience. My stylist kept dropping the combs and spilled something all over at one point and had to stop to clean it up. Also, she did the one thing that annoys me the most: she parted my hair in the middle to cut it. Now it looks odd when I return it to its natural part on the side. Yes, it was inexpensive at $16, but I was not impressed with the service, nor am I happy with my cut.  Users/LauraKaroly

20070907 01:30:18 nbsp EXCELLENT HAIR CUTS!!!!i HIGHLY RECOMMEND THIS PLACE.Everyone do a great job and is only $14.00 dollars for mens all the girls are very nice . Users/thomasdimer

20070929 23:09:48 nbsp THANK YOU FOR MY HAIR CUT WAS GREAT THANK YOU MELA!MUCHAS GRACIAS ME GUSTO MUCHO JUSTO LO QUE QUERIA  ABLAN ESPANOL.  Users/mariaesthervillasenor

20071004 22:40:14 nbsp Very happy with all the hair dresses everyone there is really nice. Great hair cuts and fantastic sense of humor. A guys is only $14.00 dollars for hair cuts. Users/davidchang

20071118 17:10:04 nbsp I had a wonderful expeience at Angies salon . If youre a guy came to this salon.Walkins are welcome and Ive never waited long time Users/Franktovar

20071219 01:56:43 nbsp I went on a Monday around 1pm and it was busy. I had to wait an hour. Majority of the clientele (at least at the time I went) were older women getting their hair dyed or whatever. Although the person who worked on me was friendly, I did not like my hair cut. At first, my hair was cut unevenly, and after I had told her what to do to fix it, results were still bad. I would have been better off cutting it myself. Do what another person had suggested above, and bring in a picture for them to see. Otherwise, dont expect them to create something that would look good on you. Users/at86

20080131 11:30:20 nbsp Atmosphere was very relaxed.  The haircut was decent, a little choppy.  After reading all the great comments, I was expecting more.  It felt like I had to guide my stylist and tell her exactly what to do.  Decent experience, nothing worth raving about.  Probably wont go back.     Users/JennaChen

20080430 10:51:46 nbsp Great haircut for only 16 bucks! :) I had Sylvia do mine and it came out really, really well. Ive never been there for hair dye jobs but a friend of mine has aka SonjaSchaff and her hairs always cute. Users/simplyg00d

20080716 23:51:47 nbsp I had a great hair cut this is my 2th time Anamaria cut my hair and I loved .I really recommend you .If you dont like to wait you can make and appointment too. Users/marissacampos

20081010 17:14:00 nbsp I had my hair cut by Sylvia my first time. She isnt really good at layering my hair and she doesnt know how to cut side bangs. It was presentable but nothing great. My roommate got her haircut by Angie and it looked really good on her. So I went to Angie the second time. Angie asked me who cut my hair before because the layers were uneven but I didnt tell her it was Sylvia. Go to Angie if youre looking for a better haircut... but I wont come back here again. I think Connie from Kosmos is significantly better at cutting modern hair.  Users/PSL

20081023 21:21:43 nbsp I just got a great cut like always. Everybody is fantastic I like this place they are very professionals.I highly recommend this place.    Users/trinni

20081024 21:28:11 nbsp AMAZING

I moved to Davis from SF to attend UCD about 3years ago. For the first few months I was here, I traveled back to SF just to get my hair done. (If youre looking for someone in SF, email me... I know JUST the right girl!). But that got expensive. So I decided to go to Angies because of the good reviews it got, and was recommended by a friend.

I have been going to Angies for over 3 years now, and I never want to go anywhere else. I found the perfect place for me that can handle my college budget!

I have to tell all of you that it truly is a GREAT place! It is a very friendly and relaxing environment. They make you feel at home the second you walk in the door, and the quality of the service is tremendous. whether its a hair cut or coloring, you always come out looking fabulous. thats true with all of the stylists. i have had my hair cut by at least 3 of the stylists, and i have never disliked how it was cut. they are very good about talking with you first and discussing what you want. even as they are cutting, they check to make sure it is to your liking and are willing to make any changes. and when youre done, everyone compliments you on how great you look. granted, im sure thats part of promoting the biz, but they are always very genuine about it. the pricing is VERY reasonable. overall, this place is a very fun and comfortable environment. Trust me if you go you will always be in good hands.

Ali_CityGirl

 Users/AliWalker

20090202 19:37:38 nbsp just went today. got my hair cut by Mela. Shes very nice and very gentle with my hair. She concentrated on the style I wanted and discussed lengths of shortness with me. I recommend this place for affordable and comfort. I had long hair and chopped into something short and simple with bangs. all for $17. plus, Im glad they take walk in. I just walked in and got my haircut :) Users/ChiYang

20090214 16:20:35 nbsp My friend and I were looking for inexpensive haircuts in Davis. We were able to walk right in and be seen immediately, which is not what Im used to (I usually make appointments). The place is kinda small and looks like a house, which was offsetting until we peeked into the window and saw that all the stylists had cute hair (which is how I judge the quality of salons). Usually I have trouble finding a decent stylist because I am a woman who prefers very short spiky hair, which is hard to do correctly (you need a razor, etc) and Im used to paying $30+ for good cuts. The woman who cut my hair here did just as good a job as any expensive place, and for $15 (she gave me a $2 discount for having short hair). I was very impressed. I picked out a picture and she helped me customize it to what I wanted my hair to look like, and it was exactly what I wanted. I will definitely go back. Dont be turned off by it looking small, by people looking like they arent busy, or by the fact that everyone in there speaks Spanish constantly (though I speak a little bit of Spanish, so for me it felt homey). Im very pleased to have found a good stylist on a college student budget. Oh, and my friend loves her haircut too. Users/philoinferno

20090217 22:27:24 nbsp update I actually wont be back to this location, my haircut grew out very quickly last time due to the poor cutting and their prices keep rising. Users/simplyg00d

20090227 22:54:11 nbsp I love my hair cut just what I want!and only $17 dollars. Users/tomasa

20090427 15:39:31 nbsp Just went two days ago. I got somebody to cut my hair right when I walked in.. The lady did a nice job. Not too talkative (so not distracting herself), yet very careful to follow directions and always ask before doing something drastic. Im Korean and used to go to Korean hair salons in LA, but there were non in Davis.. I went to New Fashion Salon a few months ago and the cut was okay (not too bad) but they really gave me TOO MUCH layers, my hair was messy! But now, I got rid of all my layers at Angies. I love it! At New Fashion, I specifically asked for little layers but she gave me so much, so Angies was heaven for me! I highly recommend here. They follow directions well and its so cheap! Only $17 for a haircut!  Users/YuJinChoi

20090430 22:09:10 nbsp What I can said I love my hair cut and I pay only $17 dollars new style new look soooo great. Users/anny

20090526 02:18:18 nbsp AMAZING the best haircut I have ever had. The ladies are super nice and not only is it a great cut but it feels like you are only in there for a few minutes.  Users/ddavis

20090608 02:28:28 nbsp A friend recommended this place, and I went due to the cheap pricing. The salon looks nice and homely inside, the stylists spoke spanish the entire time. They werent the friendliest, but whatever. The haircut was EXTREMELY quick  I asked for layers, and I barely saw any. I wont be going back here, ever again. Users/shopaholic

20090612 11:15:28 nbsp I have gone to Angies several times in that past and was satisfied with my hair cut for the price I paid. Recently I went in without an appointment and Slyvia cut my hair.  I had a picture of what I wanted (which was a long bob with side swept bangs) and when she finished, I ended up looking like Kate from Jon & Kate + 8. Not what I wanted.  Short of that, it didnt look good or even. I had to fix it myself with scissors at home. I should have asked for my money back.  Angie is much better.  I highly recommend her. Avoid Sylvia.  She seems unhappy like she doesnt like her job and maybe needs to move on to another career. Users/JenniferGreen

20090824 21:21:42 nbsp The place got remodeled a couple of years ago and it looks great. They always make you feel welcomed even without an appointment and try to fit you in their tight schedule. They are really nice and ususally talk among each other wich makes you think they enjoy being there. I can not believe how low are the prices. I have long curly hair and use three tones of color which takes close to three hours to do. It always takes me a week ahead appointment and close to $300 at other salons and they did it here for $100 the moment I walked in. The results were identical to other expensive salons. I highly recommend this place. I also witnessed a very annoying and moody girl doing her hair there for her brothers wedding and Sylvia was extremely nice, and accomodating, making all the changes she requested. The girl brought a picture and decided during the service that she wanted to do several changes from the original picture. The girl looked really happy at the end, and I could not believe how much time, effort, and patience Sylvia put into making her happy for the very low price they charged her.  Users/Maga

20090926 16:32:32 nbsp Angie is a professional. My hair are thick and curly and many hair salons dont know how to cut this type of hair. Angie cut them so fast(25 minutes I was out)and she did exactly what I wanted + she straighten them and its only for 17$. She is the best hair stylist I have experienced in US so far. Thank you Angie! Users/Adelina

20091028 20:50:38 nbsp My husband was a customer there and was very dissatisfied,  He answered his cell phone when I called him for a medical emergency and was charged $5.  The owner was rude and obnoxious.  Not a great cut either. Buyer beware. Users/kbowen100

20100109 15:12:12 nbsp I saw this place across the street when I was at the CoOp and decided to try it out, especially seeing that they only charge $15 for a haircut! I made an appointment for the next day and was very satisfied with the service. They were ready for me when I got there and the haircut took only 15 minutes. Ive got long curly hair and they styled it really well, especially given the price and amount of time it took. I guess for womens cuts it must be $17, because thats what my final price was but hey, thats pretty great! Ill definitely be going back from here on out. Users/mlesblues

20100314 16:55:30 nbsp I went there a while back and took in a picture that came from one of those hair magazine (that even had instructions attach to it with what to ask for).  I showed the pic to Anamaria b/c she was the one doing my hair and restated the specifics from the magazine cutout.  She glanced at it for a second then set it down, never looking at it again, and gave me a completely different cut that was choppy and uneven.  Sure their prices are cheap, but you get what you pay for...cheap and crappy service.  Im better off getting my hair cut for free at those beauty school, at lease they do an accurate job in following instructions and requests. Not surprise theyre closing, well see how their new business do if the service stays the same. Users/kikao

20100315 21:59:01 nbsp I highly recommend this place i like all the girls everyone thats my hair for years and i always happy and all the times i changes my style . Users/Estelamantoya

20100326 11:20:58 nbsp The worst haircut Ive ever had!! I have thick, long straight hair and I asked my stylist  Angie  to put some layers in so that it didnt look too flat and straight. I even brought a photo of what I wanted my hair to look like. Should have been a simple, pretty generic layered cut. She proceeded to razor cut layers that started up by my ears and left the bottom of my hair super thin and straggly. I literally cried when I got home and looked at my hair. It took months to grow out and look seminormal. Also, during the cut she talked to her coworker/friend the whole time and pretty much ignored me until the end. Users/AmyLeigh

20100420 08:30:31 nbsp I just got my hair cut yesterday Fabulous
I got exactly what I asked for and my hair looks great!
I had got to anthor place last week and they did a horrible job, but Anamaria I belive was her name fixed it! I was soooo relieved! The place was kid of small but I guess who cares when your hair comes out looking GREAT!

I will be returning!  Users/JessicaMorgan

20100427 16:33:56 nbsp I have long hair and I got my hair cut here recently.  Angie is nice, shop is great, prices are great, but unfortunately, one of the stylists cut my hair too short.  This is the second time this has happened in Davis, Im just posting this so people see that no shop is perfect. Users/Darkfallin

20100505 17:14:44 nbsp Ive been here 3 times. The first 2 times I brought in a picture and explained how I wanted my hair done. I dont remember who did my hair, but she only got the basic shape of the hairstyle from the picture, and not much else. I went again today without a picture, and explicitly said several times that I wanted sideswept bangs. She didnt seem to know what those were and didnt quite cut my bangs the way I wanted. Thankfully, they still turned out okay when I went back home to adjust and style them myself.

In short, go here because theyre friendly and cheap, but not if youre looking for a new style. Users/AlishaTran

20100516 04:36:34 nbsp Ive been here about 5 times total, maybe 4, but out of those times I had 3 bad haircuts and with 3 different ladies. Theyre great and friendly, but dont really talk to you and instead to each other. In Spanish. Ive brought in pictures and one picture had a bunch of layers. The woman removed all of my layers and I ended up with a straight, boring haircut. I looked like Donna from That 70s Show. Not fun. I ended up going elsewhere to get it fixed. Users/HannahFolkes

20100808 14:17:56 nbsp Angie is amazing! I have had my hair cut multiple times here. I bring in a picture and she does it really quick and straightens my hair after for only $17. I used to pay over $60 for the same cut at pure beauty. Angie is wonderful and I will keep going to this place after I leave Davis.  Users/serafina

20110216 My husband and I have been going to this salon for 10 years. Angie is a very good hair dresser and her prices are fair. The salon in not stuffy but very welcoming. Users/LuzCamacho

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      SUBROUTINE MB03GD( N, B, LDB, D, LDD, MACPAR, Q, LDQ, U, LDU,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute an orthogonal matrix Q and an orthogonal symplectic
C     matrix U for a real regular 2-by-2 or 4-by-4 skew-Hamiltonian/
C     Hamiltonian pencil a J B' J' B - b D with
C
C           ( B11  B12 )      (  D11  D12  )      (  0  I  )
C       B = (          ), D = (            ), J = (        ),
C           (  0   B22 )      (   0  -D11' )      ( -I  0  )
C
C     such that J Q' J' D Q and U' B Q keep block triangular form, but
C     the eigenvalues are reordered. The notation M' denotes the
C     transpose of the matrix M.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil a J B' J' B - b D. N = 2 or N = 4.
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB, N)
C             The leading N-by-N part of this array must contain the
C             non-trivial factor of the decomposition of the
C             skew-Hamiltonian input matrix J B' J' B. The (2,1) block
C             is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= N.
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD, N)
C             The leading N/2-by-N part of this array must contain the
C             first block row of the second matrix of a J B' J' B - b D.
C             The matrix D has to be Hamiltonian. The strict lower
C             triangle of the (1,2) block is not referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= N/2.
C
C     MACPAR  (input)  DOUBLE PRECISION array, dimension (2)
C             Machine parameters:
C             MACPAR(1)  (machine precision)*base, DLAMCH( 'P' );
C             MACPAR(2)  safe minimum,             DLAMCH( 'S' ).
C             This argument is not used for N = 2.
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ, N)
C             The leading N-by-N part of this array contains the
C             orthogonal transformation matrix Q.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= N.
C
C     U       (output) DOUBLE PRECISION array, dimension (LDU, N)
C             The leading N-by-N part of this array contains the
C             orthogonal symplectic transformation matrix U.
C
C     LDU     INTEGER
C             The leading dimension of the array U.  LDU >= N.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             If N = 2 then DWORK is not referenced.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             If N = 2 then LDWORK >= 0; if N = 4 then LDWORK >= 12.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             = 1: B11 or B22 is a (numerically) singular matrix.
C
C     METHOD
C
C     The algorithm uses orthogonal transformations as described on page
C     22 in [1], but with an improved implementation.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
C         Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
C         Eigenproblems.
C         Tech. Rep., Technical University Chemnitz, Germany,
C         Nov. 2007.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, October 29, 2008.
C     V. Sima, Aug. 2009 (SLICOT version of the routine DHAFEX).
C
C     REVISIONS
C
C     V. Sima, Nov. 2009, July 2010, Nov. 2010.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil,
C     structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDB, LDD, LDQ, LDU, LDWORK, N
C
C     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), D( LDD, * ), DWORK( * ),
     $                   MACPAR( * ), Q( LDQ, * ), U( LDU, * )
C
C     .. Local Scalars ..
      INTEGER            I, ICS, IR, ITAU, IWRK1, IWRK2
      DOUBLE PRECISION   CL1, CL2, CO, CO2, CR1, CR2, EPS, F, F1, G, G1,
     $                   R, R1, S, SFMIN, SI, SI2, SL1, SL2, SMAX1,
     $                   SMAX2, SMIN1, SMIN2, SR1, SR2, T, T1
C
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEQR2, DGERQ2, DLACPY, DLARTG, DLASV2,
     $                   DORGR2, DORM2R, DSWAP, DSYR2K, MB01RU, MB04SU,
     $                   MB04WU
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
C
C     .. Executable Statements ..
C
C     For efficiency, the input arguments are not tested.
C
      INFO = 0
C
C     Computations.
C
      IF( N.EQ.4 ) THEN
C
C        Set machine constants.
C
         EPS   = MACPAR( 1 )
         SFMIN = MACPAR( 2 )
C
C        Compute the first two columns of H = inv( B' )*J'*D*inv( B )*J
C        in U, using the singular value decompositions of B11 and B22.
C
         CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CO, SI, R )
         F = CO*B( 1, 2 ) + SI*B( 2, 2 )
         G = CO*B( 2, 2 ) - SI*B( 1, 2 )
         CALL DLASV2( R, F, G, SMIN1, SMAX1, SR1, CR1, SL1, CL1 )
         IF( ABS( SMIN1 ).LT.MAX( SFMIN, EPS*ABS( SMAX1 ) ) ) THEN
            INFO = 1
            RETURN
         END IF
C
         CALL DLARTG( B( 3, 3 ), B( 4, 3 ), CO2, SI2, R )
         F = CO2*B( 3, 4 ) + SI2*B( 4, 4 )
         G = CO2*B( 4, 4 ) - SI2*B( 3, 4 )
         CALL DLASV2( R, F, G, SMIN2, SMAX2, SR2, CR2, SL2, CL2 )
         IF( ABS( SMIN2 ).LT.MAX( SFMIN, EPS*ABS( SMAX2 ) ) ) THEN
            INFO = 1
            RETURN
         END IF
C
C        Compute inv( B11' )*D11' and copy it in U12.
C
         R = ( CR1*D( 1, 1 ) + SR1*D( 1, 2 ) )/SMAX1
         F = ( CR1*D( 2, 1 ) + SR1*D( 2, 2 ) )/SMAX1
         T = ( CR1*D( 1, 2 ) - SR1*D( 1, 1 ) )/SMIN1
         G = ( CR1*D( 2, 2 ) - SR1*D( 2, 1 ) )/SMIN1
C
         R1 = CL1*R - SL1*T
         F1 = CL1*F - SL1*G
         T1 = CL1*T + SL1*R
         G1 = CL1*G + SL1*F
C
         U( 1, 3 ) = CO*R1 - SI*T1
         U( 2, 3 ) = CO*T1 + SI*R1
         U( 1, 4 ) = CO*F1 - SI*G1
         U( 2, 4 ) = CO*G1 + SI*F1
C
C        Compute D11*inv( B11 )*B12 + B12'*inv( B11' )*D11' - D12 in Q.
C
         Q( 1, 1 ) = D( 1, 3 )
         Q( 1, 2 ) = D( 1, 4 )
         Q( 2, 2 ) = D( 2, 4 )
C
         CALL DSYR2K( 'Upper', 'Transpose', 2, 2, ONE, U( 1, 3 ), LDU,
     $                B( 1, 3 ), LDB, -ONE, Q, LDQ )
C
C        Compute inv( B22 ) in U22.
C
         R =  CR2/SMAX2
         T =  SR2/SMAX2
         F = -SR2/SMIN2
         G =  CR2/SMIN2
C
         R1 = CL2*R - SL2*F
         T1 = CL2*T - SL2*G
         F1 = CL2*F + SL2*R
         G1 = CL2*G + SL2*T
C
         U( 3, 3 ) = CO2*R1 - SI2*F1
         U( 4, 3 ) = CO2*T1 - SI2*G1
         U( 3, 4 ) = CO2*F1 + SI2*R1
         U( 4, 4 ) = CO2*G1 + SI2*T1
C
C        Compute H11 = -inv( B11' )*D11'*inv( B22 ) in U11.
C
         CALL DGEMM( 'No Transpose', 'No Transpose', 2, 2, 2, -ONE,
     $               U( 1, 3 ), LDU, U( 3, 3 ), LDU, ZERO, U, LDU )
C
C        Compute H21 = inv( B22' )*Q*inv( B22 ) in U21.
C
         CALL MB01RU( 'Upper', 'Transpose', 2, 2, ZERO, ONE, U( 3, 1 ),
     $                LDU, U( 3, 3 ), LDU, Q, LDQ, DWORK, 4, INFO )
         U( 4, 1 ) = U( 3, 2 )
C
         S = -( U( 1, 1 ) + U( 2, 2 ) )
C
C        Compute Y1, the first two columns of Y = H*H - s*H + t*I4,
C        where H = ( Hij ), i,j = 1,2, H12 = 0, t = det(H22).
C        H is real lower Hamiltonian block triangular with the
C        desired eigenvalues in the leading positions.
C
         T = U( 1, 1 )*U( 2, 2 ) - U( 2, 1 )*U( 1, 2 )
C
         CALL DLACPY( 'Full', 4, 2, U, LDU, Q, LDQ )
         Q( 1, 3 ) = U( 1, 1 ) - S
         Q( 2, 3 ) = U( 2, 1 )
         Q( 3, 3 ) = U( 1, 1 )
         Q( 4, 3 ) = U( 2, 1 )
         Q( 1, 4 ) = U( 1, 2 )
         Q( 2, 4 ) = U( 2, 2 ) - S
         Q( 3, 4 ) = U( 1, 2 )
         Q( 4, 4 ) = U( 2, 2 )
         CALL DGEMM( 'No Transpose', 'No Transpose', 4, 2, 2, ONE,
     $               Q, LDQ, Q( 1, 3 ), LDQ, ZERO, U, LDU )
         CALL DGEMM( 'Transpose', 'No Transpose', 2, 2, 2, -ONE,
     $               Q( 3, 3 ), LDQ, Q( 3, 1 ), LDQ, ONE, U( 3, 1 ),
     $               LDU )
         U( 1, 1 ) = U( 1, 1 ) + T
         U( 2, 2 ) = U( 2, 2 ) + T
C
C        Compute the relevant part of the orthogonal symplectic
C        matrix U performing the symplectic QR factorization of Y1.
C        Workspace: need   10.
C
         ICS   = 1
         ITAU  = ICS  + 4
         IWRK2 = ITAU + 2
         CALL MB04SU( 2, 2, U( 1, 1 ), LDU, U( 3, 1 ), LDU,
     $                DWORK( ICS ), DWORK( ITAU ), DWORK( IWRK2 ),
     $                LDWORK-IWRK2+1, INFO )
         CALL MB04WU( 'No Transpose', 'No Transpose', 2, 2, 2,
     $                U( 1, 1 ), LDU, U( 3, 1 ), LDU, DWORK( ICS ),
     $                DWORK( ITAU ), DWORK( IWRK2 ), LDWORK-IWRK2+1,
     $                INFO )
C
C        Compute J*U in U.
C
         U( 1, 3 ) =  U( 1, 1 )
         U( 2, 3 ) =  U( 2, 1 )
         U( 1, 4 ) =  U( 1, 2 )
         U( 2, 4 ) =  U( 2, 2 )
C
         U( 1, 1 ) = -U( 3, 1 )
         U( 2, 1 ) = -U( 4, 1 )
         U( 1, 2 ) = -U( 3, 2 )
         U( 2, 2 ) = -U( 4, 2 )
C
         U( 3, 1 ) = -U( 1, 3 )
         U( 4, 1 ) = -U( 2, 3 )
         U( 3, 2 ) = -U( 1, 4 )
         U( 4, 2 ) = -U( 2, 4 )
C
         U( 3, 3 ) =  U( 1, 1 )
         U( 4, 3 ) =  U( 2, 1 )
         U( 3, 4 ) =  U( 1, 2 )
         U( 4, 4 ) =  U( 2, 2 )
C
C        Compute U'*B using structure.
C
         CALL DGEMM( 'Transpose', 'No Transpose', 4, 2, 2, ONE, U,
     $               LDU, B, LDB, ZERO, Q, LDQ )
         CALL DGEMM( 'Transpose', 'No Transpose', 4, 2, 4, ONE, U,
     $               LDU, B( 1, 3 ), LDB, ZERO, Q( 1, 3 ), LDQ )
C
C        Determine Q using different elimination orders in the RQ and
C        QR factorizations of U'*B.
C        Workspace: need   12.
C
         ITAU  = 1
         IWRK1 = ITAU + N
         CALL DGERQ2( N, N, Q, LDQ, DWORK( ITAU ), DWORK( IWRK1 ),
     $                INFO )
         IR    = IWRK1
         IWRK2 = IR + 4
         DWORK( IR )   = Q( 3, 3 )
         DWORK( IR+1 ) = Q( 3, 4 )
         DWORK( IR+2 ) = ZERO
         DWORK( IR+3 ) = Q( 4, 4 )
         CALL DORGR2( N, N, N, Q, LDQ, DWORK( ITAU ), DWORK( IWRK2 ),
     $                INFO )
C
         DO 20 I = 2, N
            CALL DSWAP( N-I+1, Q( I, I-1 ), 1, Q( I-1, I ), LDQ )
   20    CONTINUE
C
         CALL DGEQR2( 2, 2, DWORK( IR ), 2, DWORK( ITAU ),
     $                DWORK( IWRK2 ), INFO )
         CALL DORM2R( 'Right', 'No Transpose', N, 2, 2, DWORK( IR ), 2,
     $                DWORK( ITAU ), Q( 1, 3 ), LDQ, DWORK( IWRK2 ),
     $                INFO )
      ELSE
C
         G = TWO*B( 1, 1 )*B( 2, 2 )*D( 1, 1 )
         CALL DLARTG( B( 1, 1 )*B( 2, 2 )*D( 1, 2 ), G, CO, SI, R )
         Q( 1, 1 ) =  CO
         Q( 2, 1 ) = -SI
         Q( 1, 2 ) =  SI
         Q( 2, 2 ) =  CO
         CALL DLARTG( B( 1, 1 )*Q( 1, 1 ) + B( 1, 2 )*Q( 2, 1 ),
     $                B( 2, 2 )*Q( 2, 1 ), CO, SI, R )
         U( 1, 1 ) =  CO
         U( 2, 1 ) =  SI
         U( 1, 2 ) = -SI
         U( 2, 2 ) =  CO
      END IF
C
      RETURN
C *** Last line of MB03GD ***
      END

max_stars_repo_name: bnavigator/SLICOT-Reference

max_issues_repo_name: RJHKnight/slicotr

max_forks_repo_name: RJHKnight/slicotr


module test_implementation
  integer, public, protected :: i
end module test_implementation


! { dg-do run }
program main
  character(len=3), dimension(2) :: a
  a(1) = 'aaa'
  a(2) = 'bbb'
  if (maxloc(a,dim=1) /= 2) STOP 1
  if (minloc(a,dim=1) /= 1) STOP 2

end program main


text:
! { dg-do compile }
! Test the fix for pr41167, in which the first argument of 'pack', below,
! was simplified incorrectly, with the results indicated.
!
! Contributed by Harald Anlauf <anlauf@gmx.de>
!
program gfcbug88
  implicit none
  type t
     character(len=8) :: name
  end type t
  type(t) ,parameter :: obstyp(2)= (/ t ('A'), t ('B') /)
  character(9) :: chr(1)

  print *, pack (" "//obstyp(:)% name, (/ .true., .false. /))  ! Used to ICE on compilation
  chr = pack (" "//obstyp(:)% name, (/ .true., .false. /))  ! Used to give conversion error
end program gfcbug88