text:
These are reviews of Instaconnect from 2007.  For more current reviews, visit Instaconnect the entry.

20070115 16:23:19 nbsp I have been at Viking Apartments since September and the only thing worse than the Internet service has been the customer service.  I have called several times to complain about low signals, slow speeds and recurring dropoffs, and usually the representative said someone would come over to do a power cycle, which is just turning the system off and on again.  When that didnt work I called again and was told there were no known issues at my apartment, but that someone would call me back, and of course nobody did.  I called a third time and nobody even answered the phone, even during business hours.  After about five days of nobody even picking up the phone, I finally got someone to set up an appointment to come to my apartment.  Of course nobody showed up and apparently someone called, but did not leave a message, so I did not even know they had tried to contact me.  Someone should hopefully be coming out tomorrow, but Im not holding my breath. Users/MattStauffer

20070131 07:49:01 nbsp Most of the instaconnect APs I see only use MAC address filtering to verify your account, therefor its easy to steal access by using a MAC spoofer, doing this also messes up the access of the legitimate user. basically what im trying to say is, I dont recommend this service since its very unsecure Users/JoeCool

20070131 22:52:45 nbsp Instaconnect sucks!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Its unstable and the service is not the same as what they advertised. Even if there is a problem and you call them for help, they cannot really help you. Service is crappy and slow. If you can get it for free, I guess its okay. But if you need to pay for it, might as well find another company. Users/CarlieYang

20070209 19:00:33 nbsp Instaconnect is horrible!!!!! there were days that our service was out for three days straight..a whole weekend! and two of my roomates hardly ever got service at all.  When they called instaconnect to ask about it they said it was their computers problem not the service. That is when they actually picked up the phone, i have their answering service memorized.. The only time they even offered to have anyone come out here to check out the problem was when we said we wanted to cancel, which by the way, you must pay a ONE HUNDRED FIFTY dollar cancellation fee that they dont tell you about when you sign up in order to cancel early.  And its slow as hell.  Users/SaraNetto
  20070711 19:09:52 nbsp This is in response to those people who mentioned the excessive cancellation fee. You can always dispute a charge made to your credit card if you made a good faith effort to resolve it with the merchant. Basically, by not providing you with a minimal level of customer service, Instaconnect has sold you an unsatisfactory product/service, thus your credit card company will usually just refund the charges. I believe you have to dispute within 3090 days of the charge though (unfortunately for me). In fact, you can even dispute their original charge to your credit card! Id recommend anyone whos recently signed up for the full year plan do this ASAP. Users/davisGeek

20070225 13:37:05 nbsp The free wireless service supplied by Instaconnect at Greenbriar Apartments has been either very slow or nonfunctioning for a month now. I called Instaconnect to complain twice. The first time, the support tech told me that they would fix the problem at the end of the day, but I saw no improvement. I called again about a week later, but no one answered the phone at 1 PM. Users/NerdUp

20070306 14:04:31 nbsp I currently use Instaconnect at Alvarado Sunset Apartments.  The internet here has been incredibly slow for a month and a half and I have had to call nearly twice to three times a week to even find out what is happening with the internet.  Their customer service is awful.  Although I will be staying in this complex next year THERE IS NO WAY I am keeping my Instaconnect service. Users/JeremyGimbel

20070708 16:27:45 nbsp Instaconnect offers subpar service.  Sometimes the connection suddenly becomes extremely slow.  Sometimes all access points just disappear (no connection).  When that sorta thing happens, there is not much you can do, even though the blackout periods have lasted up to 4 days in the past.  But perhaps the most infuriating part was to have been deprived of internet the day before dead day, dead day and the first day of finals for Fall, Winter and Spring Quarters.  Yes, all three.  I guess thats when everyone starts browsing the web for information.  Still, unacceptable.  If you want to get a C on you final because your internet was down and you wasted 2 hours the night before your test, get Instaconnect. Users/PaulWilburn

20070711 16:02:51 nbsp Well, it certainly sounds like everyone has been having problems with instaconnect, and complaining about them far more eloquently than I could.  I called them to complain today  they claim that ALL of their wireless access points have been working perfectly, EXCEPT AT MY APARTMENT COMPLEX!!!  They snottily implied that somehow it was my fault for living in a place where stuff keeps happening to their access points.  Just fyi, my service went down on July 5th, tech support voicemail was full, and monday morning I got a call saying their staff had gone home for the holiday weekend.  What kind of company doesnt have customer service on weekends?  So anyways, I am interested in hearing everyones Instaconnect horror stories  you can post em here or email me: sursurrus@yahoo.com

Also, just FYI, anyone buying the prepaid years service  they WILL double bill your credit card!  I paid it all up front, yet I still have been getting $28 charges to my credit card every month.  I think this is part of their dishonest business practice to defraud unsuspecting customers (particularly those who have parents who pay for their internet service).  Know your legal rights  you may demand interest to be paid on any fake charges to your credit card.
  This is not intentional.  Im not exactly sure whats going on there, but Im going to try and find out.  Users/RyanCastellucci

Anyways, if you too feel like you are getting an unacceptable level of service, contact me.  I worked for a crooked telemarketing company that STILL provided better customer service than instaconnect!!  Also, to maximize your chances of speaking to a real person, when you call the instaconnect number (5307591570) enter the extension for new account activation (I believe it is #4).  They only are interested in talking to you when taking your money )
  If nobody answers at Aria its either because everybody is on the phone or out of the office (yes, Aria has staffing issues.  Turnover sucks.  Ive complained about this often internally.  It seems that it is being worked on, though I do 99% of my work remotely, so I am less in touch with what is going on there.).  All those options go to the same group of lines as far as I know, and our current phone system is too dumb to tell the rep what option you pushed.  Im supposed to be replacing the current phone system with Asterisk by the time classes start back up to deal with those issues.  Key added features will be hold queuing (hopefully with hold tickets to call back later and get to the front of the queue, we know a lot of people use cell phones, and using up airtime waiting on hold sucks), and the ability to page the on call tech.  I have been complaining about the limited functionality of our phone system for quite a while, so dont think nobody cares.  I give a damn at least. Users/RyanCastellucci

Id like to thank everyone for sharing their stories about this deplorable company.  Id like to go down to their office with all their dissatisfied customers in person!  Also, I notice that for the last year or so (since 2006) Mr Ryan Castellucci has had no response to any of the customer complaints.  Ryan, this comment is directed at you or any other instaconnect employee who reads this.  What kind of crooks are you?  How can you even pretend to compete with legitimate businesses such as Comcast and Verizon DSL? Users/davisGeek
  Ok, Ill bite; the crook comment did it.  I have not lived in Davis since December 2007, and Ive been very busy with school since August 2006, which is why I have not been addressing things on the wiki (I significantly cut my hours with Aria at that time).  Responding to complaints on the wiki is something I was doing in my spare time when I could; it is not and was not my responsibility to do that.  Ive since been going to college full time, which most people here should understand is a huge timesink.  Only reason I saw this is because someone mentioned your comment on my user page.  I do have my own internal list of gripes, mostly related to staffing and the phone system.  Ive also had gripes about the way customer service gets handled, and that is WHY I was monitoring the wiki. Users/RyanCastellucci
   Dont be fooled.  Instaconnect did the same thing last year before I signed up  Ryan went around and made excuses and I bought it, they were working to address their issues, etc.  The point is, these are known issues, the company is woefully understaffed, and run by a crook (John C. Reedy).  They promise the world, then cant deliver on half their promises.  DONT BE FOOLED THE SAME WAY I WAS!!!!!!!  Note how changes are only being made so they can suck in a new years worth of prepaid customers.  Even the current phone reps seem to be dissatisfied with the company in similar ways to Ryan.  Dont let a shady, fly by night local company scam you!  They have the attitude that college students are cash cows to be milked, and could care less about customers (except when they complain loudly, longly and annoyingly, then they offer token refunds). Users/davisGeek
    There are some outstanding issues that need to be addressed, and some that have been taken care of.  I am personally working on the phone system, since that is something I can make better.  I actually give a damn about people, and have personally been onsite past midnight working on an issue more then once, and have gone to peoples apartments to spend hours fixing their computers. Dont make ME personally out to be a bad guy.  Im not.  Users/RyanCastellucci

20070711 17:43:02 nbsp They are the worst internet provider I have ever met!!!!!
The internet is VERY SLOW AND UNSTABLE. The worst thing is that, everytime you complain they promise you they will fix it but they ignore it.
I do also have the weird problem about the service, by which I cant open any page. I can log in to their service but I cant open other pages, everytime I try to open to page it keep bringing me back to their front page!!! THIS IS FRUSTATING PLEASE DO NOT USE THEIR SERVICE UNTIL THEY IMPROVE. Users/UCDgrad

20070711 18:34:13 nbsp I want to say Im in painful to this instaconnect provider. Even it is very cheap compared to other providers but I always feel bad about the connection. The signal is always unstable and have problem all the time. From my experience, I could not use internet almost 1 week a month, I did believe me. Icalled service center to solve the problem and they said they will fix it for me but nothing happened!!!!!. I cant see ANY reason for the existance for instaconnects technical service anymore.  Users/mac

20070711 23:11:33 nbsp When using Instaconnects public wifi services in/near downtown Davis, Ive noticed unreliability similar to what some on this page have complained about  e.g. being redirected to the captive portal page mere minutes after seeing it, even though I maintained a constant connection during that time.

However, I find the recent nasty pseudonymous reviews very difficult to credit.  Theyd have a lot more credibility if they maintained a more respectful, balanced tone and used their real names.  As it stands, I wouldnt be surprised if one or more of them were competitors or otherwise acting in bad faith. Users/GrahamFreeman

20070712 01:41:31 nbsp My experience with Instaconnect was positive.  I lived at College Town Commons apartments for more than a year and Instaconnect was included with the rent.  (One of the few good things I can say about those apartments.)

There was an access point mounted just outside my apartment.   I had a strong reliable connection for over a year.  The one time I couldnt connect I got through to Customer Service almost immediately and she made some adjustments on her end that took care of the problem over the phone.

Maybe I had such good luck because the access point was right outside my apartment.  But really I had no complaints and especially not for free.  I left Davis six months ago and maybe things have changed. Users/SteveGreen
  20070712 08:58:59 nbsp Id like to suggest in response to the comment about Collegetown Commons that it fits the pattern of certain apartment communities being second class citizens in the eyes of Instaconnect.  I can only speculate as to why: physical distance from the main office, relatively few people who use the service, perhaps the presence/absence of Instaconnect employees also living there.  Maybe someone smart can do a distance based plot of complaints vs distance from Instaconnect main office?  I bitched out an Instaconnect employee and she admitted that the company has an extremely small number of employees.  I spoke to an Instaconnect repairman and he said that theyd only recently hired him, and hes their second repairman.  So  seems like it makes sense that the closer you live to Instaconnect office, the faster your internet goes back up (especially if the repairperson must physically powercycle the AP). Users/davisGeek

20070712 22:30:04 nbsp Also, last I knew, Ryan no longer works for Aria/Instaconnect.  Its highly likely no one there has any idea whats being discussed here Users/TarZxf

Having worked for a WISP I can say that having everybody in an apartment complex maintain an acceptable level of service is quite a task.  In fact, we only did it once, because its such a pain in the ass.  You can have a signal pushing the FCC limit, multiple access points and lots of bandwidth and still have tons of problems.  Unless you have very expensive tools you cannot track the source of interference and even if you could track it, you cant control it.  Other people have the right to run wifi routers, microwaves, cordless phones, etc.  These things can effectively DoS an entire network...and youd be surprised how far away a microwave can be and still interfere.  If your internet goes out every time somebody in your complex uses a microwave, youre not gonna have very stable internet.  The point of this is that while I would agree that Instaconnect is definitely not an ideal solution, that doesnt mean theyre just ignoring you and not trying to fix the problem.  That doesnt mean theyre not, either.  It could be that theyre not answering the phone cause theyre out working on the problem.  Who knows.  I dont think a lot of people understand how wireless connections and internet access work.  Basically, the chances of a it being reliable in an apartment complex are very close to none.  I do not understand why there is any demand for this type of service at all, but for some reason there is.  If there is a demand for it, people are going to be trying to make money off of it.  Im VERY surprised that this whole wireless apartment thing still exists.   Cafes, restaurants and stuff are a whole different story.  Right, so the point is that Instaconnect probably does have you unhappy, but that doesnt mean theyre out to fuck you.  I actually dont doubt that theyre trying to fix the problems that people are having.  That doesnt mean the problem will get fixed though.  Theyre just trying to provide a service that for some reason there is a demand for.  If people had researched this a little more before they subscribed, Im sure they would have strongly considered a different service.  However, maybe they didnt have the information, which is what I  hope this message will give them...even though it is kinda long and messy.  Users/BradBenedict
   I quote from above: It could be that theyre not answering the phone cause theyre out working on the problem.  Who knows.  Well, last time I checked, most businesses do not have their receptionists also handle onsite technical service issues, leaving them unable to answer the phone.  They are usually separate entities...maybe you did both at your WISP?  That must suck.  Point is, Instaconnects customer service is dismal, AND their actual service happens to be substandard.  This is why people are questioning the motives of this company.  It seems more than mere coincidence that they cant come up to par in either area, dont you think? Users/Eganio

20070717 11:35:04 nbsp Great point, Brad.  Learned something about wireless from yer post.  So basically by not having staff on weekends theyre almost guaranteeing outages, since all those things you mentioned could screw up the connection, and the fix is to reboot the wireless APs.  As far as them not being out to fuck me:  I feel fucked whenever Ive got something important (like bills, work etc) and the connection goes down, and tech supports voicemail is so full I cant even leave a message.  I think a lot of people in Davis are very nice and slow to assume malice where it could just be stupidity/incompetence  Im not one of them!  Bottom line is they should make it very clear what youre getting with the service.   Users/davisGeek

20070727 19:36:40 nbsp you have to keep in mind, the professional network link strives for 99.9 percent uptime, it would appear that aria doesnt come close / Users/StevenDaubert

20070802 15:29:05 nbsp Instaconnect at College Town Commons has been okay for the last few months  I can remember more than once in the last year though that they upgraded the APs or the network just went down, and it took an entire week talking to customer service to get it fixed  they either werent there, their hours suck, they have no idea whats going on OR they just lie to get you off the phone. (And if internet goes out on Friday, youre screwed until Monday!)  Only once when I called for a tech problems do I feel like I got an actual tech and not just a receptionist. Overall its okay but when I move Im getting DSL again; students need something reliable... and if they really do roll out captive portals at apartments I will be switching the day I see one.. Users/AshleyRummel
  There is captive portal software at the complexes where the management isnt paying to give it to all users.  Its supposed to only pester you once every couple of weeks, and not every time you connect, precisely because it would be annoying for it to come up every time. Users/RyanCastellucci

20070822 17:25:33 nbsp Ive been unable to use any public Instaconnect hotspots all summer. I used to get the login page in my browser and continue on successfully, but now I never see the login page. I tried logging onto their http://support.instaconnect.net support site, but it wont load. I tried emailing their support address, but it bounced. I tried calling their support, and got routed into a loop back and forth to a nonexistent receptionist. Does this company even exist anymore? If so, do they support Macs? Users/RobWestergaard

20070822 20:04:07 nbsp Ive got a huge complaint to add to this ever expanding list. I started using Instaconnect in late June signing a threemonth contract with them just for summer session. The service was dreadfully slow to begin with and it was frustrating to do the simplest things like researching information, etc. About four weeks ago, at the end of July, one of the access points at the Sycamore Lane Garden Apartments, mysteriously disappeared. I dismissed it as the first day went by just saying that the internet must have been out and Instaconnect would send a tech out immediately to fix it.

When our internet was still out after two days of no service, my roommate called, demanding to know what was wrong with the service. They responded that they knew about the problemas others had complained about itand would send a tech out to fix it. A week and a half went by without any blip of service whatsoever.

My roommate and I were told that our service was disconnected for absolutely no reason and they had turned it back on for us. I had thought this was kind of weird and it didnt seem like she knew what was going on at all with our internetdespite being part of the technical support staffand just said that someone would come to fix it.

They also took this opportunity to lie to us and tell us a tech was sent out to resolve the problem that day. But, like I said before, nothing had changed. By day five, I started calling them more frequently and talked to someone named Stephanie. She told me she would look into getting me a refund and would get back to me. Every single time I called and spoke with Stephanie, she always told me the problem was being looked into, the problem was being looked into, etc, etc, etc.

Finally, I guess enough people complained and Instaconnect sent someone to deal with the problem. The tech simply reset the access point and it began to work. After a week and half of having no service, we were awarded with subpar internet. Finally, I decided to pursue my refund. Stephanie told me she would look into getting a refund for me and get back to me. After about one week of waiting for a response, I finally decided to call again and ask her what had happened. She told me, she would look into a refund for me. I was surprised that she hadnt even decided to do anything about it in the first place.

At the end of it, today, I finally got ahold of her again and told demanded to speak to someone who could tell me about a refund. She told me that she had the details of the refund worked out. I was going to be refunded $18.

Do not get this service. Stick with DSL or comcast, service is always slow and signal strength (at least in my apartment) is subpar. This is just a shoddy company who is highly disorganized and willing to allow a problem to fester before taking care of it. Users/CalvinCheng

20070827 18:48:26 nbsp I suspect they use a caching proxy server, on at least some of their systems. Many people have intermittent problems authenticating to UC Davis websites while on instaconnect.  http://tools.ietf.org/html/rfc3143 Users/TheodoreSuryapurnama
  We used to use squid, but stopped doing so due to load issues.  There was one problem a couple years ago causing authentication issues with UCD sites that was an issue with Instaconnects routing setup (the same problem was also causing people to be booted off instant messaging programs fairly often), but that was long since fixed. People do have problems authentication to MyUCDavis from instaconnect sometimes, but as I understand MyUCDavis in general has authentication issues fairly often (our other nix guy looked into it a couple times, and thinks that its just UCDs servers being moody, but I havent been able to look into that problem myself). Users/RyanCastellucci

20070827 19:21:17 nbsp you know, a buddy of mine and his friends lived in Jstreet appts and used instaconnect, it was reliable to the point where they had no complaints... Users/StevenDaubert

20070830 20:53:40 nbsp After weeks of customer service hell they finally refunded about 4 months of service (about $100).  Unfortunately I had to threaten them with small claims court, and spend hours of my time being lied to.  PLEASE THREATEN THEM WITH SMALL CLAIMS IT IS THE ONLY WAY TO GET A REFUND. Anyone who regularly has outages should persue this.  Dont even bother with customer service  talk directly to Evan Grey, call the instaconnect number and then hit extension 20 or email MailTo(egray@solisys.com).  He will lie to you, but stand your ground.  Maybe if enough people do this it will force this blatantly dishonest company out of business. Users/BillSimms

20070830 20:55:19 nbsp Dont believe Castellucis lies, nothings changed Users/BillSimms
  This is not a place for attacking (ex?) employees.  Ryan really does care about solving customers problems, or did when I (briefly) worked for SoliSys several years ago.  This page may be in need of cleaning up old comments/reviews. Users/SeanRegan
    I do, in fact, still care about making people satisfied. Thanks for backing me up, Sean. Users/RyanCastellucci
  Rather then personal attacks, why dont you just state what Ive said that you feel is untrue and why.  I havent knowingly said anything false here, and I dont appreciate accusations of such. Users/RyanCastellucci

20071002 01:47:31 nbsp I signed up for one month and checked the do not renew option. But they charged me for another month. Now I have to dispute the charge. Sigh. Users/AndreyGoder

20071008 22:08:17 nbsp im using instaconnect at university commons right now, where its provided free. the service died over the weekend (no response from the wireless spots though they were up) and no one i know here can connect to any .ucdavis.edu site (though it was fine a couple weeks ago, the past week it has stopped connecting to any ucdavis site shrugs). its also painfully slow during peak hours during evenings . ive decided to resort to purchasing comcasts special of $19.99 for 6 months going on right now.  Users/MiranPark

20071009 19:02:44 nbsp DO NOT USE INSTACONNECT.  They are complete LIARS and the internet is totally shitty. DONT DO IT. Users/LizzEhrenpreis

20071117 13:24:47 nbsp Dont get Instaconnect.  The speed is abysmal, and getting them on the phone to cancel your subscription is nearly impossible.  Plus, I told them about how I could only connect to the net 35 times during the three weeks that I used it, they said they would refund me, then never did.  Attempts to contact them later were entirely unsuccessful.  These people have shady business practices, and I cant imagine theyll remain in business much longer.  It is truly amazing that no one ever answers the phone, and when it goes to the answering machine, the machine is full since they never check it.  A very bad experience, and I got charged for an extra month that I didnt even request.   Users/digweed014

20071119 12:46:48 nbsp Simply put: Instaconnect blows at Arbors, all the time. Users/jefffy

20071124 18:46:24 nbsp The wireless at Greenbriar Apartments has been flaky for several weeks now. Sometimes it works fine, but frequently connections time out. The apartment manager called Instaconnect to complain, and the customer service representative tried to convince the manager that the age of her computer was the true culprit. Im no network engineer, but I dont see how the age of a computer causes connections to time out. Apparently, the age of the apartment managers computer also somehow influences the terrible service that the rest of the apartment residents experience. The quality of Instaconnects internet service is abysmal, and their customer support staff do not seem interested in remedying the problem. If you have a choice of going with another ISP, do it. Users/NerdUp

20071127 14:23:47 nbsp How do you cancel your Instaconnect account?  I cannot find a way to do so on the Instaconnect website, and I am able to access an Instaconnect hotspot because I am abroad right now.  My account has been billed $40 a month ever since I left my apartment in the beginning of August.  I selected a two month temporary contract, so it should have been automatically canceled.  But apparently if you read the fine print, your account remains active even after the contract.  This is a dirty trick to make money.  I have written emails asking to have my account canceled, and I received an email saying that I was being billed because my account was not selected to be terminated, but that this problem had been corrected and that I would be receiving a refund for the months that I did not use the service.  However, about two months after that email, I have been charged each month, and just recently, twice this month!  I have received no refund either, so my account is still clearly active.  What terrible service, I hope I dont have to sue this company for extortion.

If anyone can figure out how to cancel an account either on the Aria Communications website or the Instaconnect website, please help!  Users/Marrs487

20071129 21:43:15 nbsp It is true, Instaconnect does suck. But, they are improving!! I hated their services until about a month or two ago. And while the phones are not always answered, I have been getting calls back. I was billed twice, I called, left a message and it was taken care of almost right away. The people were helpful and friendly (despite popular belief). Sorry that others had a bad experience, but I like it! Users/sarahk

20071224 21:08:25 nbsp instaconnect is unusable @ university commons. But I dont really care since Im using comcast, just letting everyone know dont pay for it when their service is so bad  Users/acidicbase


!
! wrappers for markovst_gs_mod.f90
!

subroutine f90_markovst_gs_dense(n, Q, ldq, xstart, incxs, x, incx, &
  maxiter, rtol, steps, iter, rerror, info, callback)
  use markovst_gs
  integer, intent(in) :: n, ldq, incxs, incx, maxiter, steps
  double precision :: rtol
  double precision, intent(in) :: Q(1:ldq,1:n), xstart(1:incxs,1:n)
  double precision, intent(out) :: x(1:incx,1:n), rerror
  integer, intent(out) :: iter, info

  interface
    subroutine callback(iter, rerror)
      integer, intent(in) :: iter
      double precision, intent(in) :: rerror
    end subroutine callback
  end interface

  call markovst_gs_dense(n, Q, ldq, xstart, incxs, x, incx, &
  maxiter, rtol, steps, iter, rerror, info, callback)
end subroutine f90_markovst_gs_dense

subroutine f90_markovst_gs_csr(n, Q, rowptr, colind, nnz, xstart, incxs, x, incx, &
  maxiter, rtol, steps, iter, rerror, info, callback)
  use markovst_gs
  integer, intent(in) :: n, nnz, incxs, incx, maxiter, steps
  double precision :: rtol
  double precision, intent(in) :: Q(1:nnz), xstart(1:incxs,1:n)
  integer, intent(in) :: rowptr(1:n+1), colind(1:nnz)
  double precision, intent(out) :: x(1:incx,1:n), rerror
  integer, intent(out) :: iter, info

  interface
    subroutine callback(iter, rerror)
      integer, intent(in) :: iter
      double precision, intent(in) :: rerror
    end subroutine callback
  end interface

  call markovst_gs_csr(n, Q, rowptr, colind, nnz, xstart, incxs, x, incx, &
  maxiter, rtol, steps, iter, rerror, info, callback)
end subroutine f90_markovst_gs_csr

subroutine f90_markovst_gs_csc(n, Q, colptr, rowind, nnz, xstart, incxs, x, incx, &
  maxiter, rtol, steps, iter, rerror, info, callback)
  use markovst_gs
  integer, intent(in) :: n, nnz, incxs, incx, maxiter, steps
  double precision :: rtol
  double precision, intent(in) :: Q(1:nnz), xstart(1:incxs,1:n)
  integer, intent(in) :: colptr(1:n+1), rowind(1:nnz)
  double precision, intent(out) :: x(1:incx,1:n), rerror
  integer, intent(out) :: iter, info

  interface
    subroutine callback(iter, rerror)
      integer, intent(in) :: iter
      double precision, intent(in) :: rerror
    end subroutine callback
  end interface

  call markovst_gs_csc(n, Q, colptr, rowind, nnz, xstart, incxs, x, incx, &
  maxiter, rtol, steps, iter, rerror, info, callback)
end subroutine f90_markovst_gs_csc


text:
!
!  Copyright (C) 2013, Northwestern University and Argonne National Laboratory
!  See COPYRIGHT notice in top-level directory.
!
!     This is part of the PnetCDF package.
!
!     $Id: tst_f90_cdf5.f90 2131 2015-09-25 22:33:12Z wkliao $

program tst_f90_nc4
  use mpi
  use pnetcdf
  implicit none
  integer :: fh, cmode, err, ierr, dimid, varid, ndim, nvar, get_args
  character (len = *), parameter :: FILE_NAME = "tst_f90_nc4.nc"
  integer(KIND=MPI_OFFSET_KIND) :: ten=10
  character(LEN=256) filename, cmd, msg
  integer my_rank, p

  call MPI_Init(ierr)
  call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierr)
  call MPI_Comm_size(MPI_COMM_WORLD, p, ierr)

  ! take filename from command-line argument if there is any
  if (my_rank .EQ. 0) then
      filename = FILE_NAME
      err = get_args(cmd, filename)
  endif
  call MPI_Bcast(err, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
  if (err .EQ. 0) goto 999

  call MPI_Bcast(filename, 256, MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr)

!  if (p .ne. 1 .AND. my_rank .eq. 0) then
!     print *, 'Warning: ',trim(cmd),' is design to run on 1 process'
!  endif

  cmode = IOR(NF90_CLOBBER, NF90_64BIT_DATA)
  call check(nf90mpi_create(MPI_COMM_WORLD, filename, cmode, MPI_INFO_NULL, fh))
  call check(nf90mpi_def_dim(fh, 'fred', ten, dimid))
  call check(nf90mpi_def_var(fh, 'john', NF90_INT, (/dimid/), varid))
  call check(nf90mpi_close(fh))

  ! Check the file.
  call check(nf90mpi_open(MPI_COMM_WORLD, filename, NF90_WRITE, MPI_INFO_NULL, fh))
  call check(nf90mpi_inquire(fh, nDimensions = ndim, nVariables = nvar))
  if (nvar .ne. 1 .or. ndim .ne. 1) stop 3
  call check(nf90mpi_close(fh))

  call check(nf90mpi_create(MPI_COMM_WORLD, filename, cmode, MPI_INFO_NULL, fh))
  call check(nf90mpi_def_dim(fh, 'fred', ten, dimid))
  call check(nf90mpi_def_var(fh, 'john', NF90_INT, (/dimid/), varid))
  call check(nf90mpi_close(fh))

  ! Check the file.
  call check(nf90mpi_open(MPI_COMM_WORLD, filename, NF90_WRITE, MPI_INFO_NULL, fh))
  call check(nf90mpi_inquire(fh, nDimensions = ndim, nVariables = nvar))
  if (nvar .ne. 1 .or. ndim .ne. 1) stop 3
  call check(nf90mpi_close(fh))

   msg = '*** TESTING F90 '//trim(cmd)
   if (my_rank .eq. 0) call pass_fail(0, msg)

 999 call MPI_Finalize(ierr)

contains
!     This subroutine handles errors by printing an error message and
!     exiting with a non-zero status.
  subroutine check(errcode)
    implicit none
    integer, intent(in) :: errcode

    if(errcode /= nf90_noerr) then
       print *, 'Error: ', trim(nf90mpi_strerror(errcode))
       stop 2
    endif
  end subroutine check
end program tst_f90_nc4

max_stars_repo_name: utdsimmons/ohpc

max_issues_repo_name: utdsimmons/ohpc

max_forks_repo_name: utdsimmons/ohpc


!
!  Copyright 2017 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine conv_core_exc_cor
  use salmon_parallel, only: nproc_group_h
  use salmon_communication, only: comm_summation
  use scf_data
  use new_world_sub
  use allocate_mat_sub
  implicit none
  integer :: ix,iy,iz
  character(20) :: xc_tmp
  integer :: jspin
  real(8) :: cval_t
  real(8) :: tot_exc

  xc_tmp='pz'
  jspin=0
  cval_t=0.d0

  do iz=1,ng_num(3)
  do iy=1,ng_num(2)
  do ix=1,ng_num(1)
    rho_tmp(ix,iy,iz)=rho(ng_sta(1)+ix-1,ng_sta(2)+iy-1,ng_sta(3)+iz-1)
  end do
  end do
  end do

  call core_exc_cor(xc_tmp, jspin, cval_t, ng_num(1), ng_num(2), ng_num(3), Hvol,  &
                    rho_tmp, exc_dummy2, exc_dummy, exc_dummy3, exc_dummy3, &
                    exc_dummy, exc_dummy, vxc_tmp, exc_dummy2, exc_dummy2, tot_exc)

  do iz=1,ng_num(3)
  do iy=1,ng_num(2)
  do ix=1,ng_num(1)
    vxc(ng_sta(1)+ix-1,ng_sta(2)+iy-1,ng_sta(3)+iz-1)=vxc_tmp(ix,iy,iz)
  end do
  end do
  end do

  call comm_summation(tot_exc,Exc,nproc_group_h)

  return
end subroutine conv_core_exc_cor


text:
*> \brief \b XERBLA
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE XERBLA( SRNAME, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER*(*)      SRNAME
*       INTEGER            INFO
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> This is a special version of XERBLA to be used only as part of
*> the test program for testing error exits from the LAPACK routines.
*> Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRNAMT,
*> where INFOT and SRNAMT are values stored in COMMON.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] SRNAME
*> \verbatim
*>          SRNAME is CHARACTER*(*)
*>          The name of the subroutine calling XERBLA.  This name should
*>          match the COMMON variable SRNAMT.
*> \endverbatim
*>
*> \param[in] INFO
*> \verbatim
*>          INFO is INTEGER
*>          The error return code from the calling subroutine.  INFO
*>          should equal the COMMON variable INFOT.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup aux_eig
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The following variables are passed via the common blocks INFOC and
*>  SRNAMC:
*>
*>  INFOT   INTEGER      Expected integer return code
*>  NOUT    INTEGER      Unit number for printing error messages
*>  OK      LOGICAL      Set to .TRUE. if INFO = INFOT and
*>                       SRNAME = SRNAMT, otherwise set to .FALSE.
*>  LERR    LOGICAL      Set to .TRUE., indicating that XERBLA was called
*>  SRNAMT  CHARACTER*(*) Expected name of calling subroutine
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE XERBLA( SRNAME, INFO )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER*(*)      SRNAME
      INTEGER            INFO
*     ..
*
*  =====================================================================
*
*     .. Scalars in Common ..
      LOGICAL            LERR, OK
      CHARACTER*32       SRNAMT
      INTEGER            INFOT, NOUT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          LEN_TRIM
*     ..
*     .. Common blocks ..
      COMMON             / INFOC / INFOT, NOUT, OK, LERR
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Executable Statements ..
*
      LERR = .TRUE.
      IF( INFO.NE.INFOT ) THEN
         IF( INFOT.NE.0 ) THEN
            WRITE( NOUT, FMT = 9999 )
     $     SRNAMT( 1:LEN_TRIM( SRNAMT ) ), INFO, INFOT
         ELSE
            WRITE( NOUT, FMT = 9997 )
     $     SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
         END IF
         OK = .FALSE.
      END IF
      IF( SRNAME.NE.SRNAMT ) THEN
         WRITE( NOUT, FMT = 9998 )
     $     SRNAME( 1:LEN_TRIM( SRNAME ) ),
     $     SRNAMT( 1:LEN_TRIM( SRNAMT ) )
         OK = .FALSE.
      END IF
      RETURN
*
 9999 FORMAT( ' *** XERBLA was called from ', A, ' with INFO = ', I6,
     $      ' instead of ', I2, ' ***' )
 9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A,
     $      ' instead of ', A6, ' ***' )
 9997 FORMAT( ' *** On entry to ', A, ' parameter number ', I6,
     $      ' had an illegal value ***' )
*
*     End of XERBLA
*
      END

ext: f

max_stars_repo_name: drhpc/OpenBLAS

max_issues_repo_name: drhpc/OpenBLAS

max_forks_repo_name: drhpc/OpenBLAS


text:
subroutine dialog_color_palette(dlbox,Color_matrix,number_color)
	use dflib
	use dialogm
	include 'resources.fd'
	character(len=3)::text
	logical::test,keystate
	integer::Color_matrix(4,8),number,number_color
	type (dialog) dlgbox
	test=dlginit(IDD_Color_palette,dlgbox)
	if (test==.false.) then
		print*,'Failed to initialized dialog box'
		return
	end if
	test=dlgmodal(dlgbox)
!--------------color1------------------------
	test=dlgget(dlgbox,IDC_color1r,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(1,1)=number
	endif
	test=dlgget(dlgbox,IDC_color1g,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(2,1)=number
	endif
	test=dlgget(dlgbox,IDC_color1b,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(3,1)=number
	endif
	test=dlgget(dlgbox,IDC_color1p,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(4,1)=number
	endif
!--------------color 2-------------------------
	test=dlgget(dlgbox,IDC_color2r,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(1,2)=number
	else
		number_color=1
		return
	endif
	test=dlgget(dlgbox,IDC_color2g,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(2,2)=number
	endif
	test=dlgget(dlgbox,IDC_color2b,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(3,2)=number
	endif
	test=dlgget(dlgbox,IDC_color2p,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(4,2)=number
	endif
!--------------color 3-------------------------
	test=dlgget(dlgbox,IDC_color3r,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(1,3)=number
	else
		number_color=2
		return
	endif
	test=dlgget(dlgbox,IDC_color3g,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(2,3)=number
	endif
	test=dlgget(dlgbox,IDC_color3b,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(3,3)=number
	endif
	test=dlgget(dlgbox,IDC_color3p,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(4,3)=number
	endif
!--------------color 4-------------------------
	test=dlgget(dlgbox,IDC_color4r,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(1,4)=number
	else
		number_color=3
		return
	endif
	test=dlgget(dlgbox,IDC_color4g,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(2,4)=number
	endif
	test=dlgget(dlgbox,IDC_color4b,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(3,4)=number
	endif
	test=dlgget(dlgbox,IDC_color4p,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(4,4)=number
	endif
!--------------color 5-------------------------
	test=dlgget(dlgbox,IDC_color5r,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(1,5)=number
	else
		number_color=4
		return
	endif
	test=dlgget(dlgbox,IDC_color5g,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(2,5)=number
	endif
	test=dlgget(dlgbox,IDC_color5b,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(3,5)=number
	endif
	test=dlgget(dlgbox,IDC_color5p,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(4,5)=number
	endif
!--------------color 6-------------------------
	test=dlgget(dlgbox,IDC_color6r,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(1,6)=number
	else
		number_color=5
		return
	endif
	test=dlgget(dlgbox,IDC_color6g,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(2,6)=number
	endif
	test=dlgget(dlgbox,IDC_color6b,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(3,6)=number
	endif
	test=dlgget(dlgbox,IDC_color6p,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(4,6)=number
	endif
!--------------color 7-------------------------
	test=dlgget(dlgbox,IDC_color7r,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(1,7)=number
	else
		number_color=6
		return
	endif
	test=dlgget(dlgbox,IDC_color7g,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(2,7)=number
	endif
	test=dlgget(dlgbox,IDC_color7b,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(3,7)=number
	endif
	test=dlgget(dlgbox,IDC_color7p,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(4,7)=number
	endif
!--------------color 8-------------------------
	test=dlgget(dlgbox,IDC_color8r,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(1,8)=number
	else
		number_color=7
		return
	endif
	test=dlgget(dlgbox,IDC_color8g,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(2,8)=number
	endif
	test=dlgget(dlgbox,IDC_color8b,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(3,8)=number
	endif
	test=dlgget(dlgbox,IDC_color8p,text)
	if (text/='    ') then
		read (text,*),number
		color_matrix(4,8)=number
	endif
!---------------Preview------------------------
	test=dlgget(dlgbox,idc_preview,keystate)
	number_color=8
end subroutine Dialog_color_palette

max_stars_repo_path: Src/Color Palette Box.f90

max_stars_repo_name: Armanimani/FractalGenerator

max_issues_repo_path: Src/Color Palette Box.f90

max_issues_repo_name: Armanimani/FractalGenerator

max_forks_repo_path: Src/Color Palette Box.f90

max_forks_repo_name: Armanimani/FractalGenerator


text:
great(g1,ee1).
great(l1,p1).
great(ii1,t1).
great(jj1,i1).
great(z1,p1).
great(o1,n1).
great(z1,j1).
great(jj1,x1).
great(kk1,o1).
great(r1,ll1).
great(l1,g1).
great(k1,b1).
great(l1,x1).
great(c1,h1).
great(m1,n1).
great(h1,jj1).
great(k1,ll1).
great(k1,jj1).
great(hh1,l1).
great(ii1,o1).
great(bb1,ll1).
great(ff1,m1).
great(c1,t1).
great(cc1,p1).
great(ff1,ee1).
great(jj1,bb1).
great(ii1,jj1).
great(ii1,s1).
great(j1,u1).
great(h1,p1).
great(f1,ff1).
great(jj1,b1).
great(w1,ll1).
great(i1,o1).
great(c1,v1).
great(z1,aa1).
great(g1,j1).
great(ii1,ff1).
great(kk1,t1).
great(d1,w1).
great(m1,o1).
great(j1,jj1).
great(a1,m1).
great(f1,d1).
great(r1,ee1).
great(k1,q1).
great(f1,i1).
great(z1,q1).
great(z1,i1).
great(t1,n1).
great(i1,ee1).
great(kk1,m1).
great(j1,aa1).
great(e1,ee1).
great(u1,v1).
great(e1,cc1).
great(t1,ll1).
great(d1,l1).
great(j1,m1).
great(ii1,dd1).
great(kk1,n1).
great(s1,m1).
great(cc1,aa1).
great(ee1,m1).
great(hh1,ee1).
great(x1,ll1).
great(k1,j1).
great(q1,u1).
great(y1,kk1).
great(l1,q1).
great(q1,x1).
great(e1,i1).
great(cc1,o1).
great(ee1,o1).
great(ii1,ee1).
great(y1,b1).
great(z1,bb1).
great(c1,jj1).
great(d1,q1).
great(f1,jj1).
great(k1,ee1).
great(jj1,t1).
great(k1,y1).
great(l1,m1).
great(q1,b1).
great(y1,n1).
great(bb1,p1).
great(f1,r1).
great(h1,dd1).
great(hh1,cc1).
great(h1,u1).
great(hh1,t1).
great(bb1,o1).
great(d1,z1).
great(e1,v1).
great(g1,u1).
great(aa1,b1).
great(w1,t1).
great(w1,o1).
great(h1,ee1).
great(jj1,p1).
great(g1,o1).
great(hh1,a1).
great(bb1,w1).
great(ff1,v1).
great(h1,y1).
great(u1,cc1).
great(q1,n1).
great(k1,kk1).
great(aa1,n1).
great(f1,g1).
great(u1,o1).
great(v1,o1).
great(e1,j1).
great(hh1,aa1).
great(dd1,aa1).
great(c1,dd1).
great(i1,m1).
great(c1,l1).
great(a1,kk1).
great(g1,v1).
great(c1,p1).
great(ff1,p1).
great(c1,kk1).
great(p1,t1).
great(s1,p1).
great(v1,n1).
great(cc1,kk1).
great(h1,d1).
great(hh1,z1).
great(y1,ee1).
great(k1,aa1).
great(g1,m1).
great(a1,n1).
great(jj1,o1).
great(d1,dd1).
great(f1,j1).
great(ee1,s1).
great(i1,bb1).
great(j1,t1).
great(z1,s1).
great(h1,l1).
great(aa1,ll1).
great(ff1,u1).
great(c1,d1).
great(f1,ll1).
great(q1,ee1).
great(u1,dd1).
great(e1,g1).
great(j1,r1).
great(h1,x1).
great(i1,kk1).
great(cc1,n1).
great(hh1,o1).
great(q1,p1).
great(jj1,kk1).
great(u1,s1).
great(kk1,s1).
great(e1,r1).
great(ii1,i1).
great(c1,n1).
great(p1,m1).
great(z1,kk1).
great(dd1,w1).
great(jj1,ff1).
great(b1,t1).
great(l1,cc1).
great(e1,l1).
great(c1,f1).
great(dd1,m1).
great(d1,u1).
great(a1,x1).
great(s1,ll1).
great(a1,ff1).
great(f1,hh1).
great(f1,cc1).
great(k1,cc1).
great(d1,kk1).
great(q1,s1).
great(k1,t1).
great(f1,x1).
great(i1,p1).
great(l1,dd1).
great(b1,ll1).
great(h1,q1).
great(hh1,v1).
great(k1,z1).
great(e1,bb1).
great(f1,kk1).
great(hh1,r1).
great(jj1,n1).
great(cc1,ee1).
great(u1,x1).
great(q1,ff1).
great(g1,ll1).
great(e1,b1).
great(z1,jj1).
great(j1,n1).
great(j1,x1).
great(a1,y1).
great(d1,v1).
great(ff1,n1).
great(z1,cc1).
great(h1,cc1).
great(z1,b1).
great(e1,aa1).
great(u1,bb1).
great(j1,y1).
great(a1,v1).
great(c1,r1).
great(d1,j1).
great(jj1,ll1).
great(d1,r1).
great(c1,ll1).
great(l1,z1).
great(dd1,ll1).
great(i1,v1).
great(k1,u1).
great(r1,kk1).
great(ee1,w1).
great(hh1,u1).
great(l1,aa1).
great(kk1,aa1).
great(c1,s1).
great(d1,m1).
great(l1,r1).
great(aa1,w1).
great(a1,i1).
great(g1,t1).
great(ii1,v1).
great(g1,p1).
great(k1,i1).
great(e1,x1).
great(r1,w1).
great(r1,n1).
great(e1,a1).
great(j1,o1).
great(a1,p1).
great(dd1,bb1).
great(kk1,x1).
great(l1,v1).
great(hh1,dd1).
great(hh1,ll1).
great(f1,h1).
great(kk1,w1).
great(ii1,k1).
great(d1,ll1).
great(e1,k1).
great(f1,dd1).
great(hh1,h1).
great(i1,w1).
great(h1,v1).
great(w1,n1).
great(y1,t1).
great(h1,kk1).
great(j1,v1).
great(v1,p1).
great(jj1,ee1).
great(ii1,y1).
great(g1,q1).
great(u1,r1).
great(c1,j1).
great(b1,n1).
great(x1,b1).
great(x1,s1).
great(j1,b1).
great(ii1,d1).
great(ii1,cc1).
great(l1,y1).
great(e1,m1).
great(b1,s1).
great(jj1,cc1).
great(hh1,e1).
great(c1,y1).
great(f1,m1).
great(bb1,m1).
great(q1,t1).
great(hh1,b1).
great(q1,r1).
great(k1,bb1).
great(ii1,h1).
great(q1,kk1).
great(ii1,hh1).
great(l1,ee1).
great(h1,n1).
great(ee1,x1).
great(g1,b1).
great(f1,t1).
great(dd1,x1).
great(u1,i1).
great(dd1,p1).
great(e1,q1).
great(k1,n1).
great(j1,ee1).
great(y1,bb1).
great(y1,u1).
great(ii1,x1).
great(f1,u1).
great(z1,w1).
great(ff1,kk1).
great(a1,aa1).
great(l1,i1).
great(i1,dd1).
great(y1,dd1).
great(e1,jj1).
great(ff1,t1).
great(f1,z1).
great(a1,w1).
great(ii1,e1).
great(ee1,b1).
great(ii1,ll1).
great(f1,bb1).
great(bb1,s1).
great(b1,w1).
great(d1,ee1).
great(h1,t1).
great(h1,ll1).
great(c1,z1).
great(r1,m1).
great(e1,p1).
great(d1,p1).
great(ii1,kk1).
great(q1,o1).
great(jj1,q1).
great(a1,z1).
great(j1,q1).
great(l1,j1).
great(dd1,kk1).
great(k1,a1).
great(cc1,m1).
great(ff1,w1).
great(ff1,x1).
great(ff1,dd1).
great(k1,o1).
great(bb1,t1).
great(a1,bb1).
great(u1,t1).
great(k1,dd1).
great(bb1,x1).
great(g1,x1).
great(a1,ll1).
great(l1,ff1).
great(v1,kk1).
great(f1,ee1).
great(hh1,y1).
great(a1,s1).
great(r1,bb1).
great(d1,s1).
great(y1,m1).
great(x1,o1).
great(f1,v1).
great(c1,b1).
great(hh1,x1).
great(x1,m1).
great(dd1,o1).
great(g1,s1).
great(y1,cc1).
great(j1,cc1).
great(g1,aa1).
great(aa1,s1).
great(f1,n1).
great(hh1,ff1).
great(dd1,t1).
great(i1,ll1).
great(f1,a1).
great(g1,w1).
great(z1,ff1).
great(v1,ee1).
great(f1,w1).
great(v1,aa1).
great(j1,bb1).
great(z1,v1).
great(j1,i1).
great(y1,o1).
great(v1,x1).
great(i1,s1).
great(a1,u1).
great(d1,bb1).
great(c1,ee1).
great(r1,b1).
great(e1,z1).
great(y1,p1).
great(y1,v1).
great(l1,o1).
great(hh1,m1).
great(ff1,ll1).
great(ii1,u1).
great(b1,m1).
great(hh1,j1).
great(q1,aa1).
great(c1,i1).
great(x1,p1).
great(hh1,k1).
great(u1,ll1).
great(dd1,b1).
great(s1,n1).
great(z1,o1).
great(cc1,ll1).
great(i1,t1).
great(ii1,bb1).
great(a1,dd1).
great(ee1,kk1).
great(f1,b1).
great(h1,ff1).
great(q1,v1).
great(x1,n1).
great(g1,ff1).
great(jj1,r1).
great(f1,aa1).
great(ii1,w1).
great(p1,n1).
great(u1,p1).
great(i1,x1).
great(z1,r1).
great(cc1,dd1).
great(g1,i1).
great(d1,g1).
great(v1,w1).
great(c1,e1).
great(ii1,g1).
great(g1,dd1).
great(ff1,bb1).
great(p1,ll1).
great(ii1,m1).
great(f1,o1).
great(q1,m1).
great(ii1,j1).
great(u1,m1).
great(u1,n1).
great(y1,i1).
great(c1,a1).
great(h1,i1).
great(i1,aa1).
great(v1,bb1).
great(y1,ff1).
great(r1,aa1).
great(q1,bb1).
great(ee1,aa1).
great(k1,r1).
great(l1,bb1).
great(f1,ii1).
great(kk1,bb1).
great(l1,kk1).
great(h1,b1).
great(c1,u1).
great(h1,aa1).
great(o1,l1).
great(t1,aa1).
great(o1,t1).
great(o1,cc1).
great(ll1,z1).
great(m1,u1).
great(kk1,ii1).
great(r1,l1).
great(u1,d1).
great(z1,k1).
great(s1,hh1).
great(b1,cc1).
great(v1,dd1).
great(ll1,c1).
great(aa1,ee1).
great(dd1,r1).
great(i1,a1).
great(g1,z1).
great(q1,k1).
great(o1,kk1).
great(n1,w1).
great(m1,hh1).
great(cc1,ff1).
great(ii1,c1).
great(w1,r1).
great(q1,hh1).
great(p1,h1).
great(y1,ii1).
great(w1,j1).
great(u1,j1).
great(jj1,f1).
great(p1,r1).
great(o1,h1).
great(w1,a1).
great(bb1,i1).
great(m1,bb1).
great(d1,ii1).
great(dd1,y1).
great(kk1,y1).
great(dd1,q1).
great(w1,ii1).
great(ll1,p1).
great(m1,d1).
great(t1,u1).
great(g1,hh1).
great(dd1,ii1).
great(b1,kk1).
great(s1,q1).
great(g1,a1).
great(n1,aa1).
great(ll1,h1).
great(v1,y1).
great(u1,z1).
great(x1,l1).
great(x1,hh1).
great(dd1,f1).
great(kk1,jj1).
great(cc1,k1).
great(aa1,r1).
great(aa1,bb1).
great(i1,l1).
great(z1,ii1).
great(ll1,ff1).
great(k1,hh1).
great(w1,e1).
great(u1,y1).
great(x1,i1).
great(n1,r1).
great(s1,bb1).
great(j1,c1).
great(ee1,z1).
great(s1,y1).
great(ee1,y1).
great(ll1,dd1).
great(a1,h1).
great(aa1,u1).
great(aa1,y1).
great(i1,z1).
great(n1,ll1).
great(kk1,u1).
great(o1,g1).
great(e1,c1).
great(x1,ff1).
great(o1,i1).
great(m1,aa1).
great(d1,hh1).
great(n1,p1).
great(x1,c1).
great(kk1,hh1).
great(bb1,dd1).
great(p1,q1).
great(aa1,q1).
great(bb1,ii1).
great(bb1,hh1).
great(o1,jj1).
great(ll1,d1).
great(o1,hh1).
great(d1,h1).
great(n1,ii1).
great(kk1,e1).
great(jj1,ii1).
great(dd1,z1).
great(cc1,c1).
great(r1,j1).
great(t1,ff1).
great(b1,jj1).
great(p1,ii1).
great(bb1,l1).
great(ff1,j1).
great(k1,c1).
great(j1,hh1).
great(w1,k1).
great(cc1,h1).
great(bb1,j1).
great(w1,hh1).
great(bb1,v1).
great(e1,h1).
great(m1,r1).
great(y1,g1).
great(aa1,a1).
great(y1,c1).
great(ff1,jj1).
great(kk1,q1).
great(b1,dd1).
great(x1,ii1).
great(b1,x1).
great(aa1,g1).
great(i1,k1).
great(h1,hh1).
great(b1,y1).
great(t1,r1).
great(ll1,kk1).
great(ee1,a1).
great(kk1,a1).
great(aa1,ii1).
great(w1,b1).
great(ee1,cc1).
great(n1,j1).
great(p1,cc1).
great(b1,d1).
great(bb1,a1).
great(r1,a1).
great(p1,y1).
great(ff1,l1).
great(n1,f1).
great(i1,q1).
great(t1,bb1).
great(v1,d1).
great(aa1,ff1).
great(m1,ee1).
great(ll1,r1).

max_stars_repo_name: manoelfranca/cilppp

max_issues_repo_name: manoelfranca/cilppp

max_forks_repo_name: manoelfranca/cilppp


text:
      SUBROUTINE SLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB,
     $                   LDAB, B, WORK, INFO )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            IMAT, INFO, KD, LDAB, N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      REAL               AB( LDAB, * ), B( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  SLATTB generates a triangular test matrix in 2-dimensional storage.
*  IMAT and UPLO uniquely specify the properties of the test matrix,
*  which is returned in the array A.
*
*  Arguments
*  =========
*
*  IMAT    (input) INTEGER
*          An integer key describing which matrix to generate for this
*          path.
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the matrix A will be upper or lower
*          triangular.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  TRANS   (input) CHARACTER*1
*          Specifies whether the matrix or its transpose will be used.
*          = 'N':  No transpose
*          = 'T':  Transpose
*          = 'C':  Conjugate transpose (= transpose)
*
*  DIAG    (output) CHARACTER*1
*          Specifies whether or not the matrix A is unit triangular.
*          = 'N':  Non-unit triangular
*          = 'U':  Unit triangular
*
*  ISEED   (input/output) INTEGER array, dimension (4)
*          The seed vector for the random number generator (used in
*          SLATMS).  Modified on exit.
*
*  N       (input) INTEGER
*          The order of the matrix to be generated.
*
*  KD      (input) INTEGER
*          The number of superdiagonals or subdiagonals of the banded
*          triangular matrix A.  KD >= 0.
*
*  AB      (output) REAL array, dimension (LDAB,N)
*          The upper or lower triangular banded matrix A, stored in the
*          first KD+1 rows of AB.  Let j be a column of A, 1<=j<=n.
*          If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j.
*          If UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= KD+1.
*
*  B       (workspace) REAL array, dimension (N)
*
*  WORK    (workspace) REAL array, dimension (2*N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, TWO, ZERO
      PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      CHARACTER          DIST, PACKIT, TYPE
      CHARACTER*3        PATH
      INTEGER            I, IOFF, IY, J, JCOUNT, KL, KU, LENJ, MODE
      REAL               ANORM, BIGNUM, BNORM, BSCAL, CNDNUM, PLUS1,
     $                   PLUS2, REXP, SFAC, SMLNUM, STAR1, TEXP, TLEFT,
     $                   TNORM, TSCAL, ULP, UNFL
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ISAMAX
      REAL               SLAMCH, SLARND
      EXTERNAL           LSAME, ISAMAX, SLAMCH, SLARND
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SLABAD, SLARNV, SLATB4, SLATMS, SSCAL,
     $                   SSWAP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, REAL, SIGN, SQRT
*     ..
*     .. Executable Statements ..
*
      PATH( 1: 1 ) = 'Single precision'
      PATH( 2: 3 ) = 'TB'
      UNFL = SLAMCH( 'Safe minimum' )
      ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
      SMLNUM = UNFL
      BIGNUM = ( ONE-ULP ) / SMLNUM
      CALL SLABAD( SMLNUM, BIGNUM )
      IF( ( IMAT.GE.6 .AND. IMAT.LE.9 ) .OR. IMAT.EQ.17 ) THEN
         DIAG = 'U'
      ELSE
         DIAG = 'N'
      END IF
      INFO = 0
*
*     Quick return if N.LE.0.
*
      IF( N.LE.0 )
     $   RETURN
*
*     Call SLATB4 to set parameters for SLATMS.
*
      UPPER = LSAME( UPLO, 'U' )
      IF( UPPER ) THEN
         CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
     $                CNDNUM, DIST )
         KU = KD
         IOFF = 1 + MAX( 0, KD-N+1 )
         KL = 0
         PACKIT = 'Q'
      ELSE
         CALL SLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
     $                CNDNUM, DIST )
         KL = KD
         IOFF = 1
         KU = 0
         PACKIT = 'B'
      END IF
*
*     IMAT <= 5:  Non-unit triangular matrix
*
      IF( IMAT.LE.5 ) THEN
         CALL SLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM,
     $                KL, KU, PACKIT, AB( IOFF, 1 ), LDAB, WORK, INFO )
*
*     IMAT > 5:  Unit triangular matrix
*     The diagonal is deliberately set to something other than 1.
*
*     IMAT = 6:  Matrix is the identity
*
      ELSE IF( IMAT.EQ.6 ) THEN
         IF( UPPER ) THEN
            DO 20 J = 1, N
               DO 10 I = MAX( 1, KD+2-J ), KD
                  AB( I, J ) = ZERO
   10          CONTINUE
               AB( KD+1, J ) = J
   20       CONTINUE
         ELSE
            DO 40 J = 1, N
               AB( 1, J ) = J
               DO 30 I = 2, MIN( KD+1, N-J+1 )
                  AB( I, J ) = ZERO
   30          CONTINUE
   40       CONTINUE
         END IF
*
*     IMAT > 6:  Non-trivial unit triangular matrix
*
*     A unit triangular matrix T with condition CNDNUM is formed.
*     In this version, T only has bandwidth 2, the rest of it is zero.
*
      ELSE IF( IMAT.LE.9 ) THEN
         TNORM = SQRT( CNDNUM )
*
*        Initialize AB to zero.
*
         IF( UPPER ) THEN
            DO 60 J = 1, N
               DO 50 I = MAX( 1, KD+2-J ), KD
                  AB( I, J ) = ZERO
   50          CONTINUE
               AB( KD+1, J ) = REAL( J )
   60       CONTINUE
         ELSE
            DO 80 J = 1, N
               DO 70 I = 2, MIN( KD+1, N-J+1 )
                  AB( I, J ) = ZERO
   70          CONTINUE
               AB( 1, J ) = REAL( J )
   80       CONTINUE
         END IF
*
*        Special case:  T is tridiagonal.  Set every other offdiagonal
*        so that the matrix has norm TNORM+1.
*
         IF( KD.EQ.1 ) THEN
            IF( UPPER ) THEN
               AB( 1, 2 ) = SIGN( TNORM, SLARND( 2, ISEED ) )
               LENJ = ( N-3 ) / 2
               CALL SLARNV( 2, ISEED, LENJ, WORK )
               DO 90 J = 1, LENJ
                  AB( 1, 2*( J+1 ) ) = TNORM*WORK( J )
   90          CONTINUE
            ELSE
               AB( 2, 1 ) = SIGN( TNORM, SLARND( 2, ISEED ) )
               LENJ = ( N-3 ) / 2
               CALL SLARNV( 2, ISEED, LENJ, WORK )
               DO 100 J = 1, LENJ
                  AB( 2, 2*J+1 ) = TNORM*WORK( J )
  100          CONTINUE
            END IF
         ELSE IF( KD.GT.1 ) THEN
*
*           Form a unit triangular matrix T with condition CNDNUM.  T is
*           given by
*                   | 1   +   *                      |
*                   |     1   +                      |
*               T = |         1   +   *              |
*                   |             1   +              |
*                   |                 1   +   *      |
*                   |                     1   +      |
*                   |                          . . . |
*        Each element marked with a '*' is formed by taking the product
*        of the adjacent elements marked with '+'.  The '*'s can be
*        chosen freely, and the '+'s are chosen so that the inverse of
*        T will have elements of the same magnitude as T.
*
*        The two offdiagonals of T are stored in WORK.
*
            STAR1 = SIGN( TNORM, SLARND( 2, ISEED ) )
            SFAC = SQRT( TNORM )
            PLUS1 = SIGN( SFAC, SLARND( 2, ISEED ) )
            DO 110 J = 1, N, 2
               PLUS2 = STAR1 / PLUS1
               WORK( J ) = PLUS1
               WORK( N+J ) = STAR1
               IF( J+1.LE.N ) THEN
                  WORK( J+1 ) = PLUS2
                  WORK( N+J+1 ) = ZERO
                  PLUS1 = STAR1 / PLUS2
*
*                 Generate a new *-value with norm between sqrt(TNORM)
*                 and TNORM.
*
                  REXP = SLARND( 2, ISEED )
                  IF( REXP.LT.ZERO ) THEN
                     STAR1 = -SFAC**( ONE-REXP )
                  ELSE
                     STAR1 = SFAC**( ONE+REXP )
                  END IF
               END IF
  110       CONTINUE
*
*           Copy the tridiagonal T to AB.
*
            IF( UPPER ) THEN
               CALL SCOPY( N-1, WORK, 1, AB( KD, 2 ), LDAB )
               CALL SCOPY( N-2, WORK( N+1 ), 1, AB( KD-1, 3 ), LDAB )
            ELSE
               CALL SCOPY( N-1, WORK, 1, AB( 2, 1 ), LDAB )
               CALL SCOPY( N-2, WORK( N+1 ), 1, AB( 3, 1 ), LDAB )
            END IF
         END IF
*
*     IMAT > 9:  Pathological test cases.  These triangular matrices
*     are badly scaled or badly conditioned, so when used in solving a
*     triangular system they may cause overflow in the solution vector.
*
      ELSE IF( IMAT.EQ.10 ) THEN
*
*        Type 10:  Generate a triangular matrix with elements between
*        -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
*        Make the right hand side large so that it requires scaling.
*
         IF( UPPER ) THEN
            DO 120 J = 1, N
               LENJ = MIN( J, KD+1 )
               CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
               AB( KD+1, J ) = SIGN( TWO, AB( KD+1, J ) )
  120       CONTINUE
         ELSE
            DO 130 J = 1, N
               LENJ = MIN( N-J+1, KD+1 )
               IF( LENJ.GT.0 )
     $            CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
               AB( 1, J ) = SIGN( TWO, AB( 1, J ) )
  130       CONTINUE
         END IF
*
*        Set the right hand side so that the largest value is BIGNUM.
*
         CALL SLARNV( 2, ISEED, N, B )
         IY = ISAMAX( N, B, 1 )
         BNORM = ABS( B( IY ) )
         BSCAL = BIGNUM / MAX( ONE, BNORM )
         CALL SSCAL( N, BSCAL, B, 1 )
*
      ELSE IF( IMAT.EQ.11 ) THEN
*
*        Type 11:  Make the first diagonal element in the solve small to
*        cause immediate overflow when dividing by T(j,j).
*        In type 11, the offdiagonal elements are small (CNORM(j) < 1).
*
         CALL SLARNV( 2, ISEED, N, B )
         TSCAL = ONE / REAL( KD+1 )
         IF( UPPER ) THEN
            DO 140 J = 1, N
               LENJ = MIN( J, KD+1 )
               CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
               CALL SSCAL( LENJ-1, TSCAL, AB( KD+2-LENJ, J ), 1 )
               AB( KD+1, J ) = SIGN( ONE, AB( KD+1, J ) )
  140       CONTINUE
            AB( KD+1, N ) = SMLNUM*AB( KD+1, N )
         ELSE
            DO 150 J = 1, N
               LENJ = MIN( N-J+1, KD+1 )
               CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
               IF( LENJ.GT.1 )
     $            CALL SSCAL( LENJ-1, TSCAL, AB( 2, J ), 1 )
               AB( 1, J ) = SIGN( ONE, AB( 1, J ) )
  150       CONTINUE
            AB( 1, 1 ) = SMLNUM*AB( 1, 1 )
         END IF
*
      ELSE IF( IMAT.EQ.12 ) THEN
*
*        Type 12:  Make the first diagonal element in the solve small to
*        cause immediate overflow when dividing by T(j,j).
*        In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1).
*
         CALL SLARNV( 2, ISEED, N, B )
         IF( UPPER ) THEN
            DO 160 J = 1, N
               LENJ = MIN( J, KD+1 )
               CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
               AB( KD+1, J ) = SIGN( ONE, AB( KD+1, J ) )
  160       CONTINUE
            AB( KD+1, N ) = SMLNUM*AB( KD+1, N )
         ELSE
            DO 170 J = 1, N
               LENJ = MIN( N-J+1, KD+1 )
               CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
               AB( 1, J ) = SIGN( ONE, AB( 1, J ) )
  170       CONTINUE
            AB( 1, 1 ) = SMLNUM*AB( 1, 1 )
         END IF
*
      ELSE IF( IMAT.EQ.13 ) THEN
*
*        Type 13:  T is diagonal with small numbers on the diagonal to
*        make the growth factor underflow, but a small right hand side
*        chosen so that the solution does not overflow.
*
         IF( UPPER ) THEN
            JCOUNT = 1
            DO 190 J = N, 1, -1
               DO 180 I = MAX( 1, KD+1-( J-1 ) ), KD
                  AB( I, J ) = ZERO
  180          CONTINUE
               IF( JCOUNT.LE.2 ) THEN
                  AB( KD+1, J ) = SMLNUM
               ELSE
                  AB( KD+1, J ) = ONE
               END IF
               JCOUNT = JCOUNT + 1
               IF( JCOUNT.GT.4 )
     $            JCOUNT = 1
  190       CONTINUE
         ELSE
            JCOUNT = 1
            DO 210 J = 1, N
               DO 200 I = 2, MIN( N-J+1, KD+1 )
                  AB( I, J ) = ZERO
  200          CONTINUE
               IF( JCOUNT.LE.2 ) THEN
                  AB( 1, J ) = SMLNUM
               ELSE
                  AB( 1, J ) = ONE
               END IF
               JCOUNT = JCOUNT + 1
               IF( JCOUNT.GT.4 )
     $            JCOUNT = 1
  210       CONTINUE
         END IF
*
*        Set the right hand side alternately zero and small.
*
         IF( UPPER ) THEN
            B( 1 ) = ZERO
            DO 220 I = N, 2, -2
               B( I ) = ZERO
               B( I-1 ) = SMLNUM
  220       CONTINUE
         ELSE
            B( N ) = ZERO
            DO 230 I = 1, N - 1, 2
               B( I ) = ZERO
               B( I+1 ) = SMLNUM
  230       CONTINUE
         END IF
*
      ELSE IF( IMAT.EQ.14 ) THEN
*
*        Type 14:  Make the diagonal elements small to cause gradual
*        overflow when dividing by T(j,j).  To control the amount of
*        scaling needed, the matrix is bidiagonal.
*
         TEXP = ONE / REAL( KD+1 )
         TSCAL = SMLNUM**TEXP
         CALL SLARNV( 2, ISEED, N, B )
         IF( UPPER ) THEN
            DO 250 J = 1, N
               DO 240 I = MAX( 1, KD+2-J ), KD
                  AB( I, J ) = ZERO
  240          CONTINUE
               IF( J.GT.1 .AND. KD.GT.0 )
     $            AB( KD, J ) = -ONE
               AB( KD+1, J ) = TSCAL
  250       CONTINUE
            B( N ) = ONE
         ELSE
            DO 270 J = 1, N
               DO 260 I = 3, MIN( N-J+1, KD+1 )
                  AB( I, J ) = ZERO
  260          CONTINUE
               IF( J.LT.N .AND. KD.GT.0 )
     $            AB( 2, J ) = -ONE
               AB( 1, J ) = TSCAL
  270       CONTINUE
            B( 1 ) = ONE
         END IF
*
      ELSE IF( IMAT.EQ.15 ) THEN
*
*        Type 15:  One zero diagonal element.
*
         IY = N / 2 + 1
         IF( UPPER ) THEN
            DO 280 J = 1, N
               LENJ = MIN( J, KD+1 )
               CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
               IF( J.NE.IY ) THEN
                  AB( KD+1, J ) = SIGN( TWO, AB( KD+1, J ) )
               ELSE
                  AB( KD+1, J ) = ZERO
               END IF
  280       CONTINUE
         ELSE
            DO 290 J = 1, N
               LENJ = MIN( N-J+1, KD+1 )
               CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
               IF( J.NE.IY ) THEN
                  AB( 1, J ) = SIGN( TWO, AB( 1, J ) )
               ELSE
                  AB( 1, J ) = ZERO
               END IF
  290       CONTINUE
         END IF
         CALL SLARNV( 2, ISEED, N, B )
         CALL SSCAL( N, TWO, B, 1 )
*
      ELSE IF( IMAT.EQ.16 ) THEN
*
*        Type 16:  Make the offdiagonal elements large to cause overflow
*        when adding a column of T.  In the non-transposed case, the
*        matrix is constructed to cause overflow when adding a column in
*        every other step.
*
         TSCAL = UNFL / ULP
         TSCAL = ( ONE-ULP ) / TSCAL
         DO 310 J = 1, N
            DO 300 I = 1, KD + 1
               AB( I, J ) = ZERO
  300       CONTINUE
  310    CONTINUE
         TEXP = ONE
         IF( KD.GT.0 ) THEN
            IF( UPPER ) THEN
               DO 330 J = N, 1, -KD
                  DO 320 I = J, MAX( 1, J-KD+1 ), -2
                     AB( 1+( J-I ), I ) = -TSCAL / REAL( KD+2 )
                     AB( KD+1, I ) = ONE
                     B( I ) = TEXP*( ONE-ULP )
                     IF( I.GT.MAX( 1, J-KD+1 ) ) THEN
                        AB( 2+( J-I ), I-1 ) = -( TSCAL / REAL( KD+2 ) )
     $                                          / REAL( KD+3 )
                        AB( KD+1, I-1 ) = ONE
                        B( I-1 ) = TEXP*REAL( ( KD+1 )*( KD+1 )+KD )
                     END IF
                     TEXP = TEXP*TWO
  320             CONTINUE
                  B( MAX( 1, J-KD+1 ) ) = ( REAL( KD+2 ) /
     $                                    REAL( KD+3 ) )*TSCAL
  330          CONTINUE
            ELSE
               DO 350 J = 1, N, KD
                  TEXP = ONE
                  LENJ = MIN( KD+1, N-J+1 )
                  DO 340 I = J, MIN( N, J+KD-1 ), 2
                     AB( LENJ-( I-J ), J ) = -TSCAL / REAL( KD+2 )
                     AB( 1, J ) = ONE
                     B( J ) = TEXP*( ONE-ULP )
                     IF( I.LT.MIN( N, J+KD-1 ) ) THEN
                        AB( LENJ-( I-J+1 ), I+1 ) = -( TSCAL /
     $                     REAL( KD+2 ) ) / REAL( KD+3 )
                        AB( 1, I+1 ) = ONE
                        B( I+1 ) = TEXP*REAL( ( KD+1 )*( KD+1 )+KD )
                     END IF
                     TEXP = TEXP*TWO
  340             CONTINUE
                  B( MIN( N, J+KD-1 ) ) = ( REAL( KD+2 ) /
     $                                    REAL( KD+3 ) )*TSCAL
  350          CONTINUE
            END IF
         ELSE
            DO 360 J = 1, N
               AB( 1, J ) = ONE
               B( J ) = REAL( J )
  360       CONTINUE
         END IF
*
      ELSE IF( IMAT.EQ.17 ) THEN
*
*        Type 17:  Generate a unit triangular matrix with elements
*        between -1 and 1, and make the right hand side large so that it
*        requires scaling.
*
         IF( UPPER ) THEN
            DO 370 J = 1, N
               LENJ = MIN( J-1, KD )
               CALL SLARNV( 2, ISEED, LENJ, AB( KD+1-LENJ, J ) )
               AB( KD+1, J ) = REAL( J )
  370       CONTINUE
         ELSE
            DO 380 J = 1, N
               LENJ = MIN( N-J, KD )
               IF( LENJ.GT.0 )
     $            CALL SLARNV( 2, ISEED, LENJ, AB( 2, J ) )
               AB( 1, J ) = REAL( J )
  380       CONTINUE
         END IF
*
*        Set the right hand side so that the largest value is BIGNUM.
*
         CALL SLARNV( 2, ISEED, N, B )
         IY = ISAMAX( N, B, 1 )
         BNORM = ABS( B( IY ) )
         BSCAL = BIGNUM / MAX( ONE, BNORM )
         CALL SSCAL( N, BSCAL, B, 1 )
*
      ELSE IF( IMAT.EQ.18 ) THEN
*
*        Type 18:  Generate a triangular matrix with elements between
*        BIGNUM/KD and BIGNUM so that at least one of the column
*        norms will exceed BIGNUM.
*
         TLEFT = BIGNUM / MAX( ONE, REAL( KD ) )
         TSCAL = BIGNUM*( REAL( KD ) / REAL( KD+1 ) )
         IF( UPPER ) THEN
            DO 400 J = 1, N
               LENJ = MIN( J, KD+1 )
               CALL SLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) )
               DO 390 I = KD + 2 - LENJ, KD + 1
                  AB( I, J ) = SIGN( TLEFT, AB( I, J ) ) +
     $                         TSCAL*AB( I, J )
  390          CONTINUE
  400       CONTINUE
         ELSE
            DO 420 J = 1, N
               LENJ = MIN( N-J+1, KD+1 )
               CALL SLARNV( 2, ISEED, LENJ, AB( 1, J ) )
               DO 410 I = 1, LENJ
                  AB( I, J ) = SIGN( TLEFT, AB( I, J ) ) +
     $                         TSCAL*AB( I, J )
  410          CONTINUE
  420       CONTINUE
         END IF
         CALL SLARNV( 2, ISEED, N, B )
         CALL SSCAL( N, TWO, B, 1 )
      END IF
*
*     Flip the matrix if the transpose will be used.
*
      IF( .NOT.LSAME( TRANS, 'N' ) ) THEN
         IF( UPPER ) THEN
            DO 430 J = 1, N / 2
               LENJ = MIN( N-2*J+1, KD+1 )
               CALL SSWAP( LENJ, AB( KD+1, J ), LDAB-1,
     $                     AB( KD+2-LENJ, N-J+1 ), -1 )
  430       CONTINUE
         ELSE
            DO 440 J = 1, N / 2
               LENJ = MIN( N-2*J+1, KD+1 )
               CALL SSWAP( LENJ, AB( 1, J ), 1, AB( LENJ, N-J+2-LENJ ),
     $                     -LDAB+1 )
  440       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of SLATTB
*
      END

max_stars_repo_name: nashmit/lapack-release

max_issues_repo_name: nashmit/lapack-release

max_forks_repo_name: nashmit/lapack-release


text:
module material_content_test
  use material_content_m, only: material_content_t
  use random_sample_m, only: random_sample_t
  use vegetables, only: test_item_t, describe, it, result_t, assert_that, assert_not
  implicit none
  private
  public :: test_material_content

contains
  function test_material_content() result(tests)

    type(test_item_t) :: tests

    tests = describe( &
        "material_content_t", &
        [ it("is not marked as user_defined initially", check_not_user_defined) &
        , it("is marked as user_defined after being constructed", check_user_defined) &
        , it("contents are not negative", check_contents_not_negative) &
        , it("two material contents are within 6 sigma of eachother", check_difference) &
        ])
  end function

  function check_not_user_defined() result(result_)

    type(result_t) :: result_

    type(material_content_t) :: content

    result_ = assert_not(content%user_defined())
  end function

  function check_user_defined() result(result_)

    type(result_t) :: result_

    type(material_content_t) :: content
    type(random_sample_t) :: samples

    call samples%define()

    content = material_content_t( &
        Cu_ave = 0.1, Ni_ave = 0.2, Cu_sig = 0.01, Ni_sig = 0.01, samples=samples)

    result_ = assert_that(content%user_defined())
  end function

  function check_contents_not_negative() result(result_)
    type(result_t) :: result_

    type(material_content_t) :: content
    type(random_sample_t) :: samples

    call samples%define()

    content = material_content_t( &
        Cu_ave = 0.1, Ni_ave = 0.2, Cu_sig = 0.01, Ni_sig = 0.01, samples=samples)

    result_ = &
        assert_that(content%Cu() > 0.0, "Cu") &
        .and.assert_that(content%Ni() > 0.0, "Ni")
  end function

  function check_difference() result(result_)
    type(result_t) :: result_

    real, parameter :: CU_SIG = 0.01, NI_SIG = 0.01, CU_AVE = 0.1, NI_AVE = 0.2
    type(material_content_t) :: content1
    type(random_sample_t) :: samples1
    type(material_content_t) :: content2
    type(random_sample_t) :: samples2

    call samples1%define()
    call samples2%define()

    content1 = material_content_t( &
        Cu_ave = CU_AVE, Ni_ave = NI_AVE, Cu_sig = CU_SIG, Ni_sig = NI_SIG, samples=samples1)
    content2 = material_content_t( &
        Cu_ave = CU_AVE, Ni_ave = NI_AVE, Cu_sig = CU_SIG, Ni_sig = NI_SIG, samples=samples2)

    result_ = assert_that(content1%within_tolerance(content2, 6.*max(CU_SIG, NI_SIG)))
  end function
end module

max_stars_repo_name: sourceryinstitute/miniFAVOR

max_issues_repo_name: sourceryinstitute/miniFAVOR

max_forks_repo_name: sourceryinstitute/miniFAVOR


text:
module da_sound

   use da_control, only : obs_qc_pointer,max_ob_levels,missing_r, missing_data, &
      check_max_iv_print, check_max_iv_unit, v_interp_p, v_interp_h, &
      check_max_iv, missing, max_error_uv, max_error_t, rootproc, &
      max_error_p,max_error_q, sfc_assi_options, no_buddies, fails_error_max, &
      fails_buddy_check, check_buddy, check_buddy_print, check_buddy_unit, &
      buddy_weight , max_buddy_uv, max_buddy_t, max_buddy_p, max_buddy_rh, &
      max_stheight_diff,test_dm_exact, anal_type_verify, &
      kms,kme,kts,kte,sfc_assi_options_1,sfc_assi_options_2, num_procs, comm, &
      trace_use_dull, sound, sonde_sfc, position_lev_dependant, max_ext_its,qcstat_conv_unit,ob_vars, &
      convert_fd2uv,convert_uv2fd,max_error_spd,max_error_dir,max_omb_spd,max_omb_dir,pi,qc_rej_both, &
      wind_sd_sound, wind_stats_sd, write_rej_obs_conv
   use da_grid_definitions, only : da_ffdduv,da_ffdduv_model, da_ffdduv_diagnose

#ifdef DM_PARALLEL
!  use mpi, only : mpi_integer, mpi_real8, mpi_max
#endif
   use da_define_structures, only : maxmin_type, iv_type, y_type, jo_type, &
      bad_data_type, x_type, number_type, bad_data_type
   use module_domain, only : domain
   use da_interpolation, only : da_to_zk, da_interp_lin_3d, &
      da_interp_lin_3d_adj, da_interp_lin_2d, da_interp_lin_2d_adj, da_interp_lin_2d_partial
   use da_statistics, only : da_stats_calculate
   use da_tools, only : da_max_error_qc, da_residual, da_obs_sfc_correction, da_convert_zk,&
                        da_buddy_qc, da_get_print_lvl
   use da_par_util, only : da_proc_stats_combine, &
      da_deallocate_global_sound, da_to_global_sound, da_to_global_sonde_sfc, &
      da_deallocate_global_sonde_sfc
   use da_par_util1, only : da_proc_sum_int
   use da_physics, only : da_sfc_pre, da_transform_xtopsfc, &
      da_transform_xtopsfc_adj, da_uv_to_sd_lin, da_uv_to_sd_adj
   use da_tracing, only : da_trace_entry, da_trace_exit

   ! The "stats_sound_type" is ONLY used locally in da_sound:

   type residual_sound1_type
      real          :: u                        ! u-wind.
      real          :: v                        ! v-wind.
      real          :: t                        ! temperature
      real          :: q                        ! specific humidity
   end type residual_sound1_type

   type maxmin_sound_stats_type
      type (maxmin_type)         :: u, v, t, q
   end type maxmin_sound_stats_type

   type stats_sound_type
      type (maxmin_sound_stats_type)  :: maximum, minimum
      type (residual_sound1_type)     :: average, rms_err
   end type stats_sound_type

   ! The "stats_sonde_sfc_type" is ONLY used locally in da_sonde_sfc:

   type residual_sonde_sfc1_type
      real          :: u                        ! u-wind.
      real          :: v                        ! v-wind.
      real          :: t                        ! temperature
      real          :: p                        ! pressure
      real          :: q                        ! specific humidity
   end type residual_sonde_sfc1_type

   type maxmin_sonde_sfc_stats_type
      type (maxmin_type)         :: u, v, t, p, q
   end type maxmin_sonde_sfc_stats_type

   type stats_sonde_sfc_type
      type (maxmin_sonde_sfc_stats_type)  :: maximum, minimum
      type (residual_sonde_sfc1_type)     :: average, rms_err
   end type stats_sonde_sfc_type

#ifdef DM_PARALLEL
   include 'mpif.h'
#endif

contains

#include "da_ao_stats_sound.inc"
#include "da_jo_and_grady_sound.inc"
#include "da_jo_sound_uvtq.inc"
#include "da_residual_sound.inc"
#include "da_oi_stats_sound.inc"
#include "da_print_stats_sound.inc"
#include "da_transform_xtoy_sound.inc"
#include "da_transform_xtoy_sound_adj.inc"
#include "da_check_max_iv_sound.inc"
#include "da_get_innov_vector_sound.inc"
#include "da_calculate_grady_sound.inc"
#include "da_check_buddy_sound.inc"

#include "da_ao_stats_sonde_sfc.inc"
#include "da_jo_and_grady_sonde_sfc.inc"
#include "da_jo_sonde_sfc_uvtq.inc"
#include "da_residual_sonde_sfc.inc"
#include "da_oi_stats_sonde_sfc.inc"
#include "da_print_stats_sonde_sfc.inc"
#include "da_transform_xtoy_sonde_sfc.inc"
#include "da_transform_xtoy_sonde_sfc_adj.inc"
#include "da_get_innov_vector_sonde_sfc.inc"
#include "da_check_max_iv_sonde_sfc.inc"
#include "da_calculate_grady_sonde_sfc.inc"

end module da_sound

max_stars_repo_name: matzegoebel/WRF-fluxavg

max_issues_repo_name: teb-model/wrf-teb

max_forks_repo_name: teb-model/wrf-teb


text:
      program Day11
        implicit none
        integer, parameter :: N = 100

        character, dimension(N,N) :: seating=' '
        integer, dimension(N, N) :: counts
        integer :: i, j, k, ios
        logical :: changed = .true.
        character(N) :: line

        do i=1,N
                read (*, '(A)', iostat=ios) line
                if (ios /= 0) exit
                seating(i, 1:N) = [(line(j:j),j=1,N)]
        end do

        do while (changed)
            ! write (*, "(*(A))") ((seating(i,j),j=1,N),new_line("A"),i=1,N)
            changed = .false.

            do i=1,N
                do j=1,N
                    counts(i, j) = count( &
                                 [ spots(seating(i+1:, j)) &
                                 , spots(seating(i-1:1:-1, j)) &
                                 , spots(seating(i, j+1:)) &
                                 , spots(seating(i, j-1:1:-1)) &
                                 , spots([(seating(i+k,j+k),k=1,min(N-i,N-j))]) &
                                 , spots([(seating(i-k,j+k),k=1,min(i-1,N-j))]) &
                                 , spots([(seating(i+k,j-k),k=1,min(N-i,j-1))]) &
                                 , spots([(seating(i-k,j-k),k=1,min(i-1,j-1))]) &
                                 ])
                end do
            end do

            do i=1,N
                do j=1,N
                    if (seating(i, j) .eq. 'L' .and. counts(i,j) .eq. 0) then
                        seating(i, j) = '#'
                        changed = .true.
                    else if (seating(i, j) .eq. '#' .and. counts(i,j) .ge. 5) then
                        seating(i, j) = 'L'
                        changed = .true.
                    end if
                end do
            end do
        end do

      print *, count(seating .eq. '#')

      contains
              ! does the seat spot an occupied seat in the given
              ! direction?
              pure logical function spots(arr)
                implicit none
                character, dimension(:), intent(in) :: arr
                integer, dimension(1) :: occupied, empty

                occupied = findloc(arr, '#')
                empty = findloc(arr, 'L')

                if (occupied(1) .eq. 0) then ! no occupied seat
                        spots = .false.
                else if (empty(1) .eq. 0) then ! no empty seat
                        spots = .true.
                else
                        ! is the occupied seat closer than the empty
                        ! one?
                        spots = occupied(1) .lt. empty(1)
                end if
              end function
      end program

max_stars_repo_name: Porges/adventofcode

max_issues_repo_name: Porges/adventofcode

max_forks_repo_name: Porges/adventofcode


text:
!Write by Liao Yuanda
!
!###############################################################

module modu_skx
contains

    subroutine calcu_p_nearest( p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )
        implicit none
        integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L
        integer :: i, j, i_pl, j_pl, i_mi, j_mi

        i = int((p-1)/L)
        j = mod(p-1,L)
        i_pl = mod(i+1,L)
        j_pl = mod(j+1,L)
        if (i==0) then
            i_mi = L-1
        else
            i_mi = i-1
        end if
        if (j==0) then
            j_mi = L-1
        else
            j_mi = j-1
        end if

        p_i_pl = i_pl*L+j+1
        p_i_mi = i_mi*L+j+1
        p_j_pl = i*L+j_pl+1
        p_j_mi = i*L+j_mi+1
        p_i_pl_j_mi = i_pl*L+j_mi+1
        p_i_mi_j_pl = i_mi*L+j_pl+1

    end subroutine calcu_p_nearest

    subroutine calcu_Hf( L, N, M, Hf, t)
        !###############################################
        !(i,j) to (i, j_new); (i,j) to (i_new,j); N = i+(j-1)*L
        !###############################################
        implicit none
        integer :: L, N, M, i, j
        integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl
        real*8 :: t, Hf(M, M)
        Hf = 0.0
        do i = 0, L-1, 1
            do j = 0, L-1, 1
                p = i*L+j+1
                call calcu_p_nearest( p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )

                Hf(p, p_i_pl) = -t
                Hf(p, p_i_mi) = -t
                Hf(p, p_j_pl) = -t
                Hf(p, p_j_mi) = -t
                Hf(p, p_i_pl_j_mi) = -t
                Hf(p, p_i_mi_j_pl) = -t

                Hf(p+N, p_i_pl+N) = -t
                Hf(p+N, p_i_mi+N) = -t
                Hf(p+N, p_j_pl+N) = -t
                Hf(p+N, p_j_mi+N) = -t
                Hf(p+N, p_i_pl_j_mi+N) = -t
                Hf(p+N, p_i_mi_j_pl+N) = -t
            end do
        end do
    end subroutine calcu_Hf

    subroutine calcu_H( N, M, Hf, H, J_k, fai, theta )
        implicit none
        integer :: N, M, i
        real*8 :: J_k, fai(N), theta(N), Hf(M,M)
        complex*16 :: H(M, M)

        H = (0.0, 0.0)

        do i = 1, N
            H(i, i) = -J_k*cos(theta(i))
            H(i+N, i+N) = J_k*cos(theta(i))
            H(i+N, i) = -J_k*sin(theta(i))*exp( cmplx(0.0, fai(i)) )
            H(i, i+N) = -J_k*sin(theta(i))*exp( cmplx(0.0, fai(i)*(-1)) )
        end do
        H= Hf+H

    end subroutine calcu_H

    subroutine calcu_Hp( p, L, J_H, lambda, fai, theta, Hp)
        implicit none
        integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L
        real*8 :: J_H, lambda, fai(L*L), theta(L*L), Hp
        Hp = 0.0
        call calcu_p_nearest( p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )

        Hp = Hp-J_H*( sin(theta(p))*sin(theta(p_i_pl))*cos(fai(p)-fai(p_i_pl))+cos(theta(p))*cos(theta(p_i_pl)) )
        Hp = Hp-J_H*( sin(theta(p))*sin(theta(p_i_mi))*cos(fai(p)-fai(p_i_mi))+cos(theta(p))*cos(theta(p_i_mi)) )
        Hp = Hp-J_H*( sin(theta(p))*sin(theta(p_j_pl))*cos(fai(p)-fai(p_j_pl))+cos(theta(p))*cos(theta(p_j_pl)) )
        Hp = Hp-J_H*( sin(theta(p))*sin(theta(p_j_mi))*cos(fai(p)-fai(p_j_mi))+cos(theta(p))*cos(theta(p_j_mi)) )
        Hp = Hp-J_H*( sin(theta(p))*sin(theta(p_i_pl_j_mi))*cos(fai(p)-fai(p_i_pl_j_mi))+cos(theta(p))*cos(theta(p_i_pl_j_mi)) )
        Hp = Hp-J_H*( sin(theta(p))*sin(theta(p_i_mi_j_pl))*cos(fai(p)-fai(p_i_mi_j_pl))+cos(theta(p))*cos(theta(p_i_mi_j_pl)) )

        Hp = Hp-lambda*( sin(theta(p))*sin(fai(p))*cos(theta(p_i_pl))-cos(theta(p))*sin(theta(p_i_pl))*sin(fai(p_i_pl)) )
        Hp = Hp+lambda*( sin(theta(p))*sin(fai(p))*cos(theta(p_i_mi))-cos(theta(p))*sin(theta(p_i_mi))*sin(fai(p_i_mi)) )
        Hp = Hp-(sqrt(3.0)/2)*lambda*( cos(theta(p))*sin(theta(p_j_pl))*cos(fai(p_j_pl))&
            -sin(theta(p))*cos(fai(p))*cos(theta(p_j_pl)) )&
            -(1.0/2)*lambda*( sin(theta(p))*sin(fai(p))*cos(theta(p_j_pl))-cos(theta(p))*sin(theta(p_j_pl))*sin(fai(p_j_pl)) )
        Hp = Hp+(sqrt(3.0)/2)*lambda*( cos(theta(p))*sin(theta(p_j_mi))*cos(fai(p_j_mi))&
            -sin(theta(p))*cos(fai(p))*cos(theta(p_j_mi)) )&
            +(1.0/2)*lambda*( sin(theta(p))*sin(fai(p))*cos(theta(p_j_mi))-cos(theta(p))*sin(theta(p_j_mi))*sin(fai(p_j_mi)) )
        Hp = Hp-lambda*(1.0/2)*( sin(theta(p))*sin(fai(p))*cos(theta(p_i_pl_j_mi))&
            -cos(theta(p))*sin(theta(p_i_pl_j_mi))*sin(fai(p_i_pl_j_mi)) )&
            +lambda*(sqrt(3.0)/2)*( cos(theta(p))*sin(theta(p_i_pl_j_mi))*cos(fai(p_i_pl_j_mi))&
            -sin(theta(p))*cos(fai(p))*cos(theta(p_i_pl_j_mi)) )
        Hp = Hp+lambda*(1.0/2)*( sin(theta(p))*sin(fai(p))*cos(theta(p_i_mi_j_pl))&
            -cos(theta(p))*sin(theta(p_i_mi_j_pl))*sin(fai(p_i_mi_j_pl)) )&
            -lambda*(sqrt(3.0)/2)*( cos(theta(p))*sin(theta(p_i_mi_j_pl))*cos(fai(p_i_mi_j_pl))&
            -sin(theta(p))*cos(fai(p))*cos(theta(p_i_mi_j_pl)) )
        !write(*,*) Hp

    end subroutine calcu_Hp

    subroutine calcu_V( L, J_H, lambda, fai, theta, H, V )
        implicit none
        integer :: p, L, i, j
        real*8 :: J_H, lambda, fai(L*L), theta(L*L), H(L*L), V
        V = 0.0

        do i = 1,L
            do j = 1,L
                p = (i-1)*L+j
                call calcu_Hp( p, L, J_H, lambda, fai, theta, H(p))
                V = V+H(p)
            end do
        end do!
        V = V/2
        !write(*,*) V

    end subroutine calcu_V

    subroutine calcu_deltaV(L, N, B_z, theta, deltaV)
        implicit none
        integer :: L, i, j, N_ij, N
        real*8 :: B_z, theta(N), deltaV
        deltaV = 0
        do i = 0, L-1, 1
            do j = 0, L-1, 1
                N_ij = i*L+j+1
                deltaV = deltaV+B_z*cos(theta(N_ij))
            end do
        end do

    end subroutine calcu_deltaV

end module modu_skx

real(8) function ran()
!----------------------------------------------!
! 64-bit congruental generator                 !
! iran64=oran64*2862933555777941757+1013904243 !
!----------------------------------------------!
    implicit none

    real(8)    :: dmu64
    integer(8) :: ran64,mul64,add64
    common/bran64/dmu64,ran64,mul64,add64

    ran64=ran64*mul64+add64
    ran=0.5d0+dmu64*dble(ran64)

end function ran
!----------------!

!---------------------!
subroutine initran(w)
!---------------------!
    implicit none

    integer(8) :: irmax
    integer(4) :: w,nb,b

    real(8)    :: dmu64
    integer(8) :: ran64,mul64,add64
    common/bran64/dmu64,ran64,mul64,add64

    irmax=2_8**31
    irmax=2*(irmax**2-1)+1
    mul64=2862933555777941757_8
    add64=1013904243
    dmu64=0.5d0/dble(irmax)

    open(10,file='seed.in',status='old')

    read(10,*)ran64
    close(10)
    if (w.ne.0) then
        open(10,file='seed.in',status='unknown')
        write(10,*) abs((ran64*mul64)/5+5265361)
        close(10)
    end if

end subroutine initran
!----------------------!

!function to less dimension
integer function di(d)
    integer :: d
    if (d == 1) then
        di = 2
    end if
    if ( d == 2) then
        di =1
    end if
end function

program skyrmionlattice
  	use globle_vab
    use modu_skx
    implicit none
    external ctofortran
    !#########################################
    !L, size of lattice
    !N = L*L, num of lattice
    !t, J_k, the parameter if H
    !##########################################
    integer, parameter :: L = 20, N = L*L, M = 2*N, num_T_para = 20, num_MC = 4*10**4, nonzeros = 8*M
    real*8, parameter :: t = 1.0
    integer :: i, j, k, ii, r, d, di, dd, ij, aver_num, cutoff, cutoff_dos
    integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, p_p, p_pN, pN_p, pN_pN
    real*8 :: ran, J_k, Tc, x, Weight_fermi, Weight_fermi_new, t1, t2
    real*8 :: V, deltaV, ln_Weight_fermi_new, J_H, lambda, B_z, pa, Hp, energy_aver, energy_aver_B
    integer, dimension(nonzeros) :: colind
    integer, dimension(M+1) :: rowptr
    real*8, dimension(2,N) :: fai, theta
    real*8, dimension(num_T_para) :: T_para
    real*8, dimension(N) :: Hc
    complex*16, dimension(nonzeros) :: values
    !real*8, dimension(M,M) :: Hf
    real*8, allocatable :: Hf(:,:), moments(:), coeffs(:)
    complex*16, allocatable :: H(:,:)
    integer, dimension(1) :: mloc
    character(len=2) :: cha
    real*8, external :: logweight_func

    !##########################
    call cpu_time(t1)
    write(*,*) 'Begin at:', t1
    !######################

    open( unit =12, file = 'miu.in')
    read(12,*) miu
    J_k = t
    J_H = t
    lambda = 0.4*PI*t

    B_z = 0.4*J_H

	cutoff = 40
	cutoff_dos = 100
    Emax = 3*t+J_k
    Emin = -6*t-J_k
    a = (Emax-Emin)/2.0
    b = (Emax+Emin)/2.0

    d = 1
    aver_num = 100
    T_para = (/ 1.0, 0.95, 0.9, 0.85, 0.8, 0.75, 0.7, 0.65, 0.6, 0.55, 0.5, 0.45, 0.4, 0.35, 0.3, 0.25, 0.2, 0.15, 0.1, 0.05/)

    open(unit = 15, file = 'T_energyaver.out')
    call initran(1)

    do i = 1, N
        x = ran()
        fai(d,i) = x*2*PI
        x = ran()
        theta(d,i) = x*PI
    end do

    call calcu_V( L, J_H, lambda, fai(d,:), theta(d,:), Hc, V )

    call initran(1)
	allocate( Hf(M,M), H(M,M) )
    call calcu_Hf( L, N, M, Hf, t )
    call calcu_H( N, M, Hf, H, J_k, fai(d,:), theta(d,:))
	deallocate(Hf)
	call pem_sparse( H, values, colind, rowptr, M, nonzeros)
	deallocate(H)

do ii = 1, num_T_para

    energy_aver = 0.0
    energy_aver_B = 0.0

    write(cha,'(i2)') ii
    open(unit = 13, file = 'energy'//adjustl(trim(cha))//'.out' )
    open( unit = 14, file = 'lattice'//adjustl(trim(cha))//'.out' )
	open(unit = 16, file = 'pem_moments'//adjustl(trim(cha))//'.out')
    write(*,*) num_T_para-ii
    Tc = T_para(ii)*J_H
    beta = 1.0/Tc

	!call the subroutine after beta is defined
	allocate(coeffs(cutoff))
    call pem_calculate_coeffs(cutoff, coeffs, logweight_func)

	allocate(moments(cutoff))
	call pem_calculate_moments(cutoff, M, nonzeros, values, colind, rowptr, moments)
	call pem_kernel_expansion(cutoff, moments, coeffs, Weight_fermi)
	deallocate(moments)
    do i = 1, num_MC
        dd = di(d)
        x = ran()
        r = int(x*N)+1
        fai(dd,:) = fai(d,:)
        theta(dd,:) = theta(d,:)
        x = ran()
        fai(dd, r) = fai(d,r)+(x-0.5)*2*2*PI/12
        if ( fai(dd,r) < 0 ) then
            fai(dd,r) = fai(dd,r)+2*PI
        end if
        if ( fai(dd,r) > 2*PI ) then
            fai(dd,r) = fai(dd,r)-2*PI
        end if
        x = ran()
        theta(dd, r) = theta(d,r)+(x-0.5)*2*PI/6
        if ( theta(dd,r) < 0 ) then
            theta(dd,r) = theta(dd,r)+PI
        end if
        if (theta(dd,r) > PI ) then
            theta(dd,r) = theta(dd,r)-PI
        end if
		call diag_position(r, p_p, p_pN, pN_p, pN_pN, L)
        values(p_p) = ( -J_k*cos(theta(dd,r))-b )/a
        values(pN_pN) = ( J_k*cos(theta(dd,r))-b )/a
        values(pN_p) = -J_k*sin(theta(dd,r))*exp( cmplx(0.0, fai(dd,r)) )/a
        values(p_pN) = -J_k*sin(theta(dd,r))*exp( cmplx(0.0, fai(dd,r)*(-1)) )/a
		allocate(moments(cutoff))
		call pem_calculate_moments(cutoff, M, nonzeros, values, colind, rowptr, moments)
		call pem_kernel_expansion(cutoff, moments, coeffs, Weight_fermi_new)
		deallocate(moments)

        call calcu_Hp( r, L, J_H, lambda, fai(dd,:), theta(dd,:), Hp)
        deltaV = B_z*( cos(theta(dd,r))-cos(theta(d,r)) )
        x = ran()

        !write(*,*) x, '<?', exp( Weight_fermi_new-Weight_fermi-beta*(Hp-Hc(r)+deltav) )
        !write(*,*) Weight_fermi, Weight_fermi_new
        !write(*,*) V, V+Hp-Hc(r)
        if ( x > exp( Weight_fermi_new-Weight_fermi-beta*(Hp-Hc(r)+deltaV) ) ) then
            fai(dd,r) = fai(d,r)
            theta(dd, r) = theta(d, r)
            values(p_p) = ( -J_k*cos(theta(d,r))-b )/a
            values(pN_PN) = ( J_k*cos(theta(d,r))-b )/a
            values(pN_p) = -J_k*sin(theta(d,r))*exp( cmplx(0.0, fai(d,r)) )/a
            values(p_pN) = -J_k*sin(theta(d,r))*exp( cmplx(0.0, fai(d,r)*(-1)) )/a
        else
        	Weight_fermi = Weight_fermi_new
            V = V+Hp-Hc(r)
            Hc(r) = Hp
            call calcu_p_nearest( r, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )
            call calcu_Hp( p_i_pl, L, J_H, lambda, fai(dd,:), theta(dd,:), Hc(p_i_pl))
            call calcu_Hp( p_i_mi, L, J_H, lambda, fai(dd,:), theta(dd,:), Hc(p_i_mi))
            call calcu_Hp( p_j_pl, L, J_H, lambda, fai(dd,:), theta(dd,:), Hc(p_j_pl))
            call calcu_Hp( p_j_mi, L, J_H, lambda, fai(dd,:), theta(dd,:), Hc(p_j_mi))
            call calcu_Hp( p_i_pl_j_mi, L, J_H, lambda, fai(dd,:), theta(dd,:), Hc(p_i_pl_j_mi))
            call calcu_Hp( p_i_mi_j_pl, L, J_H, lambda, fai(dd,:), theta(dd,:), Hc(p_i_mi_j_pl))
        end if
        d = dd
        if ( i > num_MC-aver_num*N ) then
            if ( mod(i+aver_num*N-num_MC, N) == 0 ) then
                energy_aver = energy_aver+V
                call calcu_deltaV(L, N, B_z, theta(d,:), deltaV)
                energy_aver_B = energy_aver_B+V+deltav
                do j = 1, N
                    write(14,*) theta(d,j), fai(d,j)
                end do
				allocate(moments(cutoff_dos))
				call pem_calculate_moments(cutoff_dos, M, nonzeros, values, colind, rowptr, moments)
				write(16,*) moments
				deallocate(moments)
            end if
        end if
        write(13,*) V
    end do

	deallocate(coeffs)

    close(13)
    close(14)
	close(16)

    energy_aver = energy_aver/aver_num
    energy_aver_B = energy_aver_B/aver_num
    write(15,*) T_para(ii), energy_aver, energy_aver_B

end do

    close(15)

    !##########################
    call cpu_time(t2)
    write(*,*) 'End at:', t2
    !######################
    write(*,*) 'Timecost:', t2-t1
end program skyrmionlattice

max_stars_repo_name: Greatliao/skyrmions

max_issues_repo_name: Greatliao/skyrmions

max_forks_repo_name: Greatliao/skyrmions