text:
C Copyright(C) 2009-2017 National Technology & Engineering Solutions of
C Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C     * Neither the name of NTESS nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C=======================================================================
      SUBROUTINE TPSHOW (SHOTYP, NAMES, MAPEL, MAPND)
C=======================================================================

C   --*** TPSHOW *** (TPLOT) Display TPLOT parameter information
C   --   Written by Amy Gilkey - revised 12/17/87
C   --
C   --TPSHOW displays the TPLOT plot parameters.
C   --
C   --The SHOW options with the items they display are:
C   --   TYPLOT   - the curves to be plotted for the plot set
C   --   XYPLOT   -
C   --   PLOT     -
C   --   HARDCOPY -
C   --   NEUTRAL  -
C   --
C   --Parameters:
C   --   SHOTYP - IN - the expanded SHOW option string
C   --   NAMES - IN - the variable names
C   --
C   --Common Variables:
C   --   Uses NTPVAR, TIMPLT, ITVID, ITVNE of /TPVARS/

      include 'params.blk'
      include 'tpvars.blk'

      CHARACTER*(*) SHOTYP
      CHARACTER*(*) NAMES(*)
      INTEGER MAPEL(*), MAPND(*)

      LOGICAL ISABRT
      CHARACTER*(1024) PV1, PV2
      CHARACTER*2 STR2

      IF ((SHOTYP .EQ. 'TYPLOT') .OR. (SHOTYP .EQ. 'XYPLOT')
     &   .OR. (SHOTYP .EQ. 'PLOT') .OR. (SHOTYP .EQ. 'HARDCOPY')
     &   .OR. (SHOTYP .EQ. 'NEUTRAL')) THEN
         N = 1
         DO 100 NP = 1, NTPCRV
            IF (ISABRT ()) RETURN
            IF (TIMPLT) THEN
               PV1 = 'TIME'
            ELSE
               CALL TPLABV (-1, ITVID(N), NAMES(ITVID(N)), ITVNE(N),
     &            PV1, MAPEL, MAPND)
               N = N + 1
            END IF
            CALL TPLABV (-1, ITVID(N), NAMES(ITVID(N)), ITVNE(N), PV2,
     *        MAPEL, MAPND)
            N = N + 1
            WRITE (STR2, '(I2)', IOSTAT=IDUM) NP
            WRITE (*, 10000) 'Curve ', STR2, ' :  ', PV2(:LENSTR(PV2)),
     &         '  -vs-  ', PV1(:LENSTR(PV1))
  100    CONTINUE

      END IF

      RETURN

10000  FORMAT (1X, 10A)
      END

ext: f

max_stars_repo_name: mathstuf/seacas

max_stars_repo_licenses: BSD-3-Clause NetCDF Zlib MIT

max_issues_repo_name: mathstuf/seacas

max_issues_repo_licenses: BSD-3-Clause NetCDF Zlib MIT

max_forks_repo_name: mathstuf/seacas

max_forks_repo_licenses: BSD-3-Clause NetCDF Zlib MIT


text:
module a

contains
	subroutine f(x)
		integer x
		write(*, *) 1, 2, x
	end subroutine
end module

max_stars_repo_name: nicolasessisbreton/fython

max_issues_repo_name: nicolasessisbreton/fython

max_forks_repo_name: nicolasessisbreton/fython


text:
!
! m_vstringformat --
!
!   The module m_vstringformat provides services to format one string, that is to
!   say to convert a basic fortran data type into a dynamic vstring.
!   The current version of m_vstringformat can handle logical variables
!   and integers of all kinds. The format can be given by the client code,
!   or computed automatically. The format can be given as a basic character
!   string, or as a vstring.
!
!   Overview
!   The only method provided here is vstring_format, which takes one basic
!   basic fortran data type as the first argument (and, optionnaly, a format),
!   and returns a dynamic string which represents that value.
!
!   Formatting logical values
!   One can format a logical into a vstring with automatic or explicit format.
!   In the following sample, one format the ".false." logical into a vstring.
!   After formatting, the string "mystring" has a length of 1 and its content
!   is "F".
!
!      logical :: mybool
!      type ( t_vstring ) :: mystring
!      mybool = .false.
!      mystring = vstring_format ( mybool )
!
!   In the following sample, one format the ".false." logical into a vstring
!   with an explicit format given as a character string :
!
!      logical :: mybool
!      type ( t_vstring ) :: mystring
!      mybool = .false.
!      mystring = vstring_format ( mybool , "(L3)" )
!
!   After formatting, the string "mystring" has a length of 3 and its content
!   is "  F".
!
!   In the following sample, one format the ".false." logical into a vstring
!   with an explicit format given as a vstring :
!
!      logical :: mybool
!      type ( t_vstring ) :: mystring
!      type ( t_vstring ) :: myformat
!      mybool = .false.
!      call vstring_new ( myformat , "(L3)" )
!      mystring = vstring_format ( mybool , myformat )
!      call vstring_free ( myformat )
!
!   Formatting integer values
!   One can format an integer into a vstring, with automatic or explict format.
!   The string formatting system can handle all fortran kinds of integers.
!   The automatic format makes so that the resulting string has the
!   length which exactly matches the number of digits necessary to represent
!   the integer :
!   - if the integer is negative, the "-" sign is at the begining of the string,
!   - if the integer is positive, the "+" sign is not in the string.
!   In the following example, one formats the integer 2008 into a vstring.
!   After formatting, the string has a length of 4 and its content is the
!   string "2008".
!
!      type ( t_vstring ) :: mystring
!      mystring = vstring_format ( 2008 )
!
!   To acheive the same effect, one can use the "I0" format of the fortran 90
!   standard :
!
!      type ( t_vstring ) :: mystring
!      mystring = vstring_format ( 2008 , "(I0)" )
!
!   The component can handle long integers with specified kinds 1, 2, 4 or 8.
!   In the following example, one automatically format a 32-bits integer
!   (1073741824 = 2**31) into a dynamic string.
!
!      integer (kind=4) :: integerkind4 = 1073741824
!      mystring = vstring_format ( integerkind4 )
!
!   After formatting, the string has a length of 4 and its content is the
!   string "1073741824".
!
!   Limitations
!   The current implementation of the string formatting is based
!   on the standard "write" fortran statement, which takes
!   a basic character string as argument.
!   Moreover the format given to the string formatting command
!   is not analysed at all, so that the length of the resulting
!   string is not computed.
!   The current component use therefore a character string of
!   fixed length VSTRING_FORMAT_MAXIMUM_FORMAT_LENGTH.
!   This leads to at least two limitations :
!   - if the client code has to manage formated strings which length is over
!     VSTRING_FORMAT_MAXIMUM_FORMAT_LENGTH characters, the
!     current algorithm will generate an error at execution time.
!   - the "write" statement has to manage a long string, even
!     if the result is short, which raise performances issues.
!
!   The current string formatting takes only one value.
!   An effective implementation would in fact take a list of
!   one or more arguments, which may be of different types.
!
!   The current implementation does not manage real values.
!
!   The limitations of the current component are so strong that the
!   component should not be released... but is useful to format
!   integers and that is why it has been finally released.
!
!   Planned features
!   It is expected that future releases of this component can manage
!   more basic data types, including real types of all kinds.
!   Future releases may also extend the formats by taking into account
!   string formatting coming from other languages than fortran (for example C),
!   including:
!   - the "-" specification which specifies that the converted argument
!     should be left-justified in its field
!   - the "+" specification which specifies that a number should always
!     be printed with a sign, even if positive.
!   - etc...
!
! Copyright (c) 2008 Michael Baudin michael.baudin@gmail.com
!
! $Id: m_vstringformat.f90,v 1.2 2008/06/12 16:23:47 relaxmike Exp $
!
!
module m_vstringformat
  use m_vstring, only : &
       t_vstring, &
       vstring_new, &
       vstring_free , &
       vstring_exists , &
       vstring_length , &
       vstring_range , &
       vstring_cast , &
       vstring_append
  implicit none
  private
  !
  ! Public methods
  !
  public :: vstring_format
  !
  ! vstring_format --
  !   Generic converter from a basic fortran data type into a vstring.
  !   Returns a new dynamic string with type t_vstring by formating the
  !   given value against the optional format fmt.
  ! Arguments :
  !   value : logical to format
  !     or integer of kind 1, 2, 4 or 8 to format
  !   fmt, optional : if provided, then this format is used to compute the
  !     new string. If format is provided, it may be either with a character(len=*) type
  !     or with a t_vstring type.
  !     If format is not provided, an automatic format is computed and applied
  !     to compute the new string. With automatic format, the computed
  !     string has a minimum length, that is, does not contain any blank and
  !     begins with "-" only if the value is a strictly negative integer.
  !
  interface vstring_format
     !
     ! Logical
     !
     module procedure vstring_format_auto_logical
     module procedure vstring_format_char_logical
     module procedure vstring_format_vstring_logical
     !
     ! Integer
     !
     module procedure vstring_format_auto_integer_kind1
     module procedure vstring_format_auto_integer_kind2
     module procedure vstring_format_auto_integer_kind4
     module procedure vstring_format_auto_integer_kind8
     module procedure vstring_format_char_integer_kind1
     module procedure vstring_format_char_integer_kind2
     module procedure vstring_format_char_integer_kind4
     module procedure vstring_format_char_integer_kind8
     module procedure vstring_format_vstring_integer_kind1
     module procedure vstring_format_vstring_integer_kind2
     module procedure vstring_format_vstring_integer_kind4
     module procedure vstring_format_vstring_integer_kind8
  end interface vstring_format
  !
  ! Set to true to stop whenever an error comes in the vstring component.
  logical, save :: vstringformat_stoponerror = .true.
  !
  ! Constants
  !
  integer, parameter :: VSTRING_FORMAT_MAXIMUM_FORMAT_LENGTH = 1000
contains
  !
  ! vstring_format_auto_logical --
  !   Returns a new vstring by formatting a logical with automatic format.
  !
  function vstring_format_auto_logical ( value ) result ( newstring )
    logical , intent(in) :: value
    type ( t_vstring ) :: newstring
    character(len=1) :: charlength1
    write ( charlength1 , "(l1)" ) value
    call vstring_new ( newstring , charlength1 )
  end function vstring_format_auto_logical
  !
  ! vstring_format_char_logical --
  !   Returns a new vstring by formatting a logical with the given format.
  !
  function vstring_format_char_logical ( value , fmt ) result ( newstring )
    logical , intent(in) :: value
    character(len=*) , intent(in) :: fmt
    type ( t_vstring ) :: newstring
    ! TODO : what if the logical is expected to be formatted with more than the maximum possible number of characters ?
    character(len=VSTRING_FORMAT_MAXIMUM_FORMAT_LENGTH) :: charstring
    write ( charstring , fmt ) value
    !
    ! Note:
    !   The "trim" removes all trailing blanks and, since fortran add
    !   blanks only at the left, the string result of trim(charstring) is
    !   the expected one.
    !
    call vstring_new ( newstring , trim(charstring) )
  end function vstring_format_char_logical
  !
  ! vstring_format_vstring_logical --
  !   Returns a new vstring by formatting a logical with the given vstring format.
  !
  function vstring_format_vstring_logical ( value , fmt ) result ( newstring )
    logical , intent(in) :: value
    type ( t_vstring ) , intent(in) :: fmt
    type ( t_vstring ) :: newstring
    character(len=vstring_length(fmt)) :: fmt_charstring
    ! Downgrade the format to a character string
    call vstring_cast ( fmt , fmt_charstring )
    newstring = vstring_format_char_logical ( value , fmt_charstring )
  end function vstring_format_vstring_logical
  !
  ! vstring_format_auto_integer_kind1 --
  !   Format an integer(kind=1) into a vstring.
  ! Arguments :
  !   value : integer of kind 1 to format
  !   fmt, optional : if provided, then this format is used to compute the
  !     new string.
  !     If not provided, an automatic format is computed and applied
  !     to compute the new string. With automatic format, the computed
  !     string has a minimum length, that is, does not contain any blank and
  !     begins with "-" only if the value is a strictly negative integer.
  !     The format may be provided either with a character(len=*) type
  !     or with a t_vstring type.
  !
#define _INTEGER_FORMAT_VSTRING_ROUTINE vstring_format_vstring_integer_kind1
#define _INTEGER_FORMAT_CHAR_ROUTINE vstring_format_char_integer_kind1
#define _INTEGER_FORMAT_AUTO_ROUTINE vstring_format_auto_integer_kind1
#define _INTEGER_COMPUTE_AUTOFORMAT_ROUTINE vstring_compute_autoformat_integer_kind1
#define _INTEGER_COMPUTE_CHARNB vstring_format_intcharnb_kind1
#define _INTEGER_KIND 1
#include "m_vstringformat_integerkind_template.f90"
#undef _INTEGER_FORMAT_AUTO_ROUTINE
#undef _INTEGER_KIND
#undef _INTEGER_COMPUTE_AUTOFORMAT_ROUTINE
#undef _INTEGER_COMPUTE_CHARNB
#undef _INTEGER_FORMAT_CHAR_ROUTINE
#undef _INTEGER_FORMAT_VSTRING_ROUTINE
  !
  ! vstring_format_auto_integer_kind2 --
  !   Format an integer(kind=2) into a vstring.
  ! Arguments :
  !   value : integer of kind 2 to format
  !   fmt, optional : if provided, then this format is used to compute the
  !     new string.
  !     If not provided, an automatic format is computed and applied
  !     to compute the new string. With automatic format, the computed
  !     string has a minimum length, that is, does not contain any blank and
  !     begins with "-" only if the value is a strictly negative integer.
  !     The format may be provided either with a character(len=*) type
  !     or with a t_vstring type.
  !
#define _INTEGER_FORMAT_VSTRING_ROUTINE vstring_format_vstring_integer_kind2
#define _INTEGER_FORMAT_CHAR_ROUTINE vstring_format_char_integer_kind2
#define _INTEGER_FORMAT_AUTO_ROUTINE vstring_format_auto_integer_kind2
#define _INTEGER_COMPUTE_AUTOFORMAT_ROUTINE vstring_compute_autoformat_integer_kind2
#define _INTEGER_COMPUTE_CHARNB vstring_format_intcharnb_kind2
#define _INTEGER_KIND 2
#include "m_vstringformat_integerkind_template.f90"
#undef _INTEGER_FORMAT_AUTO_ROUTINE
#undef _INTEGER_KIND
#undef _INTEGER_COMPUTE_AUTOFORMAT_ROUTINE
#undef _INTEGER_COMPUTE_CHARNB
#undef _INTEGER_FORMAT_CHAR_ROUTINE
#undef _INTEGER_FORMAT_VSTRING_ROUTINE
  !
  ! vstring_format_auto_integer_kind4 --
  !   Format an integer(kind=4) into a vstring with automatic format.
  ! Arguments :
  !   value : integer of kind 8 to format
  !   fmt, optional : if provided, then this format is used to compute the
  !     new string.
  !     If not provided, an automatic format is computed and applied
  !     to compute the new string. With automatic format, the computed
  !     string has a minimum length, that is, does not contain any blank and
  !     begins with "-" only if the value is a strictly negative integer.
  !     The format may be provided either with a character(len=*) type
  !     or with a t_vstring type.
  !
#define _INTEGER_FORMAT_VSTRING_ROUTINE vstring_format_vstring_integer_kind4
#define _INTEGER_FORMAT_CHAR_ROUTINE vstring_format_char_integer_kind4
#define _INTEGER_FORMAT_AUTO_ROUTINE vstring_format_auto_integer_kind4
#define _INTEGER_COMPUTE_AUTOFORMAT_ROUTINE vstring_compute_autoformat_integer_kind4
#define _INTEGER_COMPUTE_CHARNB vstring_format_intcharnb_kind4
#define _INTEGER_KIND 4
#include "m_vstringformat_integerkind_template.f90"
#undef _INTEGER_FORMAT_AUTO_ROUTINE
#undef _INTEGER_KIND
#undef _INTEGER_COMPUTE_AUTOFORMAT_ROUTINE
#undef _INTEGER_COMPUTE_CHARNB
#undef _INTEGER_FORMAT_CHAR_ROUTINE
#undef _INTEGER_FORMAT_VSTRING_ROUTINE
  !
  ! vstring_format_auto_integer_kind8 --
  !   Format an integer(kind=8) into a vstring with automatic format.
  ! Arguments :
  !   value : integer of kind 8 to format
  !   fmt, optional : if provided, then this format is used to compute the
  !     new string.
  !     If not provided, an automatic format is computed and applied
  !     to compute the new string. With automatic format, the computed
  !     string has a minimum length, that is, does not contain any blank and
  !     begins with "-" only if the value is a strictly negative integer.
  !     The format may be provided either with a character(len=*) type
  !     or with a t_vstring type.
  !
#define _INTEGER_FORMAT_VSTRING_ROUTINE vstring_format_vstring_integer_kind8
#define _INTEGER_FORMAT_CHAR_ROUTINE vstring_format_char_integer_kind8
#define _INTEGER_FORMAT_AUTO_ROUTINE vstring_format_auto_integer_kind8
#define _INTEGER_COMPUTE_AUTOFORMAT_ROUTINE vstring_compute_autoformat_integer_kind8
#define _INTEGER_COMPUTE_CHARNB vstring_format_intcharnb_kind8
#define _INTEGER_KIND 8
#include "m_vstringformat_integerkind_template.f90"
#undef _INTEGER_FORMAT_AUTO_ROUTINE
#undef _INTEGER_KIND
#undef _INTEGER_COMPUTE_AUTOFORMAT_ROUTINE
#undef _INTEGER_COMPUTE_CHARNB
#undef _INTEGER_FORMAT_CHAR_ROUTINE
#undef _INTEGER_FORMAT_VSTRING_ROUTINE
  !
  ! vstringformat_error --
  !   Generates an error with the given error message
  !
  subroutine vstringformat_error ( this , message )
    implicit none
    type ( t_vstring ) , intent(in), optional :: this
    type ( t_vstring ) , intent (in) :: message
    character ( len = 40 ) :: this_chars
    type ( t_vstring ) :: this_subpart
    integer :: length
    integer, parameter :: length_max = 40
    logical :: isallocated
    character(len=1000) :: message_char
    write ( * , * ) "Internal error in m_vstring"
    if ( present ( this ) ) then
       length =  vstring_length ( this )
       isallocated = vstring_exists ( this )
       if ( isallocated ) then
          write ( * , * ) "Length:" , length
          if ( length < length_max ) then
             call vstring_cast ( this , this_chars )
             write ( * , * ) "Content:", trim(this_chars)
          else
             this_subpart = vstring_range ( this , 1 , 40 )
             call vstring_cast ( this_subpart , this_chars )
             write ( * , * ) "Content:", this_chars, "..."
             call vstring_free ( this_subpart )
          endif
       endif
    endif
    call vstring_cast ( message , message_char )
    write ( * , * ) "Message :", trim( message_char )
    if ( vstringformat_stoponerror ) then
       STOP
    endif
  end subroutine vstringformat_error
  !
  ! vstringformat_set_stoponerror --
  !   Configure the behaviour of the component whenever an
  !   error is met.
  !   If stoponerror is true, then the execution stops if an error is encountered.
  !   If stoponerror is false, then the execution continues if an error is encountered.
  !   In both cases, a message is displayed on standard output.
  !
  subroutine vstringformat_set_stoponerror ( stoponerror )
    logical , intent(in) :: stoponerror
    vstringformat_stoponerror = stoponerror
  end subroutine vstringformat_set_stoponerror
end module m_vstringformat

max_stars_repo_name: dorrabbkhan/atlnts-infrastructure

max_issues_repo_name: TerribleDev/Fortran-docker-mvc

max_forks_repo_name: TerribleDev/Fortran-docker-mvc


text:
AmLin loves Davis, the town really grew on her in the 7 years she lived there while getting her BS in Nutrition Science and MS in Nutritional Biology. She currenty resides in Woodland (Davis evil twin as someone on Wiki called it...seems a bit harsh) because she could actually afford a house there. For now, shes happy living in Woodland, eating in Davis, and working in Sacramento at the Network for a Healthy California. Her favorite Wiki activity is commenting on FOOD!

Likes:
Nugget Market, Stones Cafe & Catering Stones Cafe, Sophias, Icekrimski Cafe Icekrimski, InNOut, Nobu Hiro, Habit Burger, Tazzina BistroWoodland (if you havent been there before, you must make the trip)

Dislikes:
Greystone Apartments, Davis Swim and Fitness Club Davis Swim And Fitness

On the Fence:
Bistro 33, Crepeville, Mustard Seed

Cart bounties are worked out amongst vendors who shag them! People are really constantly sideshowing in woodland?  Users/StevenDaubert

In my previous neighborhood, which was very family oriented and near a large park, yes, every night I could hear street racing, sideshowing, you name it. Since moving to a neighborhood thats still basically a construction zone, I havent seen any of this, but dont yet know if that will be the case at some point. I have no idea what the appeal is of this type of behavior. Users/AmLin

20110223 10:09:32 nbsp /Talk pages are usually used to talk about how to edit the pages. Like, if there is a dispute about content, its worked out on a /talk page. Theyre usually deleted after the conflict is over. You posted in the right place. Users/WilliamLewis

20110223 11:30:42 nbsp Good to know...thank you very much! Users/AmLin

20110808 14:13:51 nbsp I recommend Zen Toro for your local upscaleish sushi needs. Users/TomGarberson

20110808 15:19:43 nbsp Yes! And with Zen Toro I can forget that heinous parking lot altogether! Will do, thanks.  Users/AmLin

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
program lonlat2grd
  implicit none

  character*200 inname, fnam, xyzfile, outname
  character*100 netid, staid
  integer N, ii, nxt, nyt, nzt, nx, ny, nz, xg, yg, zg
  double precision lon, lat, dep, fdump
  integer, dimension(3) :: coords, ns, dims
  double precision, dimension(4,2)::box
  integer izone

  call getarg(1,inname)
  open(11,file=inname,form='formatted')
  read(11,'(a)') xyzfile
  print*, xyzfile
  read(11,*) izone
  read(11,'(a)') fnam
  print*, fnam
  read(11,'(a)') outname
  print*, outname
  read(11,*) N
  print*, N
  close(11)

  open(11,file=xyzfile,form='formatted')
  read(11,*) nx, ny, nz
  print*, nx, ny, nz
  read(11,*) (dims(ii),ii=1,3)
  print*, dims
  read(11,*) nxt, nyt, nzt
  print*, nxt, nyt, nzt
  close(11)

  open(11,file=fnam,form='formatted')
  open(12,file=outname,form='formatted')
  open(13,file=trim(outname)//'.miss',form='formatted')

  do ii=1,N
     read(11,*) lat, lon, dep
     print*, '**********************************************'
     print*, ii, lon, lat, dep
     print*, '**********************************************'

     call findnode(xyzfile,lat,lon,dep,coords,ns,box,izone)
     xg=coords(1)*nxt+ns(1)
     yg=coords(2)*nyt+ns(2)
     zg=coords(3)*nzt+ns(3)
     if (xg.ge.1.and.xg.le.nx.and.yg.ge.1.and.yg.le.ny.and.zg.ge.1.and.zg.le.nz) then
        write(12,*) ii-1, xg, yg, zg
     else
        write(13,*) ii-1
     endif
  enddo
  close(11)
  close(12)
  close(13)
end program lonlat2grd

max_stars_repo_name: SCECcode/cvmsi

max_issues_repo_name: SCECcode/cvmsi

max_forks_repo_name: SCECcode/cvmsi


text:
!-----------------------------------------------------
!PHY1038 Assignment 1 - Newton-Raphson root finding
!URN 6309823 - Penguin Lab Group 1K
!February 24th 2015
!-----------------------------------------------------

PROGRAM Newton_Raphson
IMPLICIT NONE
REAL :: x,x1,a,b,c,d,t
INTEGER :: j,k

WRITE(6,*) " "
WRITE(6,*) " "
WRITE(6,*) "This program finds the roots of a cubic function using the Newton-Raphson method,"
WRITE(6,*) " "
WRITE(6,*) "i.e. it finds all possible values of x which satisfy the equation: f(x)=ax^3+bx^2+cx+d=0."
WRITE(6,*) " "
WRITE(6,*) " "

!I had to change this so that the coeficients are defined individually. Then I an input them into the cubic equation.

WRITE(6,*) "Please input a value for a."
READ(5,*) a
WRITE(6,*) " "
WRITE(6,*) "Please input a value for b."
READ(5,*) b
WRITE(6,*) " "
WRITE(6,*) "Please input a value for c."
READ(5,*) c
WRITE(6,*) " "
WRITE(6,*) "Please input a value for d."
READ(5,*) d
WRITE(6,*) " "
WRITE(6,*) " "
WRITE(6,*) "Make a guess as a first approximation to the root of the function (x); write down this value."
READ(5,*) x1
WRITE(6,*) " "
WRITE(6,*) " "

!'t' remains as the initial guess so that it can be referenced later

t=x1
x=x1

!This is a do loop which uses the formulat x1=x0-f(x0)/f'(x0) to find an estimate of a root of the cubic equation

!-----------------------------------------------------

k=1

DO j=1,100
  x1=x-(a*x**3+b*x**2+c*x+d)/(3*a*x**2+2*b*x+c)
    IF (ABS(x1-x) <1E-6) EXIT
  x=x1
  k=k+1
END DO

!------------------------------------------------------
WRITE(6,*) "The cubic equation in question is:",a,"x^3+",b,"x^2+",c,"x+",d
WRITE(6,*) " "
WRITE(6,*) "This is a root of the cubic equation to a tolerance of 10^-6:", x1
WRITE(6,*) " "
WRITE(6,*) "It took",k,"iterations to find this root"
WRITE(6,*) " "
WRITE(6,*) "The initial guess for a root of the cubic equation was:",t
WRITE(6,*) " "
WRITE(6,*) "Please repeat this program with different values for the initial guess until three roots of the cubic equation are found"

END PROGRAM Newton_Raphson

max_stars_repo_name: WilliamHoltam/computational-physics

max_issues_repo_name: WilliamHoltam/computational-physics

max_forks_repo_name: WilliamHoltam/computational-physics


text:
module derivatives_z_mod

USE Variablen
USE sync_mod
USE wang_johnson_mod

CONTAINS

subroutine Dphi_Dz_p(phi,sphi,qi_i,qi_nr,qi_r)

	IMPLICIT NONE

	INTEGER::h,i,j,k
	REAL::phi(-1:m_local+2,-1:n_local+2,-1:o_local+2)
	REAL,intent(out)::sphi(1:m_local,1:n_local,1:o_local)
	REAL::qi_i,qi_r,qi_nr,rel
	INTEGER::image(3)

Do j=1,m_local
	DO i=1,n_local

		sphi(j,i,1)=0.5*(phi(j,i,2)-phi(j,i,o_local))/dz
		DO h=2,o_local-1
			sphi(j,i,h)=0.5*(phi(j,i,h+1)-phi(j,i,h-1))/dz

		ENDDO
		sphi(j,i,o_local)=0.5*(phi(j,i,1)-phi(j,i,o_local-1))/dz

	ENDDO
ENDDO
 sync all

	CALL SYNC_NEIGHBOURS_P

	RETURN
end subroutine

end module

max_stars_repo_name: friedirchulrich/solver

max_issues_repo_name: friedirchulrich/solver

max_forks_repo_name: friedirchulrich/solver


text:
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2012  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine kextra  --  extra term parameter assignment  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "kextra" assigns parameters to any additional user defined
c     potential energy contribution
c
c
      subroutine kextra
      implicit none
c
c
c     add any setup for user-defined extra potential below here
c
      return
      end

max_stars_repo_name: htna/HCsbLib

max_issues_repo_name: htna/HCsbLib

max_forks_repo_name: htna/HCsbLib


text:
! Verify that the driver correctly processes `-fsyntax-only`.
!
! By default, the compiler driver (`flang`) will create actions/phases to
! generate machine code (i.e. object files). The `-fsyntax-only` flag is a
! "phase-control" flag that controls this behavior and makes the driver stop
! once the semantic checks have been run. The frontend driver (`flang -fc1`)
! runs `-fsyntax-only` by default (i.e. that's the default action), so the flag
! can be skipped.

!-----------
! RUN LINES
!-----------
! RUN: %flang -fsyntax-only %s 2>&1 | FileCheck %s --allow-empty
! RUN: %flang_fc1 %s 2>&1 | FileCheck %s --allow-empty

! RUN: rm -rf %t/non-existent-dir/
! RUN: not %flang -c %s -o %t/non-existent-dir/syntax-only.o 2>&1 | FileCheck %s --check-prefix=NO_FSYNTAX_ONLY
! RUN: not %flang_fc1 -emit-obj %s -o %t/non-existent-dir/syntax-only.o 2>&1 | FileCheck %s --check-prefix=NO_FSYNTAX_ONLY

!-----------------
! EXPECTED OUTPUT
!-----------------
! CHECK-NOT: error
! NO_FSYNTAX_ONLY: error: failed to create the output file

!-------
! INPUT
!-------
end program

max_stars_repo_name: lxbndr/llvm-project

max_issues_repo_name: lxbndr/llvm-project

max_forks_repo_name: lxbndr/llvm-project


submodule(euler_interface_m) euler_prob_0007_m
    implicit none

contains

    module character(len=20) function euler0007()
        write (euler0007, "(i20)") ans(10000)
    end function euler0007

    integer function ans(n)
        use euler_primes_m, only: is_prime
        implicit none
        integer, intent(in) :: n
        integer :: i, j

        i = 0; j = 0
        loop_1: do
            if (j == n + 1) exit loop_1
            i = i + 1
            if (mod(i, 2) == 2 .and. i /= 2) then
                cycle loop_1
            else if (is_prime(int(i))) then
                j = j + 1
            end if
        end do loop_1
        ans = i
    end function ans
end submodule euler_prob_0007_m


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

      subroutine get_frate(r_platsch,r_platvel,r_range,r_prf,r_tarsch,pln, &
                           i_lrl,r_wavl,peg,elp,r_doppler,r_frate)

	! r_platsch     -> Platform position SCH values
	! r_platvel     -> Platform velocity SCH values
	! r_range       -> Range to target
	! r_prf         -> Pulse repetition frequency
	! r_tarsch      -> Location of target in SCH
	! pln           -> Planet description
	! i_lrl         -> Left / Right looking
	! r_wavl        -> Wavelength
	! peg           -> Peg point
	! elp           -> Ellipse description
	! r_doppler     -> Doppler centroid  (Output)
	! r_frate       -> Doppler centroid rate (Output)

!****************************************************************
!**
!**   FILE NAME: get_frate.f
!**
!**   DATE WRITTEN:1/28/99
!**
!**   PROGRAMMER: Paul Rosen
!**
!**   FUNCTIONAL DESCRIPTION: Compute the exact Doppler rate based
!**   on vector formula derived by Scott Hensley
!**
!**   ROUTINES CALLED: several geometry subroutines
!**
!**   NOTES:
!**
!**   UPDATE LOG:
!**
!**   Date Changed        Reason Changed                  CR # and Version #
!**   ------------       ----------------                 -----------------
!**
!*****************************************************************

      implicit none

!     INCLUDE FILES:

!     INPUT VARIABLES:
      type peg_type
         double precision :: r_lat                   !< Peg point latitude
         double precision :: r_lon                   !< Peg point longitude
         double precision :: r_hdg                   !< Peg point heading
      end type peg_type
      type pegtrans
         double precision :: r_mat(3,3)              !< Peg transformation matrix SCH -> XYZ
         double precision :: r_matinv(3,3)           !< Inverse peg transformation matrix XYZ -> SCH
         double precision :: r_ov(3)                 !< Peg origin offset vector
         double precision :: r_radcur                !< Radius of curvature
      end type pegtrans
      type ellipsoid
         double precision :: r_a                     !< Semi-major axis
         double precision :: r_e2                    !< Eccentricity squared
      end type ellipsoid
      type planet_type
         double precision :: r_spindot               !< Planet spin rate
         double precision :: r_gm                    !< Planet GM
      end type planet_type

      double precision :: r_platsch(3), r_platvel(3) !< Platform position and velocity in SCH coordinates
      double precision :: r_range                    !< Range to the target [m]
      double precision :: r_prf                      !< Pulse repetition frequency [Hz]
      double precision :: r_tarsch(3)                !< Location of the target in SCH coordinates
      integer :: i_lrl                               !< Left or right looking radar
      double precision :: r_wavl                     !< Radar wavelength [m]
      type(planet_type) :: pln
      type(peg_type) :: peg                          !< Coordinate and heading defining the SCH coordinate system
      type(ellipsoid) :: elp

      real*8 r_platacc(3)        !platform acceleration
      real*8 r_yaw               !platform Yaw
      real*8 r_pitch             !platform Pitch
      real*8 r_azesa             !azimuth steering angle

!     OUTPUT VARIABLES:

      double precision :: r_doppler !< Doppler centroid value [Hz]
      double precision :: r_frate   !< Doppler centroid rate for target [Hz/s]

!     LOCAL VARIABLES:

      integer i_schtoxyz
      integer i_xyztosch
      real*8 r_x1, r_x2, r_l3
      real*8 r_look, r_lookvec(3)
      real*8 r_vdotl, r_adotl, r_veln , r_accn
      real*8 r_spinvec(3)
      integer k
      real*8 r_xyz(3),r_tempv(3), r_inertialacc(3),r_tempa(3),r_tempvec(3),r_xyzdot(3)
      real*8 r_bodyacc(3),r_xyzschmat(3,3),r_schxyzmat(3,3),r_xyznorm,r_dx,r_dcnorm

      type(pegtrans) :: ptm !< SCH transformation parameters

!     COMMON BLOCKS:

!     EQUIVALENCE STATEMENTS:

!     DATA STATEMENTS:

      real*8, parameter :: r_dtor = atan(1.d0) / 45.d0

!     FUNCTION STATEMENTS:

      real*8 dot

!     SAVE STATEMENTS:

!     PROCESSING STEPS:

      i_schtoxyz = 0  !< Convert from sch => xyz
      i_xyztosch = 1  !< Convert from xyz => sch

      ! Assume no yaw, pitch, or azimuth steering
      r_yaw = 0.D0
      r_pitch = 0.D0
      r_azesa = 0.D0

      ! Assume that the target is on the ellipsoid
      do k=1,3
         r_tarsch(k) = 0.D0
      enddo

      !     Calculate Peg point transformation parameters
      call radar_to_xyz(elp,peg,ptm)

      !     acceleration - use Newton's Universal Law of Gravitation
      r_spinvec(1) = 0.
      r_spinvec(2) = 0.
      r_spinvec(3) = pln%r_spindot

      !     Convert position to XYZ coordinates
      call convert_sch_to_xyz(ptm,r_platsch,r_xyz,i_schtoxyz)

      ! Normalize
      call norm(r_xyz,r_xyznorm)

      ! Compute cross product
      call cross(r_spinvec,r_xyz,r_tempv)

      ! Use gravity for inertial acceleration
      do k=1,3
         r_inertialacc(k) = -(pln%r_gm*r_xyz(k))/r_xyznorm**3
      enddo

      ! Transform SCH velocity to XYZ
      call convert_schdot_to_xyzdot(ptm,r_platsch,r_platvel,r_xyzdot,i_schtoxyz)

      ! Cross product of spin and velocity
      call cross(r_spinvec,r_xyzdot,r_tempa)
      call cross(r_spinvec,r_tempv,r_tempvec)

      do k=1,3
         r_bodyacc(k) = r_inertialacc(k) - 2.d0*r_tempa(k) - r_tempvec(k)
      enddo

!     convert acceleration back to a local SCH basis

      call schbasis(ptm,r_platsch,r_xyzschmat,r_schxyzmat)
      call matvec(r_xyzschmat,r_bodyacc,r_platacc)

!     compute the Doppler and Frate

      r_x1 = (ptm%r_radcur + r_platsch(3))     !Radius to satellite
      r_x2 = (ptm%r_radcur + r_tarsch(3))      !Radius to target

      r_l3 = (r_x1**2 + r_range**2 - r_x2**2)/(2.d0*r_x1*r_range)    !Cosine law
      r_look = acos((r_l3 + sin(r_azesa)*sin(r_pitch))/(cos(r_pitch)*cos(r_azesa)))  !Look angle

      ! Look vector components
      r_lookvec(1) = (cos(r_look)*sin(r_pitch)*cos(r_yaw) + sin(r_look)*sin(r_yaw)*i_lrl)* &
          cos(r_azesa) - sin(r_azesa)*cos(r_pitch)*cos(r_yaw)
      r_lookvec(2) = (-cos(r_look)*sin(r_pitch)*sin(r_yaw) + sin(r_look)*cos(r_yaw)*i_lrl)* &
          cos(r_azesa) + sin(r_azesa)*cos(r_pitch)*sin(r_yaw)
      r_lookvec(3) = -cos(r_look)*cos(r_pitch)*cos(r_azesa) - sin(r_azesa)*sin(r_pitch)

      ! Dot product of look vector and velocity
      r_vdotl = dot(r_lookvec,r_platvel)
      call norm(r_platvel,r_veln)
      call norm(r_platacc,r_accn)

      r_doppler = 2.d0*r_vdotl/r_wavl	    !Doppler formula
      r_dcnorm = r_doppler/r_prf	    !Normalized doppler
      r_dx = r_veln/r_prf		    !Azimuth spacing

      !Dot product of acceleration and look vector
      r_adotl = dot(r_lookvec,r_platacc)

      !Doppler rate including the acceleration term
      r_frate = 2.d0*(r_adotl + (r_vdotl**2 - r_veln**2)/r_range)/(r_wavl)

    end


text:
program foo

! Subroutines are not implemented properly in the parser (no c_actions being called)
! subroutine foo(i)
    integer :: i, j

 10 if (i < 1) then
        j = 0
 20  else
        i = 4
 30 end if

! end subroutine
end program

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
! /****************************************************
!   output.f for bin2asc
!  4 Oct. 2017    written by D.KAWATA
! ****************************************************/

subroutine output(ngt,ng,ndmt,ndm,ndm1t,ndm1,nst,ns &
       ,flagr,step,nskip,asc,flagbo,flago,flagselp,rrange,zrange)
      use gcdp_const
      use gcdp_system
      use gcdp_baryon
      use gcdp_dm

      implicit none
      include 'mpif.h'

      integer,intent(in) ::  ngt,ng,ndmt,ndm,ndm1t,ndm1,nst,ns,flagr,nskip &
        ,step,flagbo,flago,flagselp
      double precision,intent(in) :: asc,rrange(0:1),zrange(0:1)
      double precision asci
      integer nvals,nivals
      integer i,ip,ip2,npj,pn,np,ngo,ndmo,nso,nc,nselp
      double precision nhp,temp,rp,gam
! for test particle info
      double precision rmp,eccp
! for work
      integer ierr
      integer,allocatable :: istatus(:)
      integer,allocatable :: npjr(:),ireqs(:),ireqr(:)
      integer,allocatable :: tivs(:),tivr(:)
      double precision,allocatable :: tdvs(:),tdvr(:)
! /**** List *****/
      character fileo*60

      allocate(istatus(MPI_STATUS_SIZE))

! *** for binary output ***
! allocate array for MPI
      allocate(npjr(0:nprocs-1))
      allocate(ireqs(0:nprocs-1))
      allocate(ireqr(0:nprocs-1))

! 1/a
      asci=1.0d0/asc

      gam=5.0d0/3.0d0

! number of selected particles
      nselp=0
      if(flagselp.ne.0) then
        if(flagselp.eq.1) then
          do i=0,ng-1
            pn=list_ap(i)
            rp=dsqrt(x_p(pn)**2+y_p(pn)**2+z_p(pn)**2)
            if(rp.gt.rrange(0).and.rp.lt.rrange(1)) then
              if(z_p(pn).gt.zrange(0).and.z_p(pn).lt.zrange(1)) then
                nselp=nselp+1
              endif
            endif
          enddo
       else if(flagselp.eq.2) then
          do i=0,ndm-1
            rp=dsqrt(x_dm(i)**2+y_dm(i)**2+z_dm(i)**2)
            if(rp.gt.rrange(0).and.rp.lt.rrange(1)) then
              if(z_dm(i).gt.zrange(0).and.z_dm(i).lt.zrange(1)) then
                nselp=nselp+1
              endif
            endif
          enddo
        else if(flagselp.eq.2) then
          do i=ng,ng+ns-1
            pn=list_ap(i)
            rp=dsqrt(x_p(pn)**2+y_p(pn)**2+z_p(pn)**2)
            if(rp.gt.rrange(0).and.rp.lt.rrange(1)) then
              if(z_p(pn).gt.zrange(0).and.z_p(pn).lt.zrange(1)) then
                nselp=nselp+1
              endif
            endif
          enddo
        endif
        allocate(tivs(0:0))
        allocate(tivr(0:0))
        tivs(0)=nselp
        tivr(0)=0
        call MPI_ALLREDUCE(tivs,tivr,1,MPI_INTEGER &
             ,MPI_MAX,MPI_COMM_WORLD,ierr)
        nselp=tivr(0)
        deallocate(tivs)
        deallocate(tivr)
        if(myrank.eq.0) then
          write(6,*) ' N selected particle=',nselp
        endif
      endif

      ngo=0
      ndmo=0
      nso=0
! *** output gas particles ***
      if(ngt.gt.0) then
        if(flagr.eq.0) then
          nvals=9
          nivals=1
        else
          nvals=20
          nivals=3
        endif
        np=0
        do i=0,ng-1,nskip
          np=np+1
        enddo

        allocate(tivs(0:ng*nivals-1))
        allocate(tivr(0:ng*nivals-1))
        allocate(tdvs(0:ng*nvals-1))
        allocate(tdvr(0:ng*nvals-1))

        nc=0
        do i=0,ng-1,nskip
          pn=list_ap(i)
          tdvs(nc)=x_p(pn)*asci
          tdvs(nc+np)=y_p(pn)*asci
          tdvs(nc+np*2)=z_p(pn)*asci
          tdvs(nc+np*3)=vx_p(pn)
          tdvs(nc+np*4)=vy_p(pn)
          tdvs(nc+np*5)=vz_p(pn)
          tdvs(nc+np*6)=m_p(pn)
          tdvs(nc+np*7)=rho_p(pn)
          tdvs(nc+np*8)=u_p(pn)
          tivs(nc)=id_p(pn)
          nc=nc+1
        enddo
        if(flagr.gt.0) then
          nc=0
          do i=0,ng-1,nskip
            pn=list_ap(i)
            tdvs(nc+np*9)=mzHe_p(pn)
            tdvs(nc+np*10)=mzC_p(pn)
            tdvs(nc+np*11)=mzN_p(pn)
            tdvs(nc+np*12)=mzO_p(pn)
            tdvs(nc+np*13)=mzNe_p(pn)
            tdvs(nc+np*14)=mzMg_p(pn)
            tdvs(nc+np*15)=mzSi_p(pn)
            tdvs(nc+np*16)=mzFe_p(pn)
            tdvs(nc+np*17)=mzZ_p(pn)
            tdvs(nc+np*18)=h_p(pn)
            tdvs(nc+np*19)=myu_p(pn)
            tivs(nc+np)=flagfd_p(pn)
            tivs(nc+np*2)=nnb_p(pn)
            nc=nc+1
          enddo
        endif
! *** set number of receiving data
        if(myrank.eq.0) then
          do ip=0,nprocs-1
            if(ip.eq.myrank) then
              npjr(ip)=np
            else
              npjr(ip)=0
              call MPI_IRECV(npjr(ip),1,MPI_INTEGER,ip,ip &
               ,MPI_COMM_WORLD,ireqr(ip),ierr)
              call MPI_WAIT(ireqr(ip),istatus,ierr)
            endif
          enddo
        else
          ip=myrank
          call MPI_ISEND(np,1,MPI_INTEGER,0,myrank &
            ,MPI_COMM_WORLD,ireqs(ip),ierr)
          call MPI_WAIT(ireqs(ip),istatus,ierr)
        endif
! *** receiving id_p and double data and write
        if(myrank.eq.0) then
          write(fileo,'(a8,i6.6)') 'output/g',step
          open(61,file=fileo,status='unknown')
          if(flagselp.eq.1) then
            write(fileo,'(a11,i6.6,a4)') 'output/selg',step,'.bin'
            open(63,file=fileo,status='unknown',form='unformatted')
            write(63) nselp
          endif
          do ip=0,nprocs-1
            if(ip.eq.myrank) then
              do i=0,npjr(myrank)*nivals-1
                tivr(i)=tivs(i)
              enddo
              do i=0,npjr(myrank)*nvals-1
                tdvr(i)=tdvs(i)
              enddo
            else
              call MPI_IRECV(tivr,npjr(ip)*nivals,MPI_INTEGER,ip,ip &
                ,MPI_COMM_WORLD,ireqr(ip),ierr)
              call MPI_WAIT(ireqr(ip),istatus,ierr)
              ip2=ip*2
              call MPI_IRECV(tdvr,npjr(ip)*nvals,MPI_DOUBLE_PRECISION &
               ,ip,ip2,MPI_COMM_WORLD,ireqr(ip),ierr)
              call MPI_WAIT(ireqr(ip),istatus,ierr)
            endif
! *** write the data
            npj=npjr(ip)
            ngo=ngo+npj
            if(flagselp.eq.1) then
              do i=0,npj-1
                rp=dsqrt(tdvr(i)**2+tdvr(i+npj)**2+tdvr(i+npj*2)**2)
                if(rp.gt.rrange(0).and.rp.lt.rrange(1)) then
                  if(tdvr(i+npj*2).gt.zrange(0) &
                    .and.tdvr(i+npj*2).lt.zrange(1)) then
                    write(63) tdvr(i),tdvr(i+npj),tdvr(i+npj*2) &
                      ,tdvr(i+npj*3),tdvr(i+npj*4),tdvr(i+npj*5)
                  endif
                endif
              enddo
            endif
            if(flagr.eq.0) then
              do i=0,npj-1
                write(61,161) tdvr(i),tdvr(i+npj),tdvr(i+npj*2) &
               ,tdvr(i+npj*3),tdvr(i+npj*4),tdvr(i+npj*5) &
               ,tdvr(i+npj*6),tdvr(i+npj*7),tdvr(i+npj*8) &
               ,dsqrt(tdvr(i)**2+tdvr(i+npj)**2+tdvr(i+npj*2)**2) &
               ,tivr(i)
 161            format(10(1pE13.5),I10)
              enddo
            else
              do i=0,npj-1
                rp=dsqrt(tdvr(i)**2+tdvr(i+npj)**2+tdvr(i+npj*2)**2)
                nhp=((tdvr(i+npj*6)-((tdvr(i+npj*9)+tdvr(i+npj*17)) &
                  /MUSM))/tdvr(i+npj*6))*tdvr(i+npj*7)*(DU/MP)
                p_p(i)=(gam-1.0d0)*tdvr(i+npj*7)*tdvr(i+npj*8)
                temp=(p_p(i)*tdvr(i+npj*19)/(tdvr(i+npj*7)*TPRHO*MYU))*1.0e4
                cs_p(i)=dsqrt(gam*p_p(i)/tdvr(i+npj*7))
                write(61,162) tdvr(i),tdvr(i+npj),tdvr(i+npj*2) &
                  ,tdvr(i+npj*3),tdvr(i+npj*4),tdvr(i+npj*5) &
! *** m,rho,u
                  ,tdvr(i+npj*6),tdvr(i+npj*7),tdvr(i+npj*8) &
! *** mzHe,C,N,O,Ne,Mg,Si,Fe,Z
                  ,tdvr(i+npj*9),tdvr(i+npj*10),tdvr(i+npj*11) &
                  ,tdvr(i+npj*12),tdvr(i+npj*13),tdvr(i+npj*14) &
                  ,tdvr(i+npj*15),tdvr(i+npj*16),tdvr(i+npj*17) &
! *** id,flagfd,h,myu,nhp,temp,rp,nnb
                  ,tivr(i),tivr(i+npj),tdvr(i+npj*18),tdvr(i+npj*19) &
                  ,nhp,temp,rp,tivr(i+npj*2)
 162            format(18(1pE13.5),2I10,5(1pE13.5),I10)
              enddo
            endif
          enddo
          close(61)
          if(flagselp.eq.1) then
            close(63)
          endif
        else
! *** sending the data to rank 0 ***
          ip=myrank
          call MPI_ISEND(tivs,np*nivals,MPI_INTEGER,0,myrank &
            ,MPI_COMM_WORLD,ireqs(ip),ierr)
          call MPI_WAIT(ireqs(ip),istatus,ierr)
          ip2=myrank*2
          call MPI_ISEND(tdvs,np*nvals,MPI_DOUBLE_PRECISION,0,ip2 &
           ,MPI_COMM_WORLD,ireqs(ip),ierr)
          call MPI_WAIT(ireqs(ip),istatus,ierr)
        endif

        deallocate(tivs)
        deallocate(tivr)
        deallocate(tdvs)
        deallocate(tdvr)
      endif

      if(ndmt.gt.0) then
! *** output DM
        nvals=13
        nivals=1

        allocate(tivs(0:ndm*nivals-1))
        allocate(tivr(0:ndm*nivals-1))
        allocate(tdvs(0:ndm*nvals-1))
        allocate(tdvr(0:ndm*nvals-1))

        np=0
        do i=0,ndm-1,nskip
          np=np+1
        enddo
        nc=0
        do i=0,ndm-1,nskip
          pn=list_adm(i)
          tdvs(nc)=x_dm(pn)*asci
          tdvs(nc+np)=y_dm(pn)*asci
          tdvs(nc+np*2)=z_dm(pn)*asci
          tdvs(nc+np*3)=vx_dm(pn)
          tdvs(nc+np*4)=vy_dm(pn)
          tdvs(nc+np*5)=vz_dm(pn)
          tdvs(nc+np*6)=m_dm(pn)
          tdvs(nc+np*7)=rho_dm(pn)
          tdvs(nc+np*8)=h_dm(pn)
          tdvs(nc+np*9)=tadd_dm(pn)
          tdvs(nc+np*10)=rperi_dm(pn)
          tdvs(nc+np*11)=rapo_dm(pn)
          tdvs(nc+np*12)=zmax_dm(pn)
          tivs(nc)=id_dm(pn)
          nc=nc+1
        enddo
! *** set number of receiving data
        if(myrank.eq.0) then
          do ip=0,nprocs-1
            if(ip.eq.myrank) then
              npjr(ip)=np
            else
              npjr(ip)=0
              call MPI_IRECV(npjr(ip),1,MPI_INTEGER,ip,ip &
                ,MPI_COMM_WORLD,ireqr(ip),ierr)
              call MPI_WAIT(ireqr(ip),istatus,ierr)
            endif
          enddo
        else
          ip=myrank
          call MPI_ISEND(np,1,MPI_INTEGER,0,myrank &
            ,MPI_COMM_WORLD,ireqs(ip),ierr)
          call MPI_WAIT(ireqs(ip),istatus,ierr)
        endif
! *** receiving id_p and double data and write
        if(myrank.eq.0) then
          if(flagbo.eq.0) then
            write(fileo,'(a8,i6.6,a4)') 'output/d',step,'.bin'
            open(61,file=fileo,status='unknown',form='unformatted')
            write(61) ndm1t
          else
            write(fileo,'(a8,i6.6)') 'output/d',step
            open(61,file=fileo,status='unknown')
            write(fileo,'(a9,i6.6)') 'output/ld',step
            open(62,file=fileo,status='unknown')
          endif
          if(flagselp.eq.2) then
            write(fileo,'(a11,i6.6,a4)') 'output/seld',step,'.bin'
!            open(63,file=fileo,status='unknown')
!            write(63,*) '# ',nselp
            open(63,file=fileo,status='unknown',form='unformatted')
            write(63) nselp
          endif
          do ip=0,nprocs-1
            if(ip.eq.myrank) then
              do i=0,npjr(myrank)-1
                tivr(i)=tivs(i)
              enddo
              do i=0,npjr(myrank)*nvals-1
                tdvr(i)=tdvs(i)
              enddo
            else
              call MPI_IRECV(tivr,npjr(ip),MPI_INTEGER,ip,ip &
                ,MPI_COMM_WORLD,ireqr(ip),ierr)
              call MPI_WAIT(ireqr(ip),istatus,ierr)
              ip2=ip*2
              call MPI_IRECV(tdvr,npjr(ip)*nvals,MPI_DOUBLE_PRECISION &
               ,ip,ip2,MPI_COMM_WORLD,ireqr(ip),ierr)
              call MPI_WAIT(ireqr(ip),istatus,ierr)
            endif
! *** write the data
            npj=npjr(ip)
            ndmo=ndmo+npj
            if(flagselp.eq.2) then
              do i=0,npj-1
                rp=dsqrt(tdvr(i)**2+tdvr(i+npj)**2+tdvr(i+npj*2)**2)
                if(rp.gt.rrange(0).and.rp.lt.rrange(1)) then
                  if(tdvr(i+npj*2).gt.zrange(0) &
                    .and.tdvr(i+npj*2).lt.zrange(1)) then
                    write(63) tdvr(i),tdvr(i+npj),tdvr(i+npj*2) &
                         ,tdvr(i+npj*3),tdvr(i+npj*4),tdvr(i+npj*5)
!                    write(63,*) tdvr(i),tdvr(i+npj),tdvr(i+npj*2) &
!                      ,tdvr(i+npj*3),tdvr(i+npj*4),tdvr(i+npj*5)
                  endif
                endif
              enddo
            endif
            if(flagbo.eq.0) then
              do i=0,npj-1
                if(tivr(i).lt.ndm1t) then
                  write(61) tdvr(i),tdvr(i+npj),tdvr(i+npj*2),tivr(i)
                endif
              enddo
            else
              if(flago.eq.1) then
! test particle output
                do i=0,npj-1
                  if(tdvr(i+npj*11).gt.0.0d0) then
! mean radius
                    rmp=0.5d0*(tdvr(i+npj*10)+tdvr(i+npj*11))
! eccentricity
                    eccp=(tdvr(i+npj*11)-tdvr(i+npj*10)) &
                      /(tdvr(i+npj*11)+tdvr(i+npj*10))
                  else
                    rmp=0.0d0
                    eccp=0.0d0
                  endif
                  write(61,'(12(1pE13.5),I10)') tdvr(i),tdvr(i+npj) &
                   ,tdvr(i+npj*2),tdvr(i+npj*3),tdvr(i+npj*4) &
                   ,tdvr(i+npj*5),tdvr(i+npj*9),tdvr(i+npj*10) &
                   ,tdvr(i+npj*11),tdvr(i+npj*12),rmp,eccp,tivr(i)
                enddo
              else
                do i=0,npj-1
                  if(tivr(i).lt.ndm1t) then
                    write(61,163) tdvr(i),tdvr(i+npj),tdvr(i+npj*2) &
                      ,tdvr(i+npj*3),tdvr(i+npj*4),tdvr(i+npj*5) &
                      ,tdvr(i+npj*6),tdvr(i+npj*7),tdvr(i+npj*8) &
                      ,tdvr(i+npj*9),tivr(i)
                  else
                    write(62,163) tdvr(i),tdvr(i+npj),tdvr(i+npj*2) &
                      ,tdvr(i+npj*3),tdvr(i+npj*4),tdvr(i+npj*5) &
                      ,tdvr(i+npj*6),tdvr(i+npj*7),tdvr(i+npj*8) &
                      ,tdvr(i+npj*9),tivr(i)
                  endif
 163              format(10(1pE13.5),I10)
                enddo
              endif
            endif
          enddo
          close(61)
          if(flagbo.ne.0) then
            close(62)
          endif
          if(flagselp.eq.2) then
            close(63)
          endif
        else
          ip=myrank
          call MPI_ISEND(tivs,np,MPI_INTEGER,0,myrank &
            ,MPI_COMM_WORLD,ireqs(ip),ierr)
          call MPI_WAIT(ireqs(ip),istatus,ierr)
          ip2=myrank*2
          call MPI_ISEND(tdvs,np*nvals,MPI_DOUBLE_PRECISION,0,ip2 &
            ,MPI_COMM_WORLD,ireqs(ip),ierr)
          call MPI_WAIT(ireqs(ip),istatus,ierr)
        endif

        deallocate(tivs)
        deallocate(tivr)
        deallocate(tdvs)
        deallocate(tdvr)

      endif

! *** output star
      if(nst.gt.0) then
        if(flagr.eq.0) then
          nvals=7
          nivals=1
        else
          nvals=20
          nivals=3
        endif

        allocate(tivs(0:ns*nivals-1))
        allocate(tivr(0:ns*nivals-1))
        allocate(tdvs(0:ns*nvals-1))
        allocate(tdvr(0:ns*nvals-1))

        np=0
        do i=0,ns-1,nskip
          np=np+1
        enddo
        nc=0
        do i=0,ns-1,nskip
          pn=list_ap(i+ng)
          tdvs(nc)=x_p(pn)*asci
          tdvs(nc+np)=y_p(pn)*asci
          tdvs(nc+np*2)=z_p(pn)*asci
          tdvs(nc+np*3)=vx_p(pn)
          tdvs(nc+np*4)=vy_p(pn)
          tdvs(nc+np*5)=vz_p(pn)
          tdvs(nc+np*6)=m_p(pn)
          tivs(nc)=id_p(pn)
          nc=nc+1
        enddo
        if(flagr.gt.0) then
          nc=0
          do i=0,ns-1,nskip
            pn=list_ap(i+ng)
            tdvs(nc+np*9)=mzHe_p(pn)
            tdvs(nc+np*10)=mzC_p(pn)
            tdvs(nc+np*11)=mzN_p(pn)
            tdvs(nc+np*12)=mzO_p(pn)
            tdvs(nc+np*13)=mzNe_p(pn)
            tdvs(nc+np*14)=mzMg_p(pn)
            tdvs(nc+np*15)=mzSi_p(pn)
            tdvs(nc+np*16)=mzFe_p(pn)
            tdvs(nc+np*17)=mzZ_p(pn)
            tdvs(nc+np*18)=h_p(pn)
            tdvs(nc+np*19)=ts_p(pn)
            tivs(nc+np)=flagfd_p(pn)
            tivs(nc+np*2)=nnb_p(pn)
            nc=nc+1
          enddo
        endif
! *** set number of receiving data
        if(myrank.eq.0) then
          do ip=0,nprocs-1
            if(ip.eq.myrank) then
              npjr(ip)=np
            else
              npjr(ip)=0
              call MPI_IRECV(npjr(ip),1,MPI_INTEGER,ip,ip &
                ,MPI_COMM_WORLD,ireqr(ip),ierr)
              call MPI_WAIT(ireqr(ip),istatus,ierr)
            endif
          enddo
        else
          ip=myrank
          call MPI_ISEND(np,1,MPI_INTEGER,0,myrank &
            ,MPI_COMM_WORLD,ireqs(ip),ierr)
          call MPI_WAIT(ireqs(ip),istatus,ierr)
        endif
! *** receiving id_p and double data and write
        if(myrank.eq.0) then
          write(fileo,'(a8,i6.6)') 'output/s',step
          open(61,file=fileo,status='unknown')
          if(flagselp.eq.1) then
            write(fileo,'(a11,i6.6,a4)') 'output/sels',step,'.bin'
            open(63,file=fileo,status='unknown',form='unformatted')
            write(63) nselp
          endif
          do ip=0,nprocs-1
            if(ip.eq.myrank) then
              do i=0,npjr(myrank)*nivals-1
                tivr(i)=tivs(i)
              enddo
              do i=0,npjr(myrank)*nvals-1
                tdvr(i)=tdvs(i)
              enddo
            else
!            write(6,*) ' star recv nivals,nvails,npjr(ip),ip=' &
!              ,nivals,nvals,npjr(ip),ip
              call MPI_IRECV(tivr,npjr(ip)*nivals,MPI_INTEGER,ip,ip &
                ,MPI_COMM_WORLD,ireqr(ip),ierr)
              call MPI_WAIT(ireqr(ip),istatus,ierr)
              ip2=ip*2
              call MPI_IRECV(tdvr,npjr(ip)*nvals,MPI_DOUBLE_PRECISION &
                ,ip,ip2,MPI_COMM_WORLD,ireqr(ip),ierr)
              call MPI_WAIT(ireqr(ip),istatus,ierr)
            endif
! *** write the data
            npj=npjr(ip)
            nso=nso+npj
            if(flagselp.eq.3) then
              do i=0,npj-1
                rp=dsqrt(tdvr(i)**2+tdvr(i+npj)**2+tdvr(i+npj*2)**2)
                if(rp.gt.rrange(0).and.rp.lt.rrange(1)) then
                  if(tdvr(i+npj*2).gt.zrange(0) &
                    .and.tdvr(i+npj*2).lt.zrange(1)) then
                    write(63) tdvr(i),tdvr(i+npj),tdvr(i+npj*2) &
                      ,tdvr(i+npj*3),tdvr(i+npj*4),tdvr(i+npj*5)
                  endif
                endif
              enddo
            endif
            if(flagr.eq.0) then
              do i=0,npj-1
                write(61,164) tdvr(i),tdvr(i+npj),tdvr(i+npj*2) &
                 ,tdvr(i+npj*3),tdvr(i+npj*4),tdvr(i+npj*5) &
                 ,tdvr(i+npj*6),tivr(i) &
                 ,dsqrt(tdvr(i)**2+tdvr(i+npj)**2+tdvr(i+npj*2)**2)
 164           format(7(1pE13.5),I10,1pE13.5)
              enddo
            else
              do i=0,npj-1
                rp=dsqrt(tdvr(i)**2+tdvr(i+npj)**2+tdvr(i+npj*2)**2)
                write(61,165) tdvr(i),tdvr(i+npj),tdvr(i+npj*2) &
                 ,tdvr(i+npj*3),tdvr(i+npj*4),tdvr(i+npj*5),tdvr(i+npj*6) &
! *** mzHe,C,N,O,Ne,Mg,Si,Fe,Z
                 ,tdvr(i+npj*9),tdvr(i+npj*10),tdvr(i+npj*11) &
                 ,tdvr(i+npj*12),tdvr(i+npj*13),tdvr(i+npj*14) &
                 ,tdvr(i+npj*15),tdvr(i+npj*16),tdvr(i+npj*17) &
! *** ts,id,flagfd,h,rp,nnb
                 ,tdvr(i+npj*19),tivr(i),tivr(i+npj) &
                 ,tdvr(i+npj*18),rp,tivr(i+npj*2)
 165             format(17(1pE13.5),2I10,2(1pE13.5),I10)
              enddo
            endif
          enddo
          close(61)
          if(flagselp.eq.3) then
            close(63)
          endif
        else
          ip=myrank
          call MPI_ISEND(tivs,np*nivals,MPI_INTEGER,0,myrank &
            ,MPI_COMM_WORLD,ireqs(ip),ierr)
          call MPI_WAIT(ireqs(ip),istatus,ierr)
          ip2=myrank*2
          call MPI_ISEND(tdvs,np*nvals,MPI_DOUBLE_PRECISION,0,ip2 &
           ,MPI_COMM_WORLD,ireqs(ip),ierr)
          call MPI_WAIT(ireqs(ip),istatus,ierr)
        endif

        if(myrank.eq.0) then
          write(6,*) ' output ng,ndm,ns=',ngo,ndmo,nso
        endif
      endif

      deallocate(istatus)
      deallocate(npjr)
      deallocate(ireqs)
      deallocate(ireqr)

 90   return
      end

max_stars_repo_name: kawatadaisuke/gcdp-ana

max_issues_repo_name: kawatadaisuke/gcdp-ana

max_forks_repo_name: kawatadaisuke/gcdp-ana


text:
! -----------------------------------------------------------------
! Programmer(s): Cody J. Balos @ LLNL
! -----------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2019, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! -----------------------------------------------------------------
! This file contains a Fortran module for interfacing directly with
! the SUNDIALS Pthreads NVector using the ISO_C_BINDING module.
! -----------------------------------------------------------------

module fnvector_pthreads_mod

  !======= Interfaces =========
  interface

     ! =================================================================
     ! Constructors
     ! =================================================================

     ! -----------------------------------------------------------------
     ! N_VNew_Pthreads
     ! -----------------------------------------------------------------

     type(c_ptr) function FN_VNew_Pthreads(vec_length, num_threads) &
          bind(C,name='N_VNew_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_long), value :: vec_length
       integer(c_int),  value :: num_threads
     end function FN_VNew_Pthreads

     ! -----------------------------------------------------------------
     ! N_VNewEmpty_Pthreads
     ! -----------------------------------------------------------------

     type(c_ptr) function FN_VNewEmpty_Pthreads(vec_length, num_threads) &
          bind(C,name='N_VNewEmpty_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_long), value :: vec_length
       integer(c_int),  value :: num_threads
     end function FN_VNewEmpty_Pthreads

     ! -----------------------------------------------------------------
     ! N_VMake_Pthreads
     ! -----------------------------------------------------------------

     type(c_ptr) function FN_VMake_Pthreads(length, v_data, num_threads) &
          bind(C,name='N_VMake_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_long), value :: length
       real(c_double)         :: v_data(length)
       integer(c_int),  value :: num_threads
     end function FN_VMake_Pthreads

     ! -----------------------------------------------------------------
     ! N_VCloneVectorArray_Pthreads: NOT INTERFACED
     ! -----------------------------------------------------------------

     ! -----------------------------------------------------------------
     ! N_VCloneVectorArrayEmpty_Pthreads: NOT INTERFACED
     ! -----------------------------------------------------------------

     ! =================================================================
     ! Destructors
     ! =================================================================

     ! -----------------------------------------------------------------
     ! N_VDestroy_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VDestroy_Pthreads(v) &
          bind(C,name='N_VDestroy_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: v
     end subroutine FN_VDestroy_Pthreads

     ! -----------------------------------------------------------------
     ! N_VDestroyVectorArray_Pthreads: NOT INTERFACED
     ! -----------------------------------------------------------------

     ! =================================================================
     ! Other routines
     ! =================================================================

     ! -----------------------------------------------------------------
     ! N_VGetLength_Pthreads
     ! -----------------------------------------------------------------

     integer(c_long) function FN_VGetLength_Pthreads(v) &
          bind(C,name='N_VGetLength_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: v
     end function FN_VGetLength_Pthreads

     ! -----------------------------------------------------------------
     ! N_VPrint_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VPrint_Pthreads(v) &
          bind(C,name='N_VPrint_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: v
     end subroutine FN_VPrint_Pthreads

     ! -----------------------------------------------------------------
     ! NOT INTERFACED: N_VPrintFile_Pthreads
     ! -----------------------------------------------------------------

     ! =================================================================
     ! Operations
     ! =================================================================

     ! -----------------------------------------------------------------
     ! N_VGetVectorID_Pthreads
     ! -----------------------------------------------------------------

     integer(c_int) function FN_VGetVectorID_Pthreads(v) &
          bind(C,name='N_VGetVectorID_Pthreads')
        use, intrinsic :: iso_c_binding
        implicit none
        type(c_ptr), value :: v
     end function FN_VGetVectorID_Pthreads

     ! -----------------------------------------------------------------
     ! N_VCloneEmpty_Pthreads
     ! -----------------------------------------------------------------

     type(c_ptr) function FN_VCloneEmpty_Pthreads(w) &
          bind(C,name='N_VCloneEmpty_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: w
     end function FN_VCloneEmpty_Pthreads

     ! -----------------------------------------------------------------
     ! N_VClone_Pthreads
     ! -----------------------------------------------------------------

     type(c_ptr) function FN_VClone_Pthreads(w) &
          bind(C,name='N_VClone_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: w
     end function FN_VClone_Pthreads

     ! -----------------------------------------------------------------
     ! N_VSpace_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VSpace_Pthreads(v, lrw, liw) &
          bind(C,name='N_VSpace_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: v
       integer(c_long)    :: lrw
       integer(c_long)    :: liw
     end subroutine FN_VSpace_Pthreads

     ! -----------------------------------------------------------------
     ! N_VGetArrayPointer_Pthreads
     ! -----------------------------------------------------------------

     type(c_ptr) function FN_VGetArrayPointer_Pthreads(vec) &
          bind(C,name='N_VGetArrayPointer_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: vec
     end function FN_VGetArrayPointer_Pthreads

     ! -----------------------------------------------------------------
     ! N_VSetArrayPointer_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VSetArrayPointer_Pthreads(v_data, v) &
          bind(C,name='N_VSetArrayPointer_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: v_data
       type(c_ptr), value :: v
     end subroutine FN_VSetArrayPointer_Pthreads

     ! -----------------------------------------------------------------
     ! N_VLinearSum_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VLinearSum_Pthreads(a, x, b, y, z) &
          bind(C,name='N_VLinearSum_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       real(c_double), value :: a
       type(c_ptr),    value :: x
       real(c_double), value :: b
       type(c_ptr),    value :: y
       type(c_ptr),    value :: z
     end subroutine FN_VLinearSum_Pthreads

     ! -----------------------------------------------------------------
     ! N_VConst_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VConst_Pthreads(c, z) &
          bind(C,name='N_VConst_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       real(c_double), value :: c
       type(c_ptr),    value :: z
     end subroutine FN_VConst_Pthreads

     ! -----------------------------------------------------------------
     ! N_VProd_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VProd_Pthreads(x, y, z) &
          bind(C,name='N_VProd_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
       type(c_ptr), value :: y
       type(c_ptr), value :: z
     end subroutine FN_VProd_Pthreads

     ! -----------------------------------------------------------------
     ! N_VDiv_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VDiv_Pthreads(x, y, z) &
          bind(C,name='N_VDiv_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
       type(c_ptr), value :: y
       type(c_ptr), value :: z
     end subroutine FN_VDiv_Pthreads

     ! -----------------------------------------------------------------
     ! N_VScale_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VScale_Pthreads(c, x, z) &
          bind(C,name='N_VScale_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       real(c_double), value :: c
       type(c_ptr),    value :: x
       type(c_ptr),    value :: z
     end subroutine FN_VScale_Pthreads

     ! -----------------------------------------------------------------
     ! N_VAbs_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VAbs_Pthreads(x, z) &
          bind(C,name='N_VAbs_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
       type(c_ptr), value :: z
     end subroutine FN_VAbs_Pthreads

     ! -----------------------------------------------------------------
     ! N_VInv_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VInv_Pthreads(x, z) &
          bind(C,name='N_VInv_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
       type(c_ptr), value :: z
     end subroutine FN_VInv_Pthreads

     ! -----------------------------------------------------------------
     ! N_VAddConst
     ! -----------------------------------------------------------------

     subroutine FN_VAddConst_Pthreads(x, b, z) &
          bind(C,name='N_VAddConst_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr),    value :: x
       real(c_double), value :: b
       type(c_ptr),    value :: z
     end subroutine FN_VAddConst_Pthreads

     ! -----------------------------------------------------------------
     ! N_VDotProd_Pthreads
     ! -----------------------------------------------------------------

     real(c_double) function FN_VDotProd_Pthreads(x, y) &
          bind(C,name='N_VDotProd_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
       type(c_ptr), value :: y
     end function FN_VDotProd_Pthreads

     ! -----------------------------------------------------------------
     ! N_VMaxNorm_Pthreads
     ! -----------------------------------------------------------------

     real(c_double) function FN_VMaxNorm_Pthreads(x) &
          bind(C,name='N_VMaxNorm_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
     end function FN_VMaxNorm_Pthreads

     ! -----------------------------------------------------------------
     ! N_VWrmsNorm_Pthreads
     ! -----------------------------------------------------------------

     real(c_double) function FN_VWrmsNorm_Pthreads(x, w) &
          bind(C,name='N_VWrmsNorm_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
       type(c_ptr), value :: w
     end function FN_VWrmsNorm_Pthreads

     ! -----------------------------------------------------------------
     ! N_VWrmsNormMask_Pthreads
     ! -----------------------------------------------------------------

     real(c_double) function FN_VWrmsNormMask_Pthreads(x, w, id) &
          bind(C,name='N_VWrmsNormMask_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
       type(c_ptr), value :: w
       type(c_ptr), value :: id
     end function FN_VWrmsNormMask_Pthreads

     ! -----------------------------------------------------------------
     ! N_VMin_Pthreads
     ! -----------------------------------------------------------------

     real(c_double) function FN_VMin_Pthreads(x) &
          bind(C,name='N_VMin_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
     end function FN_VMin_Pthreads

     ! -----------------------------------------------------------------
     ! N_VWL2Norm_Pthreads
     ! -----------------------------------------------------------------

     real(c_double) function FN_VWL2Norm_Pthreads(x, w) &
          bind(C,name='N_VWL2Norm_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
       type(c_ptr), value :: w
     end function FN_VWL2Norm_Pthreads

     ! -----------------------------------------------------------------
     ! N_VL1Norm_Pthreads
     ! -----------------------------------------------------------------

     real(c_double) function FN_VL1Norm_Pthreads(x) &
          bind(C,name='N_VL1Norm_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
     end function FN_VL1Norm_Pthreads

     ! -----------------------------------------------------------------
     ! N_VCompare_Pthreads
     ! -----------------------------------------------------------------

     subroutine FN_VCompare_Pthreads(c, x, z) &
          bind(C,name='N_VCompare_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       real(c_double), value :: c
       type(c_ptr),    value :: x
       type(c_ptr),    value :: z
     end subroutine FN_VCompare_Pthreads

     ! -----------------------------------------------------------------
     ! N_VInvTest_Pthreads
     ! -----------------------------------------------------------------

     integer(c_int) function FN_VInvTest_Pthreads(x, z) &
          bind(C,name='N_VInvTest_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: x
       type(c_ptr), value :: z
     end function FN_VInvTest_Pthreads

     ! -----------------------------------------------------------------
     ! N_VConstrMask_Pthreads
     ! -----------------------------------------------------------------

     integer(c_int) function FN_VConstrMask_Pthreads(c, x, m) &
          bind(C,name='N_VConstrMask_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: c
       type(c_ptr), value :: x
       type(c_ptr), value :: m
     end function FN_VConstrMask_Pthreads

     ! -----------------------------------------------------------------
     ! N_VMinQuotient_Pthreads
     ! -----------------------------------------------------------------

     real(c_double) function FN_VMinQuotient_Pthreads(num, denom) &
          bind(C,name='N_VMinQuotient_Pthreads')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: num
       type(c_ptr), value :: denom
     end function FN_VMinQuotient_Pthreads

     ! ================================================================
     ! Fused vector operations: NOT INTERFACED
     ! ================================================================

     ! ================================================================
     ! Vector array operations: NOT INTERFACED
     ! ================================================================

   end interface

contains

  ! ================================================================
  ! Helpful routines
  ! ================================================================

  ! ----------------------------------------------------------------
  ! FN_VGetData_Pthreads
  !
  ! Extracts data array from a Pthreads SUNDIALS N_Vector
  ! ----------------------------------------------------------------

  subroutine FN_VGetData_Pthreads(vec, f_array)

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding

    !======= Declarations =========
    implicit none

    ! calling variables
    type(c_ptr)             :: vec
    integer(c_long)         :: length
    real(c_double), pointer :: f_array(:)

    ! C pointer for N_Vector interal data array
    type(c_ptr) :: c_array

    !======= Internals ============

    ! get data pointer from N_Vector
    c_array = FN_VGetArrayPointer_Pthreads(vec)

    ! get vector length
    length = FN_VGetLength_Pthreads(vec)

    ! convert c pointer to f pointer
    call c_f_pointer(c_array, f_array, (/length/))

  end subroutine FN_VGetData_Pthreads

end module fnvector_pthreads_mod

max_stars_repo_name: jrmie/math

max_issues_repo_name: jrmie/math

max_forks_repo_name: jrmie/math


text:
        !COMPILER-GENERATED INTERFACE MODULE: Tue Oct 10 17:23:01 2017
        MODULE EFT_SIZE__genmod
          INTERFACE
            SUBROUTINE EFT_SIZE(PMU,NO3,TC,PAR_,MUNET,QN,THETA,LSI,LNO3)
              REAL(KIND=8), INTENT(IN) :: PMU
              REAL(KIND=8), INTENT(IN) :: NO3
              REAL(KIND=8), INTENT(IN) :: TC
              REAL(KIND=8), INTENT(IN) :: PAR_
              REAL(KIND=8), INTENT(OUT) :: MUNET
              REAL(KIND=8), INTENT(OUT) :: QN
              REAL(KIND=8), INTENT(OUT) :: THETA
              REAL(KIND=8), INTENT(OUT) :: LSI
              REAL(KIND=8), INTENT(OUT) :: LNO3
            END SUBROUTINE EFT_SIZE
          END INTERFACE
        END MODULE EFT_SIZE__genmod

max_stars_repo_name: BingzhangChen/NPZDFeCONT

max_issues_repo_name: BingzhangChen/NPZDFeCONT

max_forks_repo_name: BingzhangChen/NPZDFeCONT


text:
!
! Copyright (C) 2001-2006 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!----------------------------------------------------------------------------
SUBROUTINE openfil()
  !----------------------------------------------------------------------------
  !
  ! ... This routine opens some files needed to the self consistent run,
  ! ... sets various file names, units, record lengths
  ! ... All units are set in Modules/io_files.f90
  !
  USE kinds,            ONLY : DP
  USE io_global,        ONLY : stdout
  USE basis,            ONLY : natomwfc, starting_wfc
  USE wvfct,            ONLY : nbnd, npwx
  USE fixed_occ,        ONLY : one_atom_occupations
  USE klist,            ONLY : nks
  USE io_files,         ONLY : prefix, iunpun, iunat, iunsat, iunwfc, iunigk, &
                               nwordwfc, nwordatwfc, iunefield, diropn, &
                               tmp_dir, wfc_dir, iunefieldm, iunefieldp, seqopn
  USE buffers,          ONLY : open_buffer, init_buffer
  USE control_flags,    ONLY : io_level, twfcollect
  !
  IMPLICIT NONE
  !
  integer, parameter :: npol=1 !substitute for noncollin_module%npol
  LOGICAL            :: exst
  INTEGER            :: ierr
  CHARACTER(LEN=256) :: tmp_dir_save
  !
  ! ... tmp_dir may be replaced by wfc_dir  for large files
  !
  tmp_dir_save = tmp_dir
  !
  IF ( wfc_dir /= 'undefined' ) THEN
     !
     WRITE( stdout, '(5X,"writing wfc files to a dedicated directory")' )
     !
     tmp_dir = wfc_dir
     !
  END IF
  !
  ! ... nwordwfc is the record length (IN COMPLEX WORDS)
  ! ... for the direct-access file containing wavefunctions
  !
  nwordwfc = nbnd*npwx*npol
  !
  ! ... iunwfc=10: read/write wfc from/to file
  ! ... iunwfc=-1: copy wfc to/from RAM
  !
  IF ( io_level > 0 ) THEN
     iunwfc = 10
  ELSE
     iunwfc = -1
  END IF
  !
#ifdef __IGKIO
  CALL open_buffer( iunwfc, 'wfc', nwordwfc, nks, exst )
#endif
  !
  IF ( TRIM(starting_wfc) == 'file' .AND. .NOT. exst)  THEN
     !
     ierr = 1
     IF ( twfcollect ) THEN
        !
        ! ... wavefunctions are read from the "save" file and rewritten
        ! ... (directly in pw_readfile) using the internal format
        !
        write(*,*)"openfil.f90:75 skipping pw_readfile, requires iotk"
        !CALL pw_readfile( 'wave', ierr )
        !
     !ELSE
        !
        ! ... wavefunctions are read into memory
        !
#ifdef __IGKIO
        CALL init_buffer ( iunwfc, exst, ierr )
#endif
        !
     END IF

     IF ( ierr > 0 ) THEN
        !
        WRITE( stdout, '(5X,"Cannot read wfc : file not found")' )
        !
        starting_wfc = 'atomic'
        !
     END IF
     !
  END IF
  !
  ! ... Needed for LDA+U
  !
  ! ... iunat  contains the (orthogonalized) atomic wfcs
  ! ... iunsat contains the (orthogonalized) atomic wfcs * S
  ! ... iunocc contains the atomic occupations computed in new_ns
  ! ... it is opened and closed for each reading-writing operation
  !
  nwordatwfc = 2*npwx*natomwfc*npol
  !
  IF ( one_atom_occupations ) then
     CALL diropn( iunat,  'atwfc',  nwordatwfc, exst )
     CALL diropn( iunsat, 'satwfc', nwordatwfc, exst )
  END IF
  !
  ! ... iunigk contains the number of PW and the indices igk
  ! ... Note that unit 15 is reserved for error messages
  !
#ifdef __IGKIO
  CALL seqopn( iunigk, 'igk', 'UNFORMATTED', exst )
#endif
  !
  ! ... open units for electric field calculations
  !
  !
  tmp_dir = tmp_dir_save
  !
  RETURN
  !
END SUBROUTINE openfil

max_stars_repo_name: utdsimmons/ohpc

max_issues_repo_name: utdsimmons/ohpc

max_forks_repo_name: utdsimmons/ohpc